(** * Poly: Polymorphism and Higher-Order Functions *)

(* Final reminder: Please do not put solutions to the exercises in
   publicly accessible places.  Thank you!! *)

(* Suppress some annoying warnings from Coq: *)
Set Warnings "-notation-overridden,-parsing".
From lf Require Export Lists.

(*** Polymorphism *)

(** In this chapter we continue our development of basic
    concepts of functional programming.  The critical new ideas are
    _polymorphism_ (abstracting functions over the types of the data
    they manipulate) and _higher-order functions_ (treating functions
    as data).  We begin with polymorphism. *)

(* ================================================================= *)
(** ** Polymorphic Lists *)

(** For the last couple of chapters, we've been working just
    with lists of numbers.  Obviously, interesting programs also need
    to be able to manipulate lists with elements from other types --
    lists of strings, lists of booleans, lists of lists, etc.  We
    _could_ just define a new inductive datatype for each of these,
    for example... *)

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

(** ... but this would quickly become tedious, partly because we
    have to make up different constructor names for each datatype, but
    mostly because we would also need to define new versions of all
    our list manipulating functions ([length], [rev], etc.) for each
    new datatype definition. *)

(** To avoid all this repetition, Coq supports _polymorphic_
    inductive type definitions.  For example, here is a _polymorphic
    list_ datatype. *)

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

(** This is exactly like the definition of [natlist] from the
    previous chapter, except that the [nat] argument to the [cons]
    constructor has been replaced by an arbitrary type [X], a binding
    for [X] has been added to the header, and the occurrences of
    [natlist] in the types of the constructors have been replaced by
    [list X].  (We can re-use the constructor names [nil] and [cons]
    because the earlier definition of [natlist] was inside of a
    [Module] definition that is now out of scope.)

    What sort of thing is [list] itself?  One good way to think
    about it is that [list] is a _function_ from [Type]s to
    [Inductive] definitions; or, to put it another way, [list] is a
    function from [Type]s to [Type]s.  For any particular type [X],
    the type [list X] is an [Inductive]ly defined set of lists whose
    elements are of type [X]. *)

Check list.
(* ===> list : Type -> Type *)

(** The parameter [X] in the definition of [list] becomes a parameter
    to the constructors [nil] and [cons] -- that is, [nil] and [cons]
    are now polymorphic constructors, that need to be supplied with
    the type of the list they are building. As an example, [nil nat]
    constructs the empty list of type [nat]. *)

Check (nil nat).
(* ===> nil nat : list nat *)

(** Similarly, [cons nat] adds an element of type [nat] to a list of
    type [list nat]. Here is an example of forming a list containing
    just the natural number 3.*)

Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)

(** What might the type of [nil] be? We can read off the type [list X]
    from the definition, but this omits the binding for [X] which is
    the parameter to [list]. [Type -> list X] does not explain the
    meaning of [X]. [(X : Type) -> list X] comes closer. Coq's
    notation for this situation is [forall X : Type, list X]. *)

Check nil.
(* ===> nil : forall X : Type, list X *)

(** Similarly, the type of [cons] as read off from the definition is
    [X -> list X -> list X], but using this convention to explain the
    meaning of [X] results in the type [forall X, X -> list X -> list
    X]. *)

Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** (Side note on notation: In .v files, the "forall" quantifier
    is spelled out in letters.  In the generated HTML files and in the
    way various IDEs show .v files (with certain settings of their
    display controls), [forall] is usually typeset as the usual
    mathematical "upside down A," but you'll still see the spelled-out
    "forall" in a few places.  This is just a quirk of typesetting:
    there is no difference in meaning.) *)

(** Having to supply a type argument for each use of a list
    constructor may seem an awkward burden, but we will soon see
    ways of reducing that burden. *)

Check (cons nat 2 (cons nat 1 (nil nat))).

(** (We've written [nil] and [cons] explicitly here because we haven't
    yet defined the [ [] ] and [::] notations for the new version of
    lists.  We'll do that in a bit.) *)

(** We can now go back and make polymorphic versions of all the
    list-processing functions that we wrote before.  Here is [repeat],
    for example: *)

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

(** As with [nil] and [cons], we can use [repeat] by applying it
    first to a type and then to an element of this type (and a number): *)

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
MProof. reflexivity.  Qed.

(** To use [repeat] to build other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
MProof. reflexivity.  Qed.

Module MumbleGrumble.

(** **** Exercise: 2 stars (mumble_grumble)  *)
(** Consider the following two inductively defined types. *)

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?
      - [d (b a 5)]
      - [d mumble (b a 5)]
      - [d bool (b a 5)]
      - [e bool true]
      - [e mumble (b c 0)]
      - [e bool (b c 0)]
      - [c]
(* FILL IN HERE *)
*)
(** [] *)

End MumbleGrumble.

(* ----------------------------------------------------------------- *)
(** *** Type Annotation Inference *)

(** Let's write the definition of [repeat] again, but this time we
    won't specify the types of any of the arguments.  Will Coq still
    accept it? *)

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

(** Indeed it will.  Let's see what type Coq has assigned to [repeat']: *)

Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)

(** It has exactly the same type type as [repeat].  Coq was able
    to use _type inference_ to deduce what the types of [X], [x], and
    [count] must be, based on how they are used.  For example, since
    [X] is used as an argument to [cons], it must be a [Type], since
    [cons] expects a [Type] as its first argument; matching [count]
    with [0] and [S] means it must be a [nat]; and so on.

    This powerful facility means we don't always have to write
    explicit type annotations everywhere, although explicit type
    annotations are still quite useful as documentation and sanity
    checks, so we will continue to use them most of the time.  You
    should try to find a balance in your own code between too many
    type annotations (which can clutter and distract) and too
    few (which forces readers to perform type inference in their heads
    in order to understand your code). *)

(* ----------------------------------------------------------------- *)
(** *** Type Argument Synthesis *)

(** To use a polymorphic function, we need to pass it one or
    more types in addition to its other arguments.  For example, the
    recursive call in the body of the [repeat] function above must
    pass along the type [X].  But since the second argument to
    [repeat] is an element of [X], it seems entirely obvious that the
    first argument can only be [X] -- why should we have to write it
    explicitly?

    Fortunately, Coq permits us to avoid this kind of redundancy.  In
    place of any type argument we can write the "implicit argument"
    [_], which can be read as "Please try to figure out for yourself
    what belongs here."  More precisely, when Coq encounters a [_], it
    will attempt to _unify_ all locally available information -- the
    type of the function being applied, the types of the other
    arguments, and the type expected by the context in which the
    application appears -- to determine what concrete type should
    replace the [_].

    This may sound similar to type annotation inference -- indeed, the
    two procedures rely on the same underlying mechanisms.  Instead of
    simply omitting the types of some arguments to a function, like

      repeat' X x count : list X :=

    we can also replace the types with [_]

      repeat' (X : _) (x : _) (count : _) : list X :=

    to tell Coq to attempt to infer the missing information.

    Using implicit arguments, the [repeat] function can be written like
    this: *)

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

(** In this instance, we don't save much by writing [_] instead of
    [X].  But in many cases the difference in both keystrokes and
    readability is nontrivial.  For example, suppose we want to write
    down a list containing the numbers [1], [2], and [3].  Instead of
    writing this... *)

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

(** ...we can use argument synthesis to write this: *)

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

(* ----------------------------------------------------------------- *)
(** *** Implicit Arguments *)

(** We can go further and even avoid writing [_]'s in most cases by
    telling Coq _always_ to infer the type argument(s) of a given
    function.

    The [Arguments] directive specifies the name of the function (or
    constructor) and then lists its argument names, with curly braces
    around any arguments to be treated as implicit.  (If some
    arguments of a definition don't have a name, as is often the case
    for constructors, they can be marked with a wildcard pattern
    [_].) *)

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

(** Now, we don't have to supply type arguments at all: *)

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

(** Alternatively, we can declare an argument to be implicit
    when defining the function itself, by surrounding it in curly
    braces instead of parens.  For example: *)

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

(** (Note that we didn't even have to provide a type argument to the
    recursive call to [repeat''']; indeed, it would be invalid to
    provide one!)

    We will use the latter style whenever possible, but we will
    continue to use explicit [Argument] declarations for [Inductive]
    constructors.  The reason for this is that marking the parameter
    of an inductive type as implicit causes it to become implicit for
    the type itself, not just for its constructors.  For instance,
    consider the following alternative definition of the [list]
    type: *)

Inductive list' {X:Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

(** Because [X] is declared as implicit for the _entire_ inductive
    definition including [list'] itself, we now have to write just
    [list'] whether we are talking about lists of numbers or booleans
    or anything else, rather than [list' nat] or [list' bool] or
    whatever; this is a step too far. *)

(** Let's finish by re-implementing a few other standard list
    functions on our new polymorphic lists... *)

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

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

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

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

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

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

(* ----------------------------------------------------------------- *)
(** *** Supplying Type Arguments Explicitly *)

(** One small problem with declaring arguments [Implicit] is
    that, occasionally, Coq does not have enough local information to
    determine a type argument; in such cases, we need to tell Coq that
    we want to give the argument explicitly just this time.  For
    example, suppose we write this: *)

Fail Definition mynil := nil.

(** (The [Fail] qualifier that appears before [Definition] can be
    used with _any_ command, and is used to ensure that that command
    indeed fails when executed. If the command does fail, Coq prints
    the corresponding error message, but continues processing the rest
    of the file.)

    Here, Coq gives us an error because it doesn't know what type
    argument to supply to [nil].  We can help it by providing an
    explicit type declaration (so that Coq has more information
    available when it gets to the "application" of [nil]): *)

Definition mynil : list nat := nil.

(** Alternatively, we can force the implicit arguments to be explicit by
   prefixing the function name with [@]. *)

Check @nil.

Definition mynil' := @nil nat.

(** Using argument synthesis and implicit arguments, we can
    define convenient notation for lists, as before.  Since we have
    made the constructor type arguments implicit, Coq will know to
    automatically infer these when we use the notations. *)

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

(** Now lists can be written just the way we'd hope: *)

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

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

(** **** Exercise: 2 stars, optional (poly_exercises)  *)
(** Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Complete the proofs below. *)

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
MProof.
  (* FILL IN HERE *) Admitted.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
MProof.
  (* FILL IN HERE *) Admitted.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
MProof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (more_poly_exercises)  *)
(** Here are some slightly more interesting ones... *)

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
MProof.
  (* FILL IN HERE *) Admitted.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
MProof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Polymorphic Pairs *)

(** Following the same pattern, the type definition we gave in
    the last chapter for pairs of numbers can be generalized to
    _polymorphic pairs_, often called _products_: *)

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

(** As with lists, we make the type arguments implicit and define the
    familiar concrete notation. *)

Notation "( x , y )" := (pair x y).

(** We can also use the [Notation] mechanism to define the standard
    notation for product _types_: *)

Notation "X * Y" := (prod X Y) : type_scope.

(** (The annotation [: type_scope] tells Coq that this abbreviation
    should only be used when parsing types.  This avoids a clash with
    the multiplication symbol.) *)

(** It is easy at first to get [(x,y)] and [X*Y] confused.
    Remember that [(x,y)] is a _value_ built from two other values,
    while [X*Y] is a _type_ built from two other types.  If [x] has
    type [X] and [y] has type [Y], then [(x,y)] has type [X*Y]. *)

(** The first and second projection functions now look pretty
    much as they would in any functional programming language. *)

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

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

(** The following function takes two lists and combines them
    into a list of pairs.  In other functional languages, it is often
    called [zip]; we call it [combine] for consistency with Coq's
    standard library. *)

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

(** **** Exercise: 1 star, optional (combine_checks)  *)
(** Try answering the following questions on paper and
    checking your answers in coq:
    - What is the type of [combine] (i.e., what does [Check
      @combine] print?)
    - What does

        Compute (combine [1;2] [false;false;true;true]).

      print? *)
(** [] *)

(** **** Exercise: 2 stars, recommended (split)  *)
(** The function [split] is the right inverse of [combine]: it takes a
    list of pairs and returns a pair of lists.  In many functional
    languages, it is called [unzip].

    Fill in the definition of [split] below.  Make sure it passes the
    given unit test. *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y)
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
MProof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Polymorphic Options *)

(** One last polymorphic type for now: _polymorphic options_,
    which generalize [natoption] from the previous chapter: *)

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

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

(** We can now rewrite the [nth_error] function so that it works
    with any type of lists. *)

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

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

(** **** Exercise: 1 star, optional (hd_error_poly)  *)
(** Complete the definition of a polymorphic version of the
    [hd_error] function from the last chapter. Be sure that it
    passes the unit tests below. *)

Definition hd_error {X : Type} (l : list X) : option X
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** Once again, to force the implicit arguments to be explicit,
    we can use [@] before the name of the function. *)

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
 (* FILL IN HERE *) Admitted.
Example test_hd_error2 : hd_error  [ [1];[2]]  = Some [1].
 (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Functions as Data *)

(** Like many other modern programming languages -- including
    all functional languages (ML, Haskell, Scheme, Scala, Clojure,
    etc.) -- Coq treats functions as first-class citizens, allowing
    them to be passed as arguments to other functions, returned as
    results, stored in data structures, etc.*)

(* ================================================================= *)
(** ** Higher-Order Functions *)

(** Functions that manipulate other functions are often called
    _higher-order_ functions.  Here's a simple one: *)

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

(** The argument [f] here is itself a function (from [X] to
    [X]); the body of [doit3times] applies [f] three times to some
    value [n]. *)

Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

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

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

(* ================================================================= *)
(** ** Filter *)

(** Here is a more useful higher-order function, taking a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filtering" the list, returning a new list containing just
    those elements for which the predicate returns [true]. *)

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

(** For example, if we apply [filter] to the predicate [evenb]
    and a list of numbers [l], it returns a list containing just the
    even members of [l]. *)

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

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

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

(** We can use [filter] to give a concise version of the
    [countoddmembers] function from the [Lists] chapter. *)

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1:   countoddmembers' [1;0;3;1;4;5] = 4.
MProof. reflexivity.  Qed.
Example test_countoddmembers'2:   countoddmembers' [0;2;4] = 0.
MProof. reflexivity.  Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0.
MProof. reflexivity.  Qed.

(* ================================================================= *)
(** ** Anonymous Functions *)

(** It is arguably a little sad, in the example just above, to
    be forced to define the function [length_is_1] and give it a name
    just to be able to pass it as an argument to [filter], since we
    will probably never use it again.  Moreover, this is not an
    isolated example: when using higher-order functions, we often want
    to pass as arguments "one-off" functions that we will never use
    again; having to give each of these functions a name would be
    tedious.

    Fortunately, there is a better way.  We can construct a function
    "on the fly" without declaring it at the top level or giving it a
    name. *)

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
MProof. reflexivity.  Qed.

(** The expression [(fun n => n * n)] can be read as "the function
    that, given a number [n], yields [n * n]." *)

(** Here is the [filter] example, rewritten to use an anonymous
    function. *)

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
MProof. reflexivity.  Qed.

(** **** Exercise: 2 stars (filter_even_gt7)  *)
(** Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)

Definition filter_even_gt7 (l : list nat) : list nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
 (* FILL IN HERE *) Admitted.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
 (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (partition)  *)
(** Use [filter] to write a Coq function [partition]:

      partition : forall X : Type,
                  (X -> bool) -> list X -> list X * list X

   Given a set [X], a test function of type [X -> bool] and a [list
   X], [partition] should return a pair of lists.  The first member of
   the pair is the sublist of the original list containing the
   elements that satisfy the test, and the second is the sublist
   containing those that fail the test.  The order of elements in the
   two sublists should be the same as their order in the original
   list. *)

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
(* FILL IN HERE *) Admitted.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** Map *)

(** Another handy higher-order function is called [map]. *)

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

(** It takes a function [f] and a list [ l = [n1, n2, n3, ...] ]
    and returns the list [ [f n1, f n2, f n3,...] ], where [f] has
    been applied to each element of [l] in turn.  For example: *)

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

(** The element types of the input and output lists need not be
    the same, since [map] takes _two_ type arguments, [X] and [Y]; it
    can thus be applied to a list of numbers and a function from
    numbers to booleans to yield a list of booleans: *)

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

(** It can even be applied to a list of numbers and
    a function from numbers to _lists_ of booleans to
    yield a _list of lists_ of booleans: *)

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

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

(** **** Exercise: 3 stars (map_rev)  *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
MProof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, recommended (flat_map)  *)
(** The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:

        flat_map (fun n => [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12].
*)

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y)
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
 (* FILL IN HERE *) Admitted.
(** [] *)

(** Lists are not the only inductive type that we can write a
    [map] function for.  Here is the definition of [map] for the
    [option] type: *)

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

(** **** Exercise: 2 stars, optional (implicit_args)  *)
(** The definitions and uses of [filter] and [map] use implicit
    arguments in many places.  Replace the curly braces around the
    implicit arguments with parentheses, and then fill in explicit
    type parameters where necessary and use Coq to check that you've
    done so correctly.  (This exercise is not to be turned in; it is
    probably easiest to do it on a _copy_ of this file that you can
    throw away afterwards.)
*)
(** [] *)

(* ================================================================= *)
(** ** Fold *)

(** An even more powerful higher-order function is called
    [fold].  This function is the inspiration for the "[reduce]"
    operation that lies at the heart of Google's map/reduce
    distributed programming framework. *)

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

(** Intuitively, the behavior of the [fold] operation is to
    insert a given binary operator [f] between every pair of elements
    in a given list.  For example, [ fold plus [1;2;3;4] ] intuitively
    means [1+2+3+4].  To make this precise, we also need a "starting
    element" that serves as the initial second input to [f].  So, for
    example,

       fold plus [1;2;3;4] 0

    yields

       1 + (2 + (3 + (4 + 0))).

    Some more examples: *)

Check (fold andb).
(* ===> fold andb : list bool -> bool -> bool *)

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

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

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

(** **** Exercise: 1 star, advanced (fold_types_different)  *)
(** Observe that the type of [fold] is parameterized by _two_ type
    variables, [X] and [Y], and the parameter [f] is a binary operator
    that takes an [X] and a [Y] and returns a [Y].  Can you think of a
    situation where it would be useful for [X] and [Y] to be
    different? *)

(* FILL IN HERE *)
(** [] *)

(* ================================================================= *)
(** ** Functions That Construct Functions *)

(** Most of the higher-order functions we have talked about so
    far take functions as arguments.  Let's look at some examples that
    involve _returning_ functions as the results of other functions.
    To begin, here is a function that takes a value [x] (drawn from
    some type [X]) and returns a function from [nat] to [X] that
    yields [x] whenever it is called, ignoring its [nat] argument. *)

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

Definition ftrue := constfun true.

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

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

(** In fact, the multiple-argument functions we have already
    seen are also examples of passing functions as data.  To see why,
    recall the type of [plus]. *)

Check plus.
(* ==> nat -> nat -> nat *)

(** Each [->] in this expression is actually a _binary_ operator
    on types.  This operator is _right-associative_, so the type of
    [plus] is really a shorthand for [nat -> (nat -> nat)] -- i.e., it
    can be read as saying that "[plus] is a one-argument function that
    takes a [nat] and returns a one-argument function that takes
    another [nat] and returns a [nat]."  In the examples above, we
    have always applied [plus] to both of its arguments at once, but
    if we like we can supply just the first.  This is called _partial
    application_. *)

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 :    plus3 4 = 7.
MProof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
MProof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
MProof. reflexivity.  Qed.

(* ################################################################# *)
(** * Additional Exercises *)

Module Exercises.

(** **** Exercise: 2 stars (fold_length)  *)
(** Many common functions on lists can be implemented in terms of
   [fold].  For example, here is an alternative definition of [length]: *)

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

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

(** Prove the correctness of [fold_length]. *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (fold_map)  *)
(** We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** Write down a theorem [fold_map_correct] in Coq stating that
   [fold_map] is correct, and prove it. *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 2 stars, advanced (currying)  *)
(** In Coq, a function [f : A -> B -> C] really has the type [A
    -> (B -> C)].  That is, if you give [f] a value of type [A], it
    will give you function [f' : B -> C].  If you then give [f'] a
    value of type [B], it will return a value of type [C].  This
    allows for partial application, as in [plus3].  Processing a list
    of arguments with functions that return functions is called
    _currying_, in honor of the logician Haskell Curry.

    Conversely, we can reinterpret the type [A -> B -> C] as [(A *
    B) -> C].  This is called _uncurrying_.  With an uncurried binary
    function, both arguments must be given at once as a pair; there is
    no partial application. *)

(** We can define currying as follows: *)

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

(** As an exercise, define its inverse, [prod_uncurry].  Then prove
    the theorems below to show that the two are inverses. *)

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

(** As a (trivial) example of the usefulness of currying, we can use it
    to shorten one of the examples that we saw above: *)

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

(** Thought exercise: before running the following commands, can you
    calculate the types of [prod_curry] and [prod_uncurry]? *)

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
MProof.
  (* FILL IN HERE *) Admitted.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
MProof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, advanced (nth_error_informal)  *)
(** Recall the definition of the [nth_error] function:

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

   Write an informal proof of the following theorem:

   forall X n l, length l = n -> @nth_error X l n = None

(* FILL IN HERE *)
*)
(** [] *)

(** **** Exercise: 4 stars, advanced (church_numerals)  *)
(** This exercise explores an alternative way of defining natural
    numbers, using the so-called _Church numerals_, named after
    mathematician Alonzo Church.  We can represent a natural number
    [n] as a function that takes a function [f] as a parameter and
    returns [f] iterated [n] times. *)

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

(** Let's see how to write some numbers with this notation. Iterating
    a function once should be the same as just applying it.  Thus: *)

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

(** Similarly, [two] should apply [f] twice to its argument: *)

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

(** Defining [zero] is somewhat trickier: how can we "apply a function
    zero times"?  The answer is actually simple: just return the
    argument untouched. *)

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

(** More generally, a number [n] can be written as [fun X f x => f (f
    ... (f x) ...)], with [n] occurrences of [f].  Notice in
    particular how the [doit3times] function we've defined previously
    is actually just the Church representation of [3]. *)

Definition three : nat := @doit3times.

(** Complete the definitions of the following functions. Make sure
    that the corresponding unit tests pass by proving them with
    [reflexivity]. *)

(** Successor of a natural number: *)

Definition succ (n : nat) : nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example succ_1 : succ zero = one.
MProof. (* FILL IN HERE *) Admitted.

Example succ_2 : succ one = two.
MProof. (* FILL IN HERE *) Admitted.

Example succ_3 : succ two = three.
MProof. (* FILL IN HERE *) Admitted.

(** Addition of two natural numbers: *)

Definition plus (n m : nat) : nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example plus_1 : plus zero one = one.
MProof. (* FILL IN HERE *) Admitted.

Example plus_2 : plus two three = plus three two.
MProof. (* FILL IN HERE *) Admitted.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
MProof. (* FILL IN HERE *) Admitted.

(** Multiplication: *)

Definition mult (n m : nat) : nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example mult_1 : mult one one = one.
MProof. (* FILL IN HERE *) Admitted.

Example mult_2 : mult zero (plus three three) = zero.
MProof. (* FILL IN HERE *) Admitted.

Example mult_3 : mult two three = plus three three.
MProof. (* FILL IN HERE *) Admitted.

(** Exponentiation: *)

(** (_Hint_: Polymorphism plays a crucial role here.  However,
    choosing the right type to iterate over can be tricky.  If you hit
    a "Universe inconsistency" error, try iterating over a different
    type: [nat] itself is usually problematic.) *)

Definition exp (n m : nat) : nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example exp_1 : exp two two = plus two two.
MProof. (* FILL IN HERE *) Admitted.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
MProof. (* FILL IN HERE *) Admitted.

Example exp_3 : exp three zero = one.
MProof. (* FILL IN HERE *) Admitted.

End Church.
(** [] *)

End Exercises.

(** $Date: 2017-09-06 11:44:36 -0400 (Wed, 06 Sep 2017) $ *)


Require Import Logic.Description Classical_sets Reals Lra Lia.
From mathcomp Require Import all_ssreflect.
From Coquelicot Require Import Coquelicot.
From Actuary Require Export Basics.
Unset Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(****************************************************************************************)

(* life table *)
Record life : Type := Life {
  l_fun :> R -> R;
  l_0_pos : 0 < l_fun 0;
  l_neg_nil : forall u:R, u <= 0 -> l_fun u = l_fun 0;
  l_infty_0 : is_lim l_fun p_infty 0;
  l_decr : decreasing l_fun
}.

Hint Resolve l_0_pos l_neg_nil l_infty_0 l_decr : core.

Notation "\l[ l ]_ u" := (l_fun l u) (at level 9).

Definition end_pt (l:life) := Glb_Rbar (fun u:R => \l[l]_u = 0).
Notation "\ψ[ l ]" := (end_pt l) (at level 9).

Definition death (l:life) (u:R) := \l[l]_(u) - \l[l]_(u+1).
Notation "\d[ l ]_ u" := (death l u) (at level 9).

Definition survive (l:life) (t u : R) := \l[l]_(u+t) / \l[l]_u.
Notation "\p[ l ]_{ t & u }" := (survive l t u) (at level 9).
Notation "\p[ l ]_ u" := (\p[l]_{1&u}) (at level 9).

Definition die (l:life) (f t u : R) := (\l[l]_(u+f) - \l[l]_(u+f+t)) / (\l[l]_u).
Notation "\q[ l ]_{ f | t & u }" := (die l f t u) (at level 9).
Notation "\q[ l ]_{ t & u }" := (\q[l]_{0|t & u}) (at level 9).
Notation "\q[ l ]_{ f | & u }" := (\q[l]_{f|1 & u}) (at level 9).
Notation "\q[ l ]_ u" := (\q[l]_{0|1 & u}) (at level 9).

(* force of mortality *)
Definition d_force (l:life) (u:R) := - (Derive l u) / \l[l]_u.
Notation "\μ[ l ]_ u" := (d_force l u) (at level 9).

(* temporary curtate life expectation *)
Definition temp_curt_life_expct (l:life) (x:nat) (n:nat) :=
  \Rsum_(0 <= k < n) (k * \q[l]_{k|&x}) + n * \p[l]_{n&x}.
Notation "\e[ l ]_{ x : n }" := (temp_curt_life_expct l x n) (at level 9, x at level 9).

Definition ages_dead (l:life) : Ensemble nat := fun x:nat => \l[l]_x = 0.

Definition l_finite (l:life) := exists x:nat, (ages_dead l x).

Definition ult_age (l:life) (l_fin : l_finite l) := sval (leastN l_fin).

(* conventional notation for ultimate age *)
Notation "\ω[ l , l_fin ]" := (ult_age l l_fin) (at level 9).

(* curtate life expectation *)
Definition curt_life_expct (l:life) (l_fin : l_finite l) (x:nat) :=
  \Rsum_(0 <= k < \ω[l,l_fin] - x) (k * \q[l]_{k|&x}).
Notation "\e[ l , l_fin ]_ x" := (curt_life_expct l l_fin x) (at level 9).

(* temporary complete life expectation *)
Definition temp_life_expct (l:life) (l_fin : l_finite l) (u t : R) :=
  RInt (fun s:R => -s * (Derive l (u+s)) / \l[l]_u) 0 t +
  RInt (fun s:R => -t * (Derive l (u+s)) / \l[l]_u) t (\ψ[l] - u).
Notation "\e`o[ l , l_fin ]_{ u : t }" :=
  (temp_life_expct l l_fin u t) (at level 9, u at level 9).

(* complete life expectation *)
Definition life_expct (l:life) (l_fin : l_finite l) (u:R) :=
  RInt (fun s:R => -s * (Derive l (u+s)) / \l[l]_u) 0 (\ψ[l] - u).
Notation "\e`o[ l , l_fin ]_ u" := (life_expct l l_fin u) (at level 9).

(****************************************************************************************)

Section LifeTable.

Variable l:life.

Notation "\l_ u" := (\l[l]_u) (at level 9).
Notation "\ψ" := (\ψ[l]) (at level 8).
Notation "\d_ u" := (\d[l]_u) (at level 9).
Notation "\p_{ t & u }" := (\p[l]_{t&u}) (at level 9).
Notation "\p_ u" := (\p[l]_{1&u}) (at level 9).
Notation "\q_{ f | t & u }" := (\q[l]_{f|t&u}) (at level 9).
Notation "\q_{ t & u }" := (\q_{0|t & u}) (at level 9).
Notation "\q_{ f | & u }" := (\q_{f|1 & u}) (at level 9).
Notation "\q_ u" := (\q_{0|1 & u}) (at level 9).
Notation "\μ_ u" := (\μ[l]_u) (at level 9).
Notation "\e_{ x : n }" := (\e[l]_{x:n}) (at level 9, x at level 9).

Lemma l_nonneg : forall u:R, 0 <= \l_ u.
Proof.
  move => u.
  apply Rle_lim_decr; [apply l_decr | apply l_infty_0].
Qed.

Hint Resolve l_nonneg : core.

Lemma psi_nonneg : Rbar_le 0 \ψ.
Proof.
  set (E := fun u:R => \l[l]_u = 0).
  rewrite /end_pt.
  case: (Glb_Rbar_correct E) => Hlb Hglb.
  apply Hglb.
  rewrite /is_lb_Rbar.
  move => x Hx; apply Rbar_not_lt_le.
  move => Hltx0.
  apply (Rlt_irrefl 0).
  rewrite -{2}Hx.
  rewrite l_neg_nil; [apply l_0_pos | apply /Rlt_le /Hltx0].
Qed.

Hint Resolve psi_nonneg : core.

Lemma q_d_l : forall u:R, \q_u = \d_u / \l_u.
Proof.
  move => u.
  rewrite /death /die.
  rewrite Rplus_0_r //.
Qed.

Lemma p_q_1 : forall (t u : R), (\l_u <> 0) -> \p_{t&u} + \q_{t&u} = 1.
Proof.
  move => t u Hlu.
  rewrite /survive /die.
  rewrite Rplus_0_r -Rdiv_plus_distr.
  rewrite /Rminus Rplus_comm Rplus_assoc Rplus_opp_l Rplus_0_r.
  rewrite /Rdiv Rinv_r; lra.
Qed.

Lemma p_mult : forall (s t u : R), (\l_(u+s) <> 0) -> \p_{s+t & u} = \p_{s&u} * \p_{t & u+s}.
Proof.
  move => s t u Hlus.
  rewrite 3!/survive.
  rewrite /Rdiv Rinv_mult_simpl //; rewrite Rplus_assoc //.
Qed.

Lemma q_defer_q : forall (f t u : R), \q_{f|t&u} = \q_{f+t & u} - \q_{f&u}.
Proof.
  move => f t u.
  rewrite 3!/die !Rplus_0_r.
  rewrite -RIneq.Rdiv_minus_distr.
  rewrite /Rminus Ropp_minus_distr (Rplus_comm (\l_u + _) _) -Rplus_assoc /Rminus.
  rewrite (Rplus_assoc _ _ (\l_u)) Rplus_opp_l Rplus_0_r -Rplus_assoc //.
Qed.

Lemma q_defer_p : forall (f t u : R), \q_{f|t&u} = \p_{f&u} - \p_{f+t & u}.
Proof.
  move => f t u.
  rewrite /die /survive.
    by rewrite RIneq.Rdiv_minus_distr Rplus_assoc.
Qed.

Lemma q_defer_pq : forall (f t u : R), (\l_(u+f) <> 0) -> \q_{f|t&u} = \p_{f&u} * \q_{t & u+f}.
Proof.
  move => f t u Hluf.
  rewrite /die /survive.
  rewrite Rplus_0_r /Rdiv Rinv_mult_simpl //.
Qed.

Lemma q_defer_p_q_defer : forall (f s t u : R), (\l_(u+s) <> 0) ->
  \p_{s&u} * \q_{f|t & u+s} = \q_{f+s|t & u}.
Proof.
  move => f s t u Hlus.
  rewrite /survive {1}/die.
  rewrite /Rdiv.
  rewrite Rmult_comm -Rmult_assoc (Rmult_assoc _ (/_)) Rinv_l // Rmult_1_r.
  rewrite /die (Rplus_comm f s) -!Rplus_assoc //.
Qed.

Lemma l_u_pos : forall u:R, Rbar_lt u \ψ -> 0 < \l_u.
Proof.
  move => u Hu.
  case: (Rlt_le_dec 0 (\l_u)) => // Hlu0.
  apply False_ind.
  apply (Rbar_lt_not_eq u u) => //.
  apply (Rbar_lt_le_trans _ _ _ Hu).
  rewrite /end_pt.
  set (E := (fun u0 : R => \l_ u0 = 0)).
  case: (Glb_Rbar_correct E) => Hlb _.
  apply Hlb.
  rewrite /E.
  apply Rle_antisym => //.
Qed.

Hint Resolve l_u_pos : core.

Lemma l_pos_bound : forall u:R, 0 < \l_u -> Rbar_le u \ψ.
Proof.
  move => u Hlu0.
  set (K := (fun t:R => \l_t = 0)).
  case: (Glb_Rbar_correct K) => _; apply.
  rewrite /is_lb_Rbar => s Hs.
  apply Rbar_not_lt_le => /= Hsu.
  apply (Rlt_irrefl 0).
  rewrite {2}(_ : 0 = \l_u) //.
  apply Rle_antisym; auto.
  rewrite -Hs.
  apply l_decr; lra.
Qed.

Lemma l_out_0 : forall u:R, Rbar_lt \ψ u -> \l_u = 0.
Proof.
  move => u Hpsiu.
  apply NNPP => Hluneq0.
  apply (Rbar_lt_not_le u \ψ); auto.
  apply l_pos_bound.
  move: (l_nonneg u); lra.
Qed.

Lemma e_p_n : forall (x n : nat), \e_{x:n} = \Rsum_(0 <= k < n) \p_{k+1 & x}.
Proof.
  move => x n.
  rewrite /temp_curt_life_expct.
  case: (zerop n) => [Hn0 | Hnpos].
  - rewrite !big_geq; [rewrite Hn0 Rmult_0_l; lra | |]; rewrite Hn0 //.
  - under eq_big_nat => k Hk.
    { rewrite q_defer_p.
      rewrite Rmult_minus_distr_l.
      rewrite (_ : k*\p_{k+1 & x} = (k+1)*\p_{k+1 & x} - \p_{k+1 & x}).
      - rewrite {1}/Rminus Ropp_plus_distr -Rplus_assoc Ropp_involutive.
        over.
      - rewrite /survive.
        rewrite /Rdiv -!(Rmult_assoc _ _ (/ \l_x)) -Rmult_minus_distr_r.
        rewrite Rmult_plus_distr_r Rmult_1_l Ropp_r_simpl_l //. }
    rewrite 2!big_split /=.
    rewrite Rplus_comm -!Rplus_assoc (Rplus_comm (n * _) _).
    rewrite -big_nat_recr //=.
    rewrite big_nat_recl // Rmult_0_l Rplus_0_l.
    rewrite -big_split.
    under eq_big_nat => i Hi.
    { rewrite -Nat.add_1_r plus_INR /= Rplus_opp_r.
      over. }
    rewrite big1_eq.
      by rewrite Rplus_0_l.
Qed.

(****************************************************************************************)

Section FiniteLifeTable.

Hypothesis l_fin : (l_finite l).

Notation "\ω" := (\ω[l,l_fin]) (at level 8).
Notation "\e_ x" := (\e[l,l_fin]_ x) (at level 9).

Lemma l_omega_0 : \l_\ω = 0.
Proof.
  rewrite /(\ω).
  case: leastN  => m Hmin /=.
  apply Hmin.
Qed.

Lemma psi_finite : is_finite \ψ.
Proof.
  apply is_finite_correct.
  set E := (fun u:R => \l_u = 0).
  case: (@completeness' E).
  - rewrite /bound'.
    exists 0.
    rewrite /is_lower_bound.
    move => t Ht.
    apply Rnot_gt_le => Ht0.
    apply (Rlt_irrefl 0).
    rewrite /E in Ht.
    rewrite -{2}Ht.
    rewrite l_neg_nil; [auto | lra].
  - exists \ω.
    rewrite /E; apply l_omega_0.
  - move => t Hglb.
    exists t.
    apply is_glb_Rbar_unique.
    rewrite /is_glb_Rbar.
    split.
    + rewrite /is_lb_Rbar.
      move => s Hs.
      rewrite /=.
      by apply Hglb.
    + move => [r Hr | Hpinfty | Hminfty].
      * rewrite /=.
        apply Hglb.
        rewrite /is_lower_bound => s Hs.
        by apply Hr.
      * rewrite /is_lb_Rbar in Hpinfty.
        by move: (Hpinfty \ω l_omega_0).
      * rewrite /Rbar_le //.
Qed.

Hint Resolve psi_finite : core.

Lemma omega_pos : 0 < \ω.
Proof.
  rewrite -Nat2Z.inj_0; apply Rlt_gt; rewrite -INR_IZR_INZ; apply lt_INR.
  apply Nat.neq_0_lt_0 => Homega0.
  apply (Rlt_irrefl \l_\ω).
  rewrite {1}l_omega_0  Homega0.
  apply l_0_pos.
Qed.

Hint Resolve omega_pos : core.

Lemma le_psi_omega : Rbar_le \ψ \ω.
Proof.
  apply Rbar_not_lt_le.
  apply (contra_not (l_u_pos \ω)).
  rewrite l_omega_0; lra.
Qed.

Lemma l_old_0 : forall x:nat, (\ω <= x) -> \l_x = 0.
Proof.
  move => x Hx.
  apply Rle_antisym.
  - rewrite -l_omega_0.
    apply /l_decr; lra.
  - apply l_nonneg.
Qed.

Lemma l_old_0' : forall u:R, \ω <= u -> \l_u = 0.
Proof.
  move => u Hu.
  apply Rle_antisym; auto.
  rewrite -l_omega_0.
  apply /l_decr; lra.
Qed.

Lemma l_x_pos : forall x:nat, x < \ω -> 0 < \l_x.
Proof.
  move => x Hx.
  case: (Rlt_le_dec 0 (\l_x)).
  - lra.
  - case => [Hlxneg | Hlx0].
    + contradict Hlxneg.
      apply /Rle_not_gt /l_nonneg.
    + contradict Hx.
      apply /Rge_not_lt / Rle_ge /le_INR.
      rewrite /(\ω).
      case: leastN => y Hmin /=.
        by apply Hmin.
Qed.

Hint Resolve l_x_pos : core.

Lemma p_nonneg : forall (t x : nat), x < \ω -> 0 <= \p_{t&x}.
Proof.
  move => t x Hx.
  rewrite /survive /Rdiv.
  rewrite -(Rmult_0_l (/(\l_x))).
  apply (Rmult_le_compat_r (/(\l_x)) 0);
    [apply /Rlt_le /Rinv_0_lt_compat /l_x_pos => // | apply l_nonneg].
Qed.

Lemma p_nonneg' : forall (t:R) (x:nat), x < \ω -> 0 <= \p_{t&x}.
Proof.
  move => t x Hx.
  rewrite /survive.
  apply Rdiv_le_0_compat; [| apply l_x_pos]; auto.
Qed.

Lemma p_omega_0 : forall x:nat, \p_{\ω-x & x} = 0.
Proof.
  move => x.
  rewrite /survive.
  rewrite Rplus_comm /Rminus Rplus_assoc Rplus_opp_l Rplus_0_r.
  rewrite l_omega_0; lra.
Qed.

Lemma p_old_0 : forall (x y : nat), \ω <= x+y -> \p_{y & x} = 0.
Proof.
  move => x y Hxy.
  rewrite /survive /Rdiv.
  rewrite -plus_INR.
  rewrite (l_old_0 (x+y)); [rewrite Rmult_0_l | rewrite plus_INR]; done.
Qed.

Lemma p_old_0' : forall (t:R) (x:nat), \ω <= x+t -> \p_{t&x} = 0.
Proof.
  move => t x Hxt.
  rewrite /survive.
  rewrite l_old_0'; lra.
Qed.

Lemma p_0_1 : forall (x : nat), x < \ω -> \p_{0&x} = 1.
Proof.
  move => x Hx.
  rewrite /survive.
  rewrite Rplus_0_r.
  rewrite /Rdiv Rinv_r //.
  apply /pos_neq0 /l_x_pos => //.
Qed.

Lemma p_0_1' : forall u:R, u < \ψ -> \p_{0 & u} = 1.
Proof.
  move => u Hu.
  rewrite /survive.
  rewrite Rplus_0_r.
  rewrite /Rdiv Rinv_r //.
  apply /pos_neq0 /l_u_pos.
    by move: psi_finite <-.
Qed.

Lemma q_omega_1 : \q_(\ω-1) = 1.
Proof.
  rewrite /die Rplus_0_r {3}/Rminus Rplus_assoc Rplus_opp_l Rplus_0_r.
  rewrite l_old_0; [| lra]; rewrite Rminus_0_r.
  rewrite /Rdiv Rinv_r //.
  apply pos_neq0.
  rewrite -(minus_INR \ω 1);
    [apply /l_x_pos /lt_INR /Nat.sub_lt => // |]; apply /INR_lt /omega_pos.
Qed.

Lemma q_defer_old_0 : forall (f t x : nat), \ω <= x+f -> \q_{f|t&x} = 0.
Proof.
  move => f t x Hxf.
  rewrite /die.
  rewrite -!plus_INR.
  rewrite (l_old_0 (x+f)%coq_nat); [| rewrite plus_INR //].
  rewrite (l_old_0 (((x+f)%coq_nat+t)%coq_nat)).
  - rewrite Rminus_0_r /Rdiv Rmult_0_l //.
  - apply /le_INR /(Nat.le_trans _ (x+f)%coq_nat);
      [apply INR_le; rewrite plus_INR; lra | lia].
Qed.

Lemma q_defer_old_0' : forall (f t u : R), 0 <= t -> \ω <= u+f -> \q_{f|t&u} = 0.
Proof.
  move => f t u H0t Homegauf.
  rewrite /die.
  have Homegauft : \ω <= u+f+t by apply (Rle_trans _ (u+f)); lra.
  rewrite (l_old_0' (u+f)) // (l_old_0' (u+f+t)) //; lra.
Qed.

Lemma e_p : forall x:nat, \e_x = \Rsum_(0 <= k < \ω-x) \p_{k+1 & x}.
Proof.
  move => x.
  rewrite /curt_life_expct.
  case: (le_lt_dec 1 (\ω-x)) => [Hdead | Halive].
  - under eq_big_nat => k Hk.
    { rewrite q_defer_p.
      rewrite Rmult_minus_distr_l.
      rewrite (_ : k*\p_{k+1 & x} = (k+1)*\p_{k+1 & x} - \p_{k+1 & x}).
      - rewrite {1}/Rminus Ropp_plus_distr -Rplus_assoc Ropp_involutive.
        over.
      - rewrite /survive.
        rewrite /Rdiv -!(Rmult_assoc _ _ (/ \l_x)) -Rmult_minus_distr_r.
        rewrite Rmult_plus_distr_r Rmult_1_l Ropp_r_simpl_l //. }
    rewrite 2!big_split /=.
    rewrite -(Rplus_0_r (\Rsum_(0 <= i < \ω-x) i * \p_{i&x})).
    rewrite -{2}(Rmult_0_r (\ω-x)) -{2}(p_omega_0 x).
    rewrite -(minus_INR \ω x); [| apply /Nat.lt_le_incl /(Nat.lt_add_lt_sub_r 0); rewrite /lt //].
    rewrite -(big_nat_recr (\ω-x) 0) /= ; [| rewrite /leP //].
    rewrite big_nat_recl //.
    rewrite Rmult_0_l Rplus_0_l.
    rewrite -big_split.
    under eq_big_nat => i Hi.
    { rewrite -Nat.add_1_r plus_INR /= Rplus_opp_r.
      over. }
    rewrite big1_eq.
    by rewrite Rplus_0_l.
  - rewrite !big_geq //; apply /leP; lia.
Qed.

Lemma e_rec : forall x:nat, \e_x = \p_x * (1 + \e_(x+1)).
Proof.
  move => x.
  rewrite e_p.
  case: (le_lt_dec 2 (\ω-x)) => [Halive | Hdead].
  - have Halive0 : (0 < \ω-x)%N by apply /ltP /(Nat.lt_le_trans 0 2); [lia | done].
    have Halive1 : (1 < \ω-x)%N by apply /ltP /(Nat.lt_le_trans 1 2); [lia | done].
    rewrite -(prednK Halive0).
    rewrite big_nat_recl; [| by rewrite -Nat.pred_0; apply /leP /Nat.pred_le_mono /leP].
    rewrite Rplus_0_l.
    under eq_big_nat => i Hi.
    { rewrite Rplus_comm (p_mult 1 (i.+1)).
      - rewrite S_INR.
        over.
      - rewrite -(plus_INR x 1).
        apply /pos_neq0 /l_x_pos /lt_INR /(Nat.lt_add_lt_sub_r 0).
        rewrite Nat.sub_add_distr.
        apply lt_minus_O_lt.
        move /ltP in Halive1.
        rewrite -SSR_minus //. }
    rewrite -big_distrr.
    rewrite -{1}(Rmult_1_r (\p_x)).
    rewrite -Rmult_plus_distr_l.
      by rewrite -Nat.sub_1_r -SSR_minus -subnDA e_p plus_INR.
  - apply (Nat.lt_succ_r (\ω - x)) in Hdead.
    apply Nat.le_1_r in Hdead.
    destruct Hdead as [H0 | H1].
    + rewrite H0.
      rewrite big_geq //.
      rewrite (p_old_0 x 1); [rewrite Rmult_0_l // |].
      apply Nat.sub_0_le in H0.
      rewrite -plus_INR; apply /le_INR /(Nat.le_trans _ x) => //; lia.
    + rewrite H1.
      rewrite big_nat1 Rplus_0_l.
      rewrite e_p subnDA H1 SSR_minus Nat.sub_diag.
      rewrite big_geq //.
      rewrite Rplus_0_r Rmult_1_r //.
Qed.

End FiniteLifeTable.

(****************************************************************************************)

Section DifferentiableLifeTable.

(* Suppose l is continuously differentiable. *)
Hypothesis l_C1 : forall u:R, ex_derive l u /\ continuous (Derive l) u.

Lemma ex_derive_l : forall u:R, ex_derive l u.
Proof.
  apply l_C1.
Qed.

Hint Resolve ex_derive_l : core.

Lemma continuous_l : forall u:R, continuous l u.
Proof.
  move => u.
  apply (ex_derive_continuous l u) => //.
Qed.

Hint Resolve continuous_l : core.

Lemma continuous_Derive_l : forall u:R, continuous (Derive l) u.
Proof.
  apply l_C1.
Qed.

Hint Resolve continuous_Derive_l : core.

Lemma continuous_p_fst : forall t u : R, Rbar_lt u \ψ -> continuous (fun s:R => \p_{ s & u }) t.
Proof.
  move => t u Hupsi.
  rewrite /survive /Rdiv.
  apply (continuous_comp (Rplus u) (fun r:R => \l_r */ \l_u)).
  - apply continuous_Rplus_snd.
  - apply (continuous_scal_l _ (/ \l_u)); auto.
Qed.

Lemma continuous_mu :  forall u:R, Rbar_lt u \ψ -> continuous (fun v:R => \μ_v) u.
Proof.
  move => u Hu.
  rewrite /d_force /Rdiv.
  apply (continuous_mult (fun v:R => - Derive l v)).
  - apply (continuous_opp (Derive l)); auto.
  - by apply (continuous_Rinv_comp); last apply /pos_neq0 /l_u_pos.
Qed.

Lemma mu_Derive_ln : forall u:R, Rbar_lt u \ψ -> \μ_u = - Derive (fun v:R => ln \l_v) u.
Proof.
  move => u Hu.
  rewrite Derive_comp; try auto_derive; auto.
  rewrite Derive_ln; auto.
  rewrite /d_force; lra.
Qed.

Lemma RInt_mu_ln : forall u:R, 0 <= u -> Rbar_lt u \ψ ->
  RInt (fun v:R => \μ_v) 0 u = -ln(\l_u / \l_0).
Proof.
  move => u H0u Hupsi.
  have H0v : forall v:R, Rmin 0 u < v -> 0 < v.
  { move => v Huv.
    rewrite (_ : 0 = Rmin 0 u); [apply Huv |].
    rewrite /Rmin.
    case Rle_dec => [_ | Hn0u] //. }
  have Hvpsi : forall v:R, v <= Rmax 0 u -> Rbar_lt v \ψ.
  { move => v Hvu.
    eapply Rbar_le_lt_trans; [| apply Hupsi].
    rewrite (_ : u = Rmax 0 u); [apply Hvu |].
    rewrite /Rmax.
    case Rle_dec => [_ | Hn0u] //. }
  have HC0Dlnl : forall v:R, Rbar_lt v \ψ -> continuous (Derive (fun w : R => ln \l_ w)) v.
  { move => v Hv.
    apply (continuous_ext_loc _ (fun w:R => - \μ_w));
      [| by apply /(continuous_opp (d_force l)) /continuous_mu].
    have Hexball : exists eps:posreal, Rbar_lt (v + eps) \ψ.
    { move: Hv.
      case: \ψ => [r Hur | Hpsi_p_infty | Hpsi_m_infty].
      - have Hepsilon_pos : 0 < (r-v)/2 by rewrite /= in Hur; lra.
        exists (mkposreal ((r-v)/2) Hepsilon_pos) => /=; lra.
      - have Hepsilon_pos : 0 < 1 by lra.
        exists (mkposreal 1 Hepsilon_pos); auto.
      - contradiction. }
    destruct Hexball as [eps Heps].
    exists eps => /= w Hw.
    rewrite mu_Derive_ln; [lra |].
    apply (Rbar_lt_trans _ (v + eps)) => //=.
    suff H : w - v < eps; [lra |].
    apply (Rle_lt_trans _ (Rabs (w-v))); [apply Rle_abs | auto]. }
  under RInt_ext => v Hv.
  { rewrite mu_Derive_ln; [| apply Hvpsi; lra].
    rewrite -(Rmult_1_l (Derive _ _)) Ropp_mult_distr_l.
    over. }
  rewrite RInt_scal.
  - rewrite RInt_Derive.
    + rewrite ln_div; auto; rewrite /scal /= /mult /= -Ropp_mult_distr_l Rmult_1_l //.
    + move => v Hv.
      apply ex_derive_comp; auto.
      auto_derive.
      apply /l_u_pos /Hvpsi; lra.
    + move => v Hv.
      apply /HC0Dlnl /Hvpsi; lra.
  - apply ex_RInt_continuous => w Hw.
    apply /HC0Dlnl /Hvpsi; lra.
Qed.

Lemma l_exp_RInt_mu : forall u:R, 0 <= u -> Rbar_lt u \ψ ->
  \l_u = \l_0 * exp (- RInt (fun v:R => \μ_v) 0 u).
Proof.
  move => u H0u Hupsi.
  rewrite RInt_mu_ln // Ropp_involutive.
  rewrite exp_ln.
  - field; apply /pos_neq0 /l_u_pos /(Rbar_le_lt_trans _ u); auto.
  - apply Rdiv_lt_0_compat; auto.
Qed.

Lemma p_exp_RInt_mu : forall (t u : R), 0 <= t -> 0 <= u -> Rbar_lt (u+t) \ψ ->
  \p_{t & u} = exp (- RInt (fun v:R => \μ_v) u (u+t)).
Proof.
  move => t u H0t H0u Hutpsi.
  have HC0mu : forall v:R, v <= (u+t) -> continuous [eta d_force l] v.
  { move => v Hv.
    apply continuous_mu.
    apply (Rbar_le_lt_trans _ (u+t)) => //. }
  rewrite /survive.
  rewrite (l_exp_RInt_mu (u+t)) //; [| lra].
  rewrite (l_exp_RInt_mu u) //; [| apply (Rbar_le_lt_trans _ (u+t)) => //=; lra].
  rewrite /Rdiv Rinv_mult_distr; auto; [| apply /pos_neq0 /exp_pos].
  rewrite -!Rmult_assoc (Rmult_comm \l_0) (Rmult_assoc _ \l_0) Rinv_r;
    auto; rewrite Rmult_1_r.
  rewrite -exp_Ropp -exp_plus -Ropp_plus_distr.
  rewrite (_ : - RInt [eta d_force l] 0 u = opp (RInt [eta d_force l] 0 u)) //.
  rewrite opp_RInt_swap;
    [| apply /ex_RInt_continuous => v Hv; apply HC0mu; rewrite Rmax_right in Hv; lra].
  rewrite (Rplus_comm (RInt _ _ _)).
  rewrite (_ : RInt [eta d_force l] u 0 + RInt [eta d_force l] 0 (u + t) =
               plus (RInt [eta d_force l] u 0) (RInt [eta d_force l] 0 (u + t))) //.
  rewrite RInt_Chasles //; apply ex_RInt_continuous => v Hv; apply HC0mu;
    [rewrite Rmax_left in Hv | rewrite Rmax_right in Hv]; lra.
Qed.

Lemma q_exp_RInt_mu : forall (t u : R), 0 <= t -> 0 <= u -> Rbar_lt (u+t) \ψ ->
  \q_{t & u} = 1 - exp (- RInt (fun v:R => \μ_v) u (u+t)).
Proof.
  move => t u H0t H0u Hutpsi.
  have Hupsi : Rbar_lt u \ψ by apply (Rbar_le_lt_trans _ (u+t)); [rewrite /=; lra | auto].
  rewrite -(p_q_1 t u); auto.
  rewrite p_exp_RInt_mu; auto; lra.
Qed.

Lemma mu_incr : forall (u s : R), Rbar_lt (u+s) \ψ ->
  \μ_(u+s) = - (Derive (fun r:R => \l_(u+r)) s) / \l_(u+s).
Proof.
  move => u s Huspsi.
  rewrite Derive_incr; auto.
Qed.

Lemma RInt_l_mu : forall (u t : R), 0 <= t -> Rbar_lt (u+t) \ψ ->
  \l_u - \l_(u+t) = RInt (fun s:R => \l_(u+s) * \μ_(u+s)) 0 t.
Proof.
  move => u t H0t Hutpsi.
  have HDC0 : forall s:R, s <= t -> continuous (Derive (fun r : R => \l_ (u + r))) s.
  { move => s Hs.
    apply (continuous_ext (fun r:R => (Derive l) (u+r))).
    - move => r.
      rewrite Derive_incr; auto.
    - apply continuous_comp; auto; apply continuous_Rplus_snd. }
  under RInt_ext => s [H0s Hst].
  { rewrite Rmax_right in Hst; [| lra].
    have Huspsi :  Rbar_lt (u + s) \ψ
      by apply (Rbar_lt_trans _ (u+t)); [ rewrite /=; lra | auto].
    rewrite mu_incr //.
    rewrite /Rdiv Rmult_comm Rmult_assoc Rinv_l; auto; rewrite Rmult_1_r.
    rewrite -(Rmult_1_l (Derive _ _)) Ropp_mult_distr_l.
    over. }
  rewrite RInt_scal.
  - rewrite RInt_Derive.
    + rewrite Rplus_0_r /scal /= /mult /=; lra.
    + move => s _.
      auto_derive; auto.
    + move => s [_ Hst].
      rewrite Rmax_right in Hst; [| lra].
        by apply HDC0.
  - apply ex_RInt_continuous => s [_ Hst].
    rewrite Rmax_right in Hst; [| lra].
      by apply HDC0.
Qed.

Lemma q_RInt_p_mu : forall (f u t : R), 0 <= f -> 0 <= t -> Rbar_lt (u+f+t) \ψ ->
  \q_{f|t & u} = RInt (fun s:R => \p_{s & u} * \μ_(u+s)) f (f+t).
Proof.
  move => f u t H0f H0t Huftpsi.
  rewrite /die.
  rewrite RInt_l_mu //.
  rewrite /Rdiv Rmult_comm.
  rewrite (_ : / \l_ u * RInt (fun s : R => \l_ (u + f + s) * \μ_ (u + f + s)) 0 t =
               scal (/ \l_u) (RInt (fun s : R => \l_ (u + f + s) * \μ_ (u + f + s)) 0 t));
    [| rewrite /scal /= /mult //=].
  rewrite -RInt_scal.
  - rewrite /scal /= /mult /=.
    under RInt_ext => s _.
    { rewrite -Rmult_assoc (Rmult_comm (/ \l_u)) -/(Rdiv \l_(u+s) \l_u) Rplus_assoc.
      rewrite -/(Rdiv _ \l_u) -/(survive _ (f+s) u).
      rewrite !(Rplus_comm f s).
      over. }
    rewrite (@RInt_comp_plus _ (fun r:R => \p_{r&u} * \μ_(u+r))).
    + rewrite Rplus_0_l (Rplus_comm f t) //.
    + apply ex_RInt_continuous => r Hr.
      apply (continuous_mult (fun s:R => \p_{s&u})).
      * apply continuous_p_fst.
        apply (Rbar_le_lt_trans _ (u+f+t)); [rewrite /=; lra | auto].
      * apply (continuous_comp (Rplus u) (d_force l)); [apply continuous_Rplus_snd |].
        apply continuous_mu.
        destruct Hr as [_ Hrtf].
        rewrite Rmax_right in Hrtf; [| lra].
        rewrite Rplus_comm in Hrtf.
        apply (Rbar_le_lt_trans _ (u+f+t)); [rewrite /=; lra | auto].
  - apply ex_RInt_continuous => s [_ Hst].
    rewrite Rmax_right in Hst; [| lra].
    apply (continuous_mult (fun r:R => \l_(u+f+r))).
    + apply continuous_comp; [apply continuous_Rplus_snd | auto].
    + apply continuous_comp; [apply continuous_Rplus_snd | apply continuous_mu].
      apply (Rbar_le_lt_trans _ (u+f+t)); [rewrite /=; lra | auto].
Qed.

Lemma q_imm_RInt_p_mu : forall (u t : R), 0 <= t -> Rbar_lt (u+t) \ψ ->
  \q_{t & u} = RInt (fun s:R => \p_{s & u} * \μ_(u+s)) 0 t.
Proof.
  move => u t H0t Hutpsi.
    by rewrite (q_RInt_p_mu 0); try lra; rewrite ?Rplus_assoc Rplus_0_l.
Qed.

End DifferentiableLifeTable.

(****************************************************************************************)

Section FiniteDefferentiableLifeTable.

Hypothesis l_fin : (l_finite l).
Hypothesis l_C1 : forall u:R, ex_derive l u /\ continuous (Derive l) u.

Notation "\ω" := (\ω[l,l_fin]) (at level 8).
Notation "\e_ x" := (\e[l,l_fin]_ x) (at level 9).
Notation "\e`o_{ u : t }" := (\e`o[l,l_fin]_{u:t}) (at level 9, u at level 9).
Notation "\e`o_ u" := (\e`o[l,l_fin]_u) (at level 9).

Hint Resolve ex_derive_l continuous_l continuous_Derive_l : core.
Hint Resolve l_omega_0 psi_finite omega_pos le_psi_omega l_old_0 : core.

Lemma l_psi_0 : \l_\ψ = 0.
Proof.
  case: (Req_dec \l_\ψ 0) => // Hlpsineq0.
  apply False_ind.
  set (K := (fun u:R => \l_u = 0)).
  have HpsiCK : (complementary K) \ψ by [].
  have : closed_set K.
  { rewrite (_ : K = image_rec l (eq^~ 0)) //.
    apply continuity_closed; [apply eq_R_continuous; auto |].
    apply Rsingleton_closed. }
  apply/open_set_P1 => HKclosed.
  have HpsiNBH : neighbourhood (complementary K) \ψ
    by rewrite -/(interior _ \ψ); apply HKclosed.
  rewrite /neighbourhood in HpsiNBH.
  case: HpsiNBH => eps Hdisk.
  destruct eps as [eps Hepspos].
  suff Hlneq0 : \l_(\ψ+eps/2) <> 0.
  - apply Hlneq0.
    apply l_out_0.
    rewrite -psi_finite //=; lra.
  - apply Hdisk.
    rewrite /disc.
    rewrite (_ : \ψ + eps/2 - \ψ = eps/2) /=; try lra.
    rewrite Rabs_pos_eq; lra.
Qed.

Lemma l_0_equiv : forall u:R, \l_u = 0 <-> \ψ <= u.
Proof.
  move => u.
  split.
  - move => Hlu0.
    apply Rnot_lt_le.
    contradict Hlu0.
    apply /pos_neq0 /l_u_pos.
    rewrite -psi_finite //=.
  - case.
    + move: (l_out_0 u).
      rewrite -psi_finite //=.
    + by move <-; rewrite l_psi_0.
Qed.

Lemma l_pos_equiv : forall u:R, 0 < \l_u <-> u < \ψ.
Proof.
  move => u; split.
  - move => Hlupos.
    apply Rnot_le_lt => /l_0_equiv; lra.
  - move => Hu.
    apply Rnot_le_lt => /Rle_antisym /(_ (l_nonneg _)) /l_0_equiv; lra.
Qed.

Lemma lt_omega_lt_psi : forall x:nat, x < \ω -> x < \ψ.
Proof.
  move => x /l_x_pos; apply l_pos_equiv.
Qed.

Lemma l_u_nbh_pos : forall u:R, u < \ψ -> exists eps:posreal, 0 < \l_(u + eps).
Proof.
  move => u Hu.
  have Hu' : Rbar_lt u \ψ by rewrite -psi_finite.
  move: (l_u_pos u Hu') => Hlu.
  have Hlu2 : 0 < \l_u / 2 by lra.
  have HuC0 : continuity_pt l u by apply continuity_pt_continuous; auto.
  set (Blu := open_interval (\l_u / 2) (\l_u * 3/2)).
  have HBlunbh : neighbourhood Blu \l_u
    by exists (mkposreal (\l_u / 2) Hlu2) => v;
      rewrite /disc /Blu /open_interval /=; move /Rabs_def2; lra.
  case: (continuity_P1 l u) => /(_ HuC0 _ HBlunbh).
  case => V; case; case; move => [r Hr] HDuV HVBlu _.
  have Hr2 : 0 < r/2 by lra.
  exists (mkposreal (r/2) Hr2) => /=.
  eapply Rlt_trans; [apply Hlu2 |].
  apply HVBlu.
  apply HDuV.
  rewrite /disc.
  apply Rabs_def1 => /=; lra.
Qed.

Lemma p_old_0'' : forall (t u : R), \ψ <= u + t -> \p_{t & u} = 0.
Proof.
  move => t u Hut.
  rewrite /survive.
  case: (l_0_equiv (u+t)) => _ ->; lra.
Qed.

Lemma continuous_p_fst' : forall (t:R) (x:nat), x < \ω -> continuous (fun s:R => \p_{ s & x }) t.
Proof.
  move => t x Hxomega.
  rewrite /survive /Rdiv.
  apply (continuous_comp (Rplus x) (fun r:R => \l_r */ \l_x)).
  - apply continuous_Rplus_snd.
  - apply (continuous_scal_l _ (/ \l_x)); auto.
Qed.

Lemma temp_compl_expct : forall u:R, \e`o_u = \e`o_{u : \ψ-u}.
Proof.
  move => u.
  rewrite /temp_life_expct /life_expct.
  rewrite RInt_point /zero /=; lra.
Qed.

Lemma temp_life_expct_RInt_p : forall (u t : R), u < \ψ -> 0 <= t -> u+t <= \ψ ->
  \e`o_{u:t} = RInt (fun s:R => \p_{s&u}) 0 t.
Proof.
  move => u t Hupsi H0t Hutpsi.
  have Hutpsi' : Rbar_le (u+t) \ψ by rewrite -psi_finite //=.
  have HC0scall : forall r:R, continuous (fun s : R => / \l_ u * \l_ s) r.
  { move => r.
    rewrite (_ : Rmult = scal) //.
    apply (continuous_scal_r (/ \l_u) l); auto. }
  rewrite /temp_life_expct.
  have HRInt0t : RInt (fun s:R => -s * Derive l (u+s) / \l_u) 0 t =
                 RInt (fun s:R => \p_{ s & u}) 0 t + - t * \p_{t & u}.
  { under RInt_ext => s _.
    { rewrite Rplus_comm Rmult_comm.
      rewrite /Rdiv Rmult_assoc -Ropp_mult_distr_l (Rmult_comm s).
      rewrite -{2}(Ropp_r_simpl_l u s).
      over. }
    rewrite (@RInt_comp_plus _ (fun r:R => scal (Derive l r) (- (/ \l_u * (r-u))))) Rplus_0_l.
    - rewrite (@RInt_scal_Derive_l l (fun r:R => - (/ \l_ u * (r - u)))); auto.
      + rewrite /minus /scal /plus /opp /= /mult /=.
        rewrite (_ : t + u - u = t + (u - u)); try lra.
        rewrite !Rminus_eq_0 Rplus_0_r Rmult_0_r -!Ropp_mult_distr_r
                Rmult_0_r Ropp_involutive Rplus_0_r.
        under RInt_ext => s Hs.
        { rewrite Derive_opp Derive_scal Derive_minus; try auto_derive; auto;
            rewrite Derive_id Derive_const Rminus_0_r Rmult_1_r.
          rewrite Rmult_comm -Ropp_mult_distr_l (_ : Ropp = opp) //.
          over. }
        rewrite RInt_opp /opp /=; [| apply ex_RInt_continuous => s _; auto].
        rewrite Ropp_involutive -{4}(Rplus_0_l u) -RInt_comp_plus;
          [| apply ex_RInt_continuous => s _; auto].
        under RInt_ext => s _ do
          rewrite Rmult_comm Rplus_comm -/(Rdiv _ \l_u) -/(survive l s u).
        rewrite (_ : - (\l_ (t + u) * (/ \l_ u * t)) = -t * \p_{t&u})
                /survive /Rdiv Rplus_comm; lra.
      + move => s _; auto_derive; auto.
      + move => s _.
        apply (continuous_ext (fun _ => - / \l_u)); [| apply continuous_const].
        move => r.
        rewrite Derive_opp Derive_scal Derive_minus; try auto_derive; auto.
        rewrite Derive_id Derive_const; lra.
    - apply ex_RInt_continuous => s Hs.
      apply continuous_mult; auto.
      rewrite (_ : Ropp = opp) //; apply (continuous_opp (fun y:R => / \l_ u * (y - u))).
      rewrite (_ : Rmult = scal) //; apply (continuous_scal_r _ (fun y:R => (y-u))).
      apply continuous_Rminus_fst. }
  have HRInttpsiu :
    RInt (fun s:R => -t * Derive l (u+s) / \l_u) t (\ψ-u) = t * \p_{t&u}.
  { under RInt_ext => s _.
    { rewrite Rplus_comm /Rdiv.
      rewrite Rmult_assoc (Rmult_comm (Derive _ _)) -Rmult_assoc -Ropp_mult_distr_l.
      over. }
    rewrite (@RInt_comp_plus _ (fun s:R => -(t * / \l_u) * (Derive l s)))
      (_ : \ψ-u+u = \ψ); try lra.
    - rewrite {1}(_ : Rmult = scal) //.
      rewrite RInt_scal; [| apply ex_RInt_continuous; auto].
      rewrite RInt_Derive; auto.
      rewrite l_psi_0 Rminus_0_l /scal /= /mult /= Rmult_opp_opp.
      rewrite /survive Rplus_comm; field.
      apply /pos_neq0 /l_u_pos.
      rewrite -psi_finite //=; lra.
    - apply ex_RInt_continuous => s _.
      apply (continuous_scal_r _ (fun r:R => Derive l r)); auto. }
  rewrite HRInt0t HRInttpsiu; lra.
Qed.

Lemma life_expct_RInt_p : forall u:R, u < \ψ ->
  \e`o_u = RInt (fun s:R => \p_{s&u}) 0 (\ψ-u).
Proof.
  move => u Hupsi.
  rewrite temp_compl_expct.
  rewrite temp_life_expct_RInt_p; lra.
Qed.

End FiniteDefferentiableLifeTable.

End LifeTable.


(*
  NOTE: This proof depends on:

  - plus_associates (defined in PlusAssociates.v)
  - plus_commutes (defined in PlusCommutes.v)
  - plus_p_right (defined in LeftDistributive.v)
*)

(*
  Add load path containing the files mentioned above -
  feel free to edit path as required
*)
Add LoadPath "/path/to/lemmas_and_theorems".

(* Require the theorems and lemmas mentioned above *)
Require Export PlusAssociates.
Require Export PlusCommutes.
Require Export LeftDistributive.

Lemma n_times_S_m_eq_n_plus_n_times_m : forall n m : nat, n * S m = n + n * m.
Proof.
  intros.
  induction n as [| n' IHn].
    reflexivity.

    simpl.
    rewrite IHn.
    apply f_equal.
    rewrite <- plus_associates.
    symmetry.
    rewrite <- plus_associates.
    apply plus_p_right.
    apply plus_commutes.
Qed.

Theorem mult_commutes : forall n m : nat, n * m = m * n.
Proof.
  intros.
  induction n as [| n' IHn].
    simpl.
    induction m as [| m' IHm].
      reflexivity.

      simpl.
      assumption.

    simpl.
    rewrite IHn.
    rewrite n_times_S_m_eq_n_plus_n_times_m.
    reflexivity.
Qed.


(**

  Axiomatic definition of countable ordinal numbers (after Kurt Schutte's
  "Proof Theory"

 Pierre Casteran (LaBRI, University of Bordeaux)
 with contributions by Florian Hatat (formerly student at ENS Lyon)

*)

From hydras Require Export Schutte_basics Ordering_Functions
        Addition AP CNF Critical Correctness_E0.

(** * Warning

This directory contains an adaptation to Coq of the mathematical
presentation of the set of countable ordinal numbers by K. Schutte.

In order to respect as most as possible the style of that presentation,
we chosed to work in classical logic augmented by Hilbert's [[epsilon]]
operator.

So, all the construction herein is powered by six axioms, three of them are
Schutte's axioms, and the other ones allow us to work in that "classical" framework, still using the Coq proof assistant and its libraries.

** Schutte's Axioms

 We consider a type [ON] (Ordinal numbers), well-ordered by some relation
 [lt], and such that every subset [X] of [Ord] is countable iff [X] is bounded.

[[

Axiom AX1 : WO lt.

Axiom AX2 : forall X: Ensemble Ord, (exists a,  (forall y, X y -> y < a)) ->
                                   countable X.

Axiom AX3 : forall X : Ensemble Ord,
              countable X ->
              exists a,  forall y, X y -> y < a.

]]

** Classical logic and Hilbert style

*** From [Coq.Logic.Classical]

[[
Axiom classic : forall P:Prop, P \/ ~ P.
]]

*** From [Coq.Logic.Epsilon]

[[

Axiom epsilon_statement :
  forall (A : Type) (P : A->Prop), inhabited A ->
    { x : A | (exists x, P x) -> P x }.

]]

*** Needed for [epsilon] to work properly.

[[
Axiom inh_Ord : inhabited Ord.

]]
**)
(* begin snippet Ex42a:: no-out *)
Example Ex42: omega + 42 + omega^2 = omega^2.
(* end snippet Ex42a *)
Proof.

  (* begin snippet Ex42b *)
  assert (HAP:= AP_phi0 2). (* .no-out *)
  elim  HAP; intros _ H0; apply H0; clear H0.
  (* end snippet Ex42b *)
  (* begin snippet Ex42d *)
  Check AP_plus_closed. (* .unfold .no-goals *)
  (* end snippet Ex42d *)
  (* begin snippet Ex42c *)
  assert (Hlt: omega < omega^2) by
      (rewrite omega_eqn; apply phi0_mono, finite_mono;
        auto with arith).
  (* end  snippet Ex42c *)

  (* begin snippet Ex42e:: no-hyps *)
  apply AP_plus_closed; trivial.
  (* ... *)
  (* end snippet Ex42e *)
  -  apply lt_trans with omega; [| trivial].
     apply finite_lt_omega.
Qed.


Require Import GHZ.
Require Import SQIR.ExtractionGateSet.

(** Alternate definition of GHZ used for extraction. *)

Fixpoint ghz (n : nat) : ucom U :=
  match n with
  | 0        => SKIP
  | 1        => H 0
  | S (S n'' as n') => ghz n' >> CX n'' n'
  end.

Lemma ghz_same : forall dim n,
  uc_eval dim (ghz n) = UnitarySem.uc_eval (GHZ.GHZ dim n).
Proof.
  intros dim n.
  induction n; simpl.
  reflexivity.
  destruct n.
  reflexivity.
  remember (ghz (S n)) as ghzn.
  remember (GHZ dim (S n)) as GHZn.
  unfold uc_eval in *.
  simpl.
  rewrite IHn.
  reflexivity.
Qed.

Theorem ghz_correct : forall n : nat,
  (0 < n)%nat -> uc_eval n (ghz n) × n ⨂ ∣0⟩ = GHZ.ghz n.
Proof.
  intros.
  rewrite ghz_same.
  apply GHZ.GHZ_correct.
  assumption.
Qed.


(* TLC in Coq
 *
 * Module: tlc.syntax.assertion
 * Purpose: Contains the syntax of assertions.
 *)

Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.seq.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrnat.
Require Import tlc.operation.orientation.
Require Import tlc.syntax.constructor.
Require Import tlc.syntax.flexible.
Require Import tlc.syntax.function.
Require Import tlc.syntax.parameter.
Require Import tlc.syntax.predicate.
Require Import tlc.syntax.term.
Require Import tlc.syntax.unknown.
Require Import tlc.syntax.variable.
Require Import tlc.utility.seq.

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

(* Forms of logical assertions *)
Inductive assertion :=
(* Predicate logic *)
| AFalse
| APredicate (p : predicate) (* Predicates *)
| ANot (A : assertion) (* Negation *)
| AAnd (A1 A2 : assertion) (* Conjunction *)
| AForAll (A : assertion) (* Universal quantification *)
| AApplication (A : assertion) (t : term) (* Universal instantiation *)
(* Temporal logic *)
| AAlways' (A : assertion) (* Always strictly in the future *)
| AAlwaysP' (A : assertion) (* Always strictly in the past *)
| AEventually' (A : assertion) (* Eventually strictly in the future *)
| AEventuallyP' (A : assertion) (* Eventually strictly in the past *)
| ANext (A : assertion) (* In the next label *)
| APrevious (A : assertion) (* In the previous label *)
| ASelf (A : assertion). (* Subtrace of self events *)

(* Equality *)
Section eq.

  (* Boolean equality *)
  Fixpoint assertion_eq A1 A2 :=
    match A1, A2 with
    (* Predicate logic *)
    | AFalse, AFalse => true
    | APredicate p1, APredicate p2 => p1 == p2
    | ANot A1, ANot A2 => assertion_eq A1 A2
    | AAnd A1_1 A1_2, AAnd A2_1 A2_2 =>
      assertion_eq A1_1 A2_1 && assertion_eq A1_2 A2_2
    | AForAll A1, AForAll A2 => assertion_eq A1 A2
    | AApplication A1 t1, AApplication A2 t2 => assertion_eq A1 A2 && (t1 == t2)
    (* Temporal logic *)
    | AAlways' A1, AAlways' A2 => assertion_eq A1 A2
    | AAlwaysP' A1, AAlwaysP' A2 => assertion_eq A1 A2
    | AEventually' A1, AEventually' A2 => assertion_eq A1 A2
    | AEventuallyP' A1, AEventuallyP' A2 => assertion_eq A1 A2
    | ANext A1, ANext A2 => assertion_eq A1 A2
    | APrevious A1, APrevious A2 => assertion_eq A1 A2
    | ASelf A1, ASelf A2 => assertion_eq A1 A2
    (* Unequal *)
    | _, _ => false
    end.

  (* Boolean equality reflection *)
  Lemma assertion_eqP : Equality.axiom assertion_eq.
  Proof.
    elim=>
      [| p1 | A1 IHA | A1_1 IHA1 A1_2 IHA2 | A1 IHA | A1 IHA t1
        | A1 IHA | A1 IHA | A1 IHA | A1 IHA | A1 IHA | A1 IHA | A1 IHA]
      [| p2 | A2 | A2_1 A2_2 | A2 | A2 t2 | A2 | A2 | A2 | A2 | A2 | A2 | A2]
      //=; try by constructor.
    - by have [<- | neqx] := p1 =P p2; last (by right; case); constructor.
    - by have [<- | neqx] := IHA A2; last (by right; case); constructor.
    - have [<- | neqx] := IHA1 A2_1; last (by right; case); simpl.
      have [<- | neqx] := IHA2 A2_2; last (by right; case); simpl.
      by constructor.
    - by have [<- | neqx] := IHA A2; last (by right; case); constructor.
    - have [<- | neqx] := IHA A2; last (by right; case); simpl.
      have [<- | neqx] := t1 =P t2; last (by right; case); simpl.
      by constructor.
    - by have [<- | neqx] := IHA A2; last (by right; case); constructor.
    - by have [<- | neqx] := IHA A2; last (by right; case); constructor.
    - by have [<- | neqx] := IHA A2; last (by right; case); constructor.
    - by have [<- | neqx] := IHA A2; last (by right; case); constructor.
    - by have [<- | neqx] := IHA A2; last (by right; case); constructor.
    - by have [<- | neqx] := IHA A2; last (by right; case); constructor.
    - by have [<- | neqx] := IHA A2; last (by right; case); constructor.
  Qed.

  (* EqType canonical structures *)
  Definition assertion_eqMixin := EqMixin assertion_eqP.
  Canonical assertion_eqType := EqType assertion assertion_eqMixin.

End eq.

(* Constructor coercions *)
Coercion APredicate : predicate >-> assertion.

(* Notation scope *)
Declare Scope assertion_scope.
Bind Scope assertion_scope with assertion.
Delimit Scope assertion_scope with assertion.

Notation "{-A A -}" := (A%assertion)
  (at level 0, A at level 100, no associativity, only parsing).

(* Constructor notations *)
Notation "~ A" := (ANot A) : assertion_scope.
Notation "A1 /\ A2" := (AAnd A1 A2) : assertion_scope.
Notation "forall: A" := (AForAll A)
  (at level 65, A at level 200, right associativity) : assertion_scope.
Notation "A ' t" := (AApplication A t)
  (at level 10, left associativity) : assertion_scope.
Notation "always^ A" := (AAlways' A)
  (at level 60, right associativity) : assertion_scope.
Notation "alwaysp^ A" := (AAlwaysP' A)
  (at level 60, right associativity) : assertion_scope.
Notation "eventually^ A" := (AEventually' A)
  (at level 60, right associativity) : assertion_scope.
Notation "eventuallyp^ A" := (AEventuallyP' A)
  (at level 60, right associativity) : assertion_scope.
Notation "'next' A" := (ANext A)
  (at level 60, right associativity) : assertion_scope.
Notation "'previous' A" := (APrevious A)
  (at level 60, right associativity) : assertion_scope.
Notation "'self' A" := (ASelf A)
  (at level 60, right associativity) : assertion_scope.

(* Constructor notations for predicates *)
Definition AEqual x1 x2 := APredicate (PEqual x1 x2).
Notation "x1 = x2" := (AEqual x1 x2) : assertion_scope.
Definition ALess x1 x2 := APredicate (PLess x1 x2).
Notation "x1 < x2" := (ALess x1 x2) : assertion_scope.
Definition AIn y xs := APredicate (PMember y xs).
Notation "y \in xs" := (AIn y xs) : assertion_scope.
Definition AExtension xs' xs := APredicate (PExtension xs' xs).
Notation "xs' <<< xs" := (AExtension xs' xs)
  (at level 20, no associativity) : assertion_scope.

(* Derived constructor notations for predicate logic *)
Definition ATrue := {-A ~ AFalse -}.
Definition AOr A1 A2 := {-A ~(~A1 /\ ~A2) -}.
Notation "A1 \/ A2" := (AOr A1 A2) : assertion_scope.
Definition AIf A1 A2 := {-A ~A1 \/ A2 -}.
Notation "A1 -> A2" := (AIf A1 A2) : assertion_scope.
Definition AIff A1 A2 := {-A (A1 -> A2) /\ (A2 -> A1) -}.
Notation "A1 <-> A2" := (AIff A1 A2) : assertion_scope.
Definition AExists A := {-A ~forall: ~A -}.
Notation "exists: A" := (AExists A)
  (at level 65, A at level 200, right associativity) : assertion_scope.

(* Derived constructor notations for predicates *)
Definition ANotEqual x1 x2 := {-A ~(x1 = x2) -}.
Notation "x1 <> x2" := (ANotEqual x1 x2) : assertion_scope.
Definition ALessEqual x1 x2 := {-A x1 < x2 \/ x1 = x2 -}.
Notation "x1 <= x2" := (ALessEqual x1 x2) : assertion_scope.
Definition AGreater x1 x2 := {-A ~ x1 <= x2 -}.
Notation "x1 > x2" := (AGreater x1 x2) : assertion_scope.
Definition AGreaterEqual x1 x2 := {-A ~ x1 < x2 -}.
Notation "x1 >= x2" := (AGreaterEqual x1 x2) : assertion_scope.
Definition ANotIn y xs := {-A ~ y \in xs -}.
Notation "y \notin xs" := (ANotIn y xs) : assertion_scope.

(* Derived strict and immediate past temporal operators *)
Definition APrevious' A := {-A ~previous ~A -}.
Notation "previous^ A" := (APrevious' A)
  (at level 60, right associativity) : assertion_scope.

(* Derived reflexive future temporal operators *)
Definition AEventually A := {-A A \/ eventually^ A -}.
Notation "'eventually' A" := (AEventually A)
  (at level 60, right associativity) : assertion_scope.
Definition AAlways A := {-A A /\ always^ A -}.
Notation "'always' A" := (AAlways A)
  (at level 60, right associativity) : assertion_scope.

(* Derived reflexive past temporal operators *)
Definition AEventuallyP A := {-A A \/ eventuallyp^ A -}.
Notation "'eventuallyp' A" := (AEventuallyP A)
  (at level 60, right associativity) : assertion_scope.
Definition AAlwaysP A := {-A A /\ alwaysp^ A -}.
Notation "'alwaysp' A" := (AAlwaysP A)
  (at level 60, right associativity) : assertion_scope.

(* Additional temporal operators *)
Definition AEntails A1 A2 := {-A always (A1 -> A2) -}.
Notation "A1 =>> A2" := (AEntails A1 A2)
  (at level 99, right associativity) : assertion_scope.
Definition ACongruent A1 A2 := {-A always (A1 <-> A2) -}.
Notation "A1 <=> A2" := (ACongruent A1 A2)
  (at level 95, no associativity) : assertion_scope.
Definition AFollowedBy A1 A2 := {-A A1 =>> eventually A2 -}.
Notation "A1 ~> A2" := (AFollowedBy A1 A2)
  (at level 90, right associativity) : assertion_scope.
Definition APrecededBy A1 A2 := {-A A1 =>> eventuallyp A2 -}.
Notation "A1 <~ A2" := (APrecededBy A1 A2)
  (at level 90, right associativity) : assertion_scope.

(* Component syntactic sugar *)
Definition AOn n A := {-A Fn = n /\ A -}.
Notation "'on' n , A" := (AOn n A)
  (at level 89, right associativity, format "'on'  n ,  A")
  : assertion_scope. (* Between connectives and entailment *)
Definition ATopRequest e :=
  {-A Fd = [] /\ Fo = CRequest /\ Fe = e -}.
Notation "'event' []-> e" := (ATopRequest e)
  (at level 60, no associativity, format "'event' []->  e")
  : assertion_scope.
Definition ATopIndication e :=
  {-A Fd = [] /\ Fo = CIndication /\ Fe = e -}.
Notation "'event' []<- e" := (ATopIndication e)
  (at level 60, no associativity, format "'event' []<-  e")
  : assertion_scope.
Definition ATopPeriodic e :=
  {-A Fd = [] /\ Fo = CPeriodic /\ Fe = e -}.
Notation "'event' []~> e" := (ATopPeriodic e)
  (at level 60, no associativity, format "'event' []~>  e")
  : assertion_scope.
Definition ASubRequest i e :=
  {-A Fd = [i] /\ Fo = CRequest /\ Fe = e -}.
Notation "'event' [ i ]-> e" := (ASubRequest i e)
  (at level 60, no associativity, format "'event' [ i ]->  e")
  : assertion_scope.
Definition ASubIndication i e :=
  {-A Fd = [i] /\ Fo = CIndication /\ Fe = e -}.
Notation "'event' [ i ]<- e" := (ASubIndication i e)
  (at level 60, no associativity, format "'event' [ i ]<-  e")
  : assertion_scope.
Definition ASubPeriodic i e :=
  {-A Fd = [i] /\ Fo = CPeriodic /\ Fe = e -}.
Notation "'event' [ i ]~> e" := (ASubPeriodic i e)
  (at level 60, no associativity, format "'event' [ i ]~>  e")
  : assertion_scope.
Definition ASelfEvent :=
  {-A (exists: Fd = [$0] /\ Fo = CIndication) \/
    (Fd = [] /\ Fo = CRequest) \/
    (Fd = [] /\ Fo = CPeriodic) -}.
Notation "self-event" := ASelfEvent
  (at level 60, no associativity) : assertion_scope.

(* Tactics *)
(* Due to its complexity, folding self-event is most easily accomplished using a
 * lemma establishing the equality of its definition (after explosion and
 * folding) and itself.
 *)
Lemma fold_ASelfEvent :
  AIf
    (AForAll
      (ANot
        (AAnd
          (AEqual Fd (TCons (TParameter (P O O)) TNil))
          (AEqual Fo CIndication))))
    (AOr
      (AAnd (AEqual Fd TNil) (AEqual Fo CRequest))
      (AAnd (AEqual Fd TNil) (AEqual Fo CPeriodic)))
  = ASelfEvent.
Proof. by []. Qed.
Ltac dfold_assertion :=
  dfold_term;
  repeat match goal with
  (* Constructor notations for predicates *)
  | |- context[ APredicate (PEqual ?x1 ?x2) ] => rewrite -/(AEqual x1 x2)
  | |- context[ APredicate (PLess ?x1 ?x2) ] => rewrite -/(ALess x1 x2)
  | |- context[ APredicate (PMember ?y ?xs) ] => rewrite -/(AIn y xs)
  | |- context[ APredicate (PExtension ?xs' ?xs) ] => rewrite -/(AExtension xs' xs)

  (* Derived constructor notations for predicate logic *)
  | |- context[ {-A ~ AFalse -} ] => rewrite -/ATrue
  | |- context[ {-A ~(~?A1 /\ ~?A2) -} ] => rewrite -/(AOr A1 A2)
  | |- context[ {-A ~?A1 \/ ?A2 -} ] => rewrite -/(AIf A1 A2)
  | |- context[ {-A (?A1 -> ?A2) /\ (?A2 -> ?A1) -} ] => rewrite -/(AIff A1 A2)
  | |- context[ {-A ~forall: ~?A -} ] => rewrite -/(AExists A)

  (* Derived constructor notations for predicates *)
  | |- context[ {-A ~(?x1 = ?x2) -} ] => rewrite -/(ANotEqual x1 x2)
  | |- context[ {-A ?x1 < ?x2 \/ ?x1 = ?x2 -} ] => rewrite -/(ALessEqual x1 x2)
  | |- context[ {-A ~ ?x1 <= ?x2 -} ] => rewrite -/(AGreater x1 x2)
  | |- context[ {-A ~ ?x1 < ?x2 -} ] => rewrite -/(AGreaterEqual x1 x2)
  | |- context[ {-A ~ ?y \in ?xs -} ] => rewrite -/(ANotIn y xs)

  (* Derived strict and immediate past temporal operators *)
  | |- context[ {-A ~previous ~?A -} ] => rewrite -/(APrevious' A)

  (* Derived reflexive future temporal operators *)
  | |- context[ {-A ?A \/ eventually^ ?A -} ] => rewrite -/(AEventually A)
  | |- context[ {-A ?A /\ always^ ?A -} ] => rewrite -/(AAlways A)

  (* Derived reflexive past temporal operators *)
  | |- context[ {-A ?A \/ eventuallyp^ ?A -} ] => rewrite -/(AEventuallyP A)
  | |- context[ {-A ?A /\ alwaysp^ ?A -} ] => rewrite -/(AAlwaysP A)

  (* Additional temporal operators *)
  | |- context[ {-A always (?A1 -> ?A2) -} ] => rewrite -/(AEntails A1 A2)
  | |- context[ {-A always (?A1 <-> ?A2) -} ] => rewrite -/(ACongruent A1 A2)
  | |- context[ {-A ?A1 =>> eventually ?A2 -} ] => rewrite -/(AFollowedBy A1 A2)
  | |- context[ {-A ?A1 =>> eventuallyp ?A2 -} ] => rewrite -/(APrecededBy A1 A2)

  (* Component syntactic sugar *)
  | |- context[ {-A TVariable (VF Fn) = ?n /\ ?A -} ] => rewrite -/(AOn n A)
  | |- context[ {-A
    TVariable (VF Fd) = [] /\
    TVariable (VF Fo) = TConstructor CRequest /\
    TVariable (VF Fe) = ?e
  -} ] => rewrite -/(ATopRequest e)
  | |- context[ {-A
    TVariable (VF Fd) = [] /\
    TVariable (VF Fo) = TConstructor CIndication /\
    TVariable (VF Fe) = ?e
  -} ] => rewrite -/(ATopIndication e)
  | |- context[ {-A
    TVariable (VF Fd) = [] /\
    TVariable (VF Fo) = TConstructor CPeriodic /\
    TVariable (VF Fe) = ?e
  -} ] => rewrite -/(ATopPeriodic e)
  | |- context[ {-A
    TVariable (VF Fd) = [?i] /\
    TVariable (VF Fo) = TConstructor CRequest /\
    TVariable (VF Fe) = ?e
  -} ] => rewrite -/(ASubRequest i e)
  | |- context[ {-A
    TVariable (VF Fd) = [?i] /\
    TVariable (VF Fo) = TConstructor CIndication /\
    TVariable (VF Fe) = ?e
  -} ] => rewrite -/(ASubIndication i e)
  | |- context[ {-A
    TVariable (VF Fd) = [?i] /\
    TVariable (VF Fo) = TConstructor CPeriodic /\
    TVariable (VF Fe) = ?e
  -} ] => rewrite -/(ASubPeriodic i e)
  | |- context[ {-A
    (exists: TVariable (VF Fd) = [$0] /\
      TVariable (VF Fo) = TConstructor CIndication) \/
    (TVariable (VF Fd) = [] /\ TVariable (VF Fo) = TConstructor CRequest) \/
    (TVariable (VF Fd) = [] /\ TVariable (VF Fo) = TConstructor CPeriodic)
  -} ] => rewrite -/ASelfEvent
  end;
  rewrite ?fold_ASelfEvent.

(* Forms of non-temporal assertions
 * Non-temporal assertions do not contain any temporal operators.
 *)
Inductive non_temporal_assertion : assertion -> Type :=
| NTAFalse :
  non_temporal_assertion AFalse
| NTAPredicate p :
  non_temporal_assertion (APredicate p)
| NTANot A :
  non_temporal_assertion A ->
  non_temporal_assertion {-A ~A -}
| NTAAnd A1 A2 :
  non_temporal_assertion A1 ->
  non_temporal_assertion A2 ->
  non_temporal_assertion {-A A1 /\ A2 -}
| NTAForAll A :
  non_temporal_assertion A ->
  non_temporal_assertion {-A forall: A -}
| NTAApplication A t :
  non_temporal_assertion A ->
  non_temporal_assertion {-A A ' t -}.

(* Forms of assertions at a particular location
 * Location assertions are restricted to specific forms of atomic assertions
 * and any compositions of those assertions, excluding the next, previous, and
 * self operators.
 *
 * The sequence of naturals represents the distinct location at which the
 * assertion is made.
 *)
Inductive location_assertion : seq nat -> assertion -> Type :=
| LAEventOn d n dp o e :
  location_assertion d {-A on n,
    (Fd = term_of_list [seq term_of_nat i | i <- dp ++ d] /\
      Fo = o /\ Fe = e) -}
| LACorrect d n :
  location_assertion d {-A n \in UCorrect -}
| LANot d A :
  location_assertion d A ->
  location_assertion d {-A ~A -}
| LAAnd d A1 A2 :
  location_assertion d A1 ->
  location_assertion d A2 ->
  location_assertion d {-A A1 /\ A2 -}
| LAForAll d A :
  location_assertion d A ->
  location_assertion d {-A forall: A -}
| LAApplication d A t :
  location_assertion d A ->
  location_assertion d {-A A ' t -}
| LAAlways' d A :
  location_assertion d A ->
  location_assertion d {-A always^ A -}
| LAAlwaysP' d A :
  location_assertion d A ->
  location_assertion d {-A alwaysp^ A -}
| LAEventually' d A :
  location_assertion d A ->
  location_assertion d {-A eventually^ A -}
| LAEventuallyP' d A :
  location_assertion d A ->
  location_assertion d {-A eventuallyp^ A -}.

(* Derived first-order operators *)
Lemma LAOr d A1 A2 :
  location_assertion d A1 ->
  location_assertion d A2 ->
  location_assertion d {-A A1 \/ A2 -}.
Proof. move=> LA1 LA2; by repeat constructor. Defined.
Hint Resolve LAOr : core.

Lemma LAIf d A1 A2 :
  location_assertion d A1 ->
  location_assertion d A2 ->
  location_assertion d {-A A1 -> A2 -}.
Proof. move=> LA1 LA2; by repeat constructor. Defined.
Hint Resolve LAIf : core.

Lemma LAIff d A1 A2 :
  location_assertion d A1 ->
  location_assertion d A2 ->
  location_assertion d {-A A1 <-> A2 -}.
Proof. move=> LA1 LA2; by repeat constructor. Defined.
Hint Resolve LAIff : core.

Lemma LAExists d A :
  location_assertion d A ->
  location_assertion d {-A exists: A -}.
Proof. move=> LA; by repeat constructor. Defined.
Hint Resolve LAExists : core.

(* Derived reflexive future temporal operators *)
Lemma LAEventually d A :
  location_assertion d A ->
  location_assertion d {-A eventually A -}.
Proof. move=> LA; by repeat constructor. Defined.
Hint Resolve LAEventually : core.

Lemma LAAlways d A :
  location_assertion d A ->
  location_assertion d {-A always A -}.
Proof. move=> LA; by repeat constructor. Defined.
Hint Resolve LAAlways : core.

(* Derived reflexive past temporal operators *)
Lemma LAEventuallyP d A :
  location_assertion d A ->
  location_assertion d {-A eventuallyp A -}.
Proof. move=> LA; by repeat constructor. Defined.
Hint Resolve LAEventuallyP : core.

Lemma LAAlwaysP d A :
  location_assertion d A ->
  location_assertion d {-A alwaysp A -}.
Proof. move=> LA; by repeat constructor. Defined.
Hint Resolve LAAlwaysP : core.

(* Additional temporal operators *)
Lemma LAEntails d A1 A2 :
  location_assertion d A1 ->
  location_assertion d A2 ->
  location_assertion d {-A A1 =>> A2 -}.
Proof. move=> LA1 LA2; by repeat constructor. Defined.
Hint Resolve LAEntails : core.

Lemma LACongruent d A1 A2 :
  location_assertion d A1 ->
  location_assertion d A2 ->
  location_assertion d {-A A1 <=> A2 -}.
Proof. move=> LA1 LA2; by repeat constructor. Defined.
Hint Resolve LACongruent : core.

Lemma LAFollowedBy d A1 A2 :
  location_assertion d A1 ->
  location_assertion d A2 ->
  location_assertion d {-A A1 ~> A2 -}.
Proof. move=> LA1 LA2; by repeat constructor. Defined.
Hint Resolve LAFollowedBy : core.

Lemma LAPrecededBy d A1 A2 :
  location_assertion d A1 ->
  location_assertion d A2 ->
  location_assertion d {-A A1 <~ A2 -}.
Proof. move=> LA1 LA2; by repeat constructor. Defined.
Hint Resolve LAPrecededBy : core.

(* Forms of assertions on the top component
 * Top assertions are simply location assertions specialized for the empty
 * distinct location.
 *)
Definition top_assertion := location_assertion [::].

(* Forms of assertions that are invariants at a particular location
 * Location invariants are location assertions in which the outermost operator
 * is the always-in-the-future operator.
 *)
Inductive location_invariant : seq nat -> assertion -> Type :=
| LIA d A :
  location_assertion d A ->
  location_invariant d {-A always A -}.

(* Every location invariant is also a location assertion *)
Lemma location_invariant_assertion d A :
  location_invariant d A ->
  location_assertion d A.
Proof.
  by case=> ???; apply: LAAlways.
Defined.

(* Forms of assertions that are invariants on the top component
 * Top invariants are simply location invariants specialized for the empty
 * distinct location.
 *)
Definition top_invariant := location_invariant [::].

(* Forms of assertions that are self invariants
 * Self invariants are restricted to specific forms of atomic assertions and
 * any compositions of those assertions, excluding the next, previous, and
 * self operators.
 *
 * The sequence of naturals represents the distinct location at which the
 * assertion is made.
 *)
Inductive self_invariant : assertion -> Type :=
| SITopRequestOn n e :
  self_invariant {-A on n, event []-> e -}
| SITopPeriodicOn n e :
  self_invariant {-A on n, event []~> e -}
| SISubIndicationOn n i e :
  self_invariant {-A on n, event [i]<- e -}
| SICorrect n :
  self_invariant {-A n \in UCorrect -}
| SINot A :
  self_invariant A ->
  self_invariant {-A ~A -}
| SIAnd A1 A2 :
  self_invariant A1 ->
  self_invariant A2 ->
  self_invariant {-A A1 /\ A2 -}
| SIForAll A :
  self_invariant A ->
  self_invariant {-A forall: A -}
| SIApplication A t :
  self_invariant A ->
  self_invariant {-A A ' t -}
| SIAlways' A :
  self_invariant A ->
  self_invariant {-A always^ A -}
| SIAlwaysP' A :
  self_invariant A ->
  self_invariant {-A alwaysp^ A -}
| SIEventually' A :
  self_invariant A ->
  self_invariant {-A eventually^ A -}
| SIEventuallyP' A :
  self_invariant A ->
  self_invariant {-A eventuallyp^ A -}.

(* Forms of assertions that are rigid predicates *)
Inductive rigid_predicate : assertion -> Type :=
| RPEqual x1 x2 :
  rigid_predicate {-A x1 = x2 -}.