Require Import Coq.Classes.Morphisms.
Require Import Relation_Definitions.

Import Logic.
Import Basics.

(*Proper IFF tac*)
Ltac respectful_intros:=
  match goal with
  |  |- (_ ==> _)%signature _ _ => intros ???; respectful_intros
  | |- impl _ _ => unfold impl
  | _ => idtac
  end.
Ltac proper_intros:=
  intros;
  match goal with
    |- Proper (_ ==> _) _ => unfold Proper; respectful_intros
  end; intros.

Class two_way_relation {T} Rimpl Riff:=
  {TwoWay: forall (x y:T), Rimpl x y -> Rimpl y x -> Riff x y}.

Instance TwoWayIff:
  two_way_relation impl iff.
Proof. constructor; intros ????. split; auto. Qed.

Lemma Proper_two_way
   {A B} {R1 R2: relation B} {a: relation A} {f: A -> B}
    `{Syma: Symmetric _ a}
    `{TwoWay:two_way_relation _ R1 R2}:
    Proper (a ==> R1) f ->
    Proper (a ==> R2) f.
Proof. proper_intros; eapply TwoWay; eapply H ; auto. Qed.

(* BUGish: [Check Proper_two_way] binds to iff impl *)

Ltac proper_iff:=
  intros;
  match goal with
    |- Proper _ _ =>
    eapply Proper_two_way; auto
  end.

Instance two_way2
   {A B} {a: relation A} {b1 b2: relation B}
    `{Syma:Symmetric _ a}
    `{TwoWay:two_way_relation _ b1 b2}:
    two_way_relation (a ==> b1)%signature (a ==> b2)%signature.
Proof. intros. constructor; intros ???? ???. eapply TwoWay; eauto. Qed.

(* Example :
Lemma Proper_iff3:
  forall {A} (a b c: relation A) f,
    `(Symmetric a) ->
    `(Symmetric b) ->
    `(Symmetric c) ->
    Proper (a ==> b ==> c ==> impl) f ->
    Proper (a ==> b ==> c ==>  iff) f.
Proof. proper_iff. Qed.
*)


(* Copyright (c) 2008-2012, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* begin hide *)
Require Import Coq.Lists.List.
Require Import List.

Require Import CpdtTactics.

Definition bad : unit := tt.

Set Implicit Arguments.
(* end hide *)

(** %\chapter{Infinite Data and Proofs}% *)

(** In lazy functional programming languages like %\index{Haskell}%Haskell, infinite data structures are everywhere%~\cite{whyfp}%.  Infinite lists and more exotic datatypes provide convenient abstractions for communication between parts of a program.  Achieving similar convenience without infinite lazy structures would, in many cases, require acrobatic inversions of control flow.

%\index{laziness}%Laziness is easy to implement in Haskell, where all the definitions in a program may be thought of as mutually recursive.  In such an unconstrained setting, it is easy to implement an infinite loop when you really meant to build an infinite list, where any finite prefix of the list should be forceable in finite time.  Haskell programmers learn how to avoid such slip-ups.  In Coq, such a laissez-faire policy is not good enough.

We spent some time in the last chapter discussing the %\index{Curry-Howard correspondence}%Curry-Howard isomorphism, where proofs are identified with functional programs.  In such a setting, infinite loops, intended or otherwise, are disastrous.  If Coq allowed the full breadth of definitions that Haskell did, we could code up an infinite loop and use it to prove any proposition vacuously.  That is, the addition of general recursion would make CIC _inconsistent_.  For an arbitrary proposition [P], we could write:
[[
Fixpoint bad (u : unit) : P := bad u.
]]

This would leave us with [bad tt] as a proof of [P].

There are also algorithmic considerations that make universal termination very desirable.  We have seen how tactics like [reflexivity] compare terms up to equivalence under computational rules.  Calls to recursive, pattern-matching functions are simplified automatically, with no need for explicit proof steps.  It would be very hard to hold onto that kind of benefit if it became possible to write non-terminating programs; we would be running smack into the halting problem.

One solution is to use types to contain the possibility of non-termination.  For instance, we can create a "non-termination monad," inside which we must write all of our general-recursive programs; several such approaches are surveyed in Chapter 7.  This is a heavyweight solution, and so we would like to avoid it whenever possible.

Luckily, Coq has special support for a class of lazy data structures that happens to contain most examples found in Haskell.  That mechanism,%\index{co-inductive types}% _co-inductive types_, is the subject of this chapter. *)

(** * Computing with Infinite Data *)

(** Let us begin with the most basic type of infinite data, _streams_, or lazy lists.%\index{Vernacular commands!CoInductive}% *)

Section stream.
  Variable A : Type.

  CoInductive stream : Type :=
  | Cons : A -> stream -> stream.
End stream.

(* begin hide *)
(* begin thide *)
CoInductive evilStream := Nil.
(* end thide *)
(* end hide *)

(** The definition is surprisingly simple.  Starting from the definition of [list], we just need to change the keyword [Inductive] to [CoInductive].  We could have left a [Nil] constructor in our definition, but we will leave it out to force all of our streams to be infinite.

   How do we write down a stream constant?  Obviously, simple application of constructors is not good enough, since we could only denote finite objects that way.  Rather, whereas recursive definitions were necessary to _use_ values of recursive inductive types effectively, here we find that we need%\index{co-recursive definitions}% _co-recursive definitions_ to _build_ values of co-inductive types effectively.

   We can define a stream consisting only of zeroes.%\index{Vernacular commands!CoFixpoint}% *)

CoFixpoint zeroes : stream nat := Cons 0 zeroes.

(* EX: Define a stream that alternates between [true] and [false]. *)
(* begin thide *)

(** We can also define a stream that alternates between [true] and [false]. *)

CoFixpoint trues_falses : stream bool := Cons true falses_trues
with falses_trues : stream bool := Cons false trues_falses.
(* end thide *)

(** Co-inductive values are fair game as arguments to recursive functions, and we can use that fact to write a function to take a finite approximation of a stream. *)

(* EX: Define a function to calculate a finite approximation of a stream, to a particular length. *)
(* begin thide *)

Fixpoint approx A (s : stream A) (n : nat) : list A :=
  match n with
    | O => nil
    | S n' =>
      match s with
        | Cons h t => h :: approx t n'
      end
  end.

Eval simpl in approx zeroes 10.
(** %\vspace{-.15in}% [[
     = 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: 0 :: nil
     : list nat
     ]]
     *)

Eval simpl in approx trues_falses 10.
(** %\vspace{-.15in}% [[
     = true
       :: false
          :: true
             :: false
                :: true :: false :: true :: false :: true :: false :: nil
     : list bool
      ]]
*)

(* end thide *)

(* begin hide *)
(* begin thide *)
Definition looper := 0.
(* end thide *)
(* end hide *)

(** So far, it looks like co-inductive types might be a magic bullet, allowing us to import all of the Haskeller's usual tricks.  However, there are important restrictions that are dual to the restrictions on the use of inductive types.  Fixpoints _consume_ values of inductive types, with restrictions on which _arguments_ may be passed in recursive calls.  Dually, co-fixpoints _produce_ values of co-inductive types, with restrictions on what may be done with the _results_ of co-recursive calls.

The restriction for co-inductive types shows up as the%\index{guardedness condition}% _guardedness condition_.  First, consider this stream definition, which would be legal in Haskell.
[[
CoFixpoint looper : stream nat := looper.
]]

<<
Error:
Recursive definition of looper is ill-formed.
In environment
looper : stream nat

unguarded recursive call in "looper"
>>

The rule we have run afoul of here is that _every co-recursive call must be guarded by a constructor_; that is, every co-recursive call must be a direct argument to a constructor of the co-inductive type we are generating.  It is a good thing that this rule is enforced.  If the definition of [looper] were accepted, our [approx] function would run forever when passed [looper], and we would have fallen into inconsistency.

Some familiar functions are easy to write in co-recursive fashion. *)

Section map.
  Variables A B : Type.
  Variable f : A -> B.

  CoFixpoint map (s : stream A) : stream B :=
    match s with
      | Cons h t => Cons (f h) (map t)
    end.
End map.

(* begin hide *)
(* begin thide *)
Definition filter := 0.
(* end thide *)
(* end hide *)

(** This code is a literal copy of that for the list [map] function, with the [nil] case removed and [Fixpoint] changed to [CoFixpoint].  Many other standard functions on lazy data structures can be implemented just as easily.  Some, like [filter], cannot be implemented.  Since the predicate passed to [filter] may reject every element of the stream, we cannot satisfy the guardedness condition.

   The implications of the condition can be subtle.  To illustrate how, we start off with another co-recursive function definition that _is_ legal.  The function [interleave] takes two streams and produces a new stream that alternates between their elements. *)

Section interleave.
  Variable A : Type.

  CoFixpoint interleave (s1 s2 : stream A) : stream A :=
    match s1, s2 with
      | Cons h1 t1, Cons h2 t2 => Cons h1 (Cons h2 (interleave t1 t2))
    end.
End interleave.

(** Now say we want to write a weird stuttering version of [map] that repeats elements in a particular way, based on interleaving. *)

Section map'.
  Variables A B : Type.
  Variable f : A -> B.
(* begin thide *)
  (** %\vspace{-.15in}%[[
  CoFixpoint map' (s : stream A) : stream B :=
    match s with
      | Cons h t => interleave (Cons (f h) (map' t)) (Cons (f h) (map' t))
    end.
    ]]
    %\vspace{-.15in}%We get another error message about an unguarded recursive call. *)

End map'.

(** What is going wrong here?  Imagine that, instead of [interleave], we had called some other, less well-behaved function on streams.  Here is one simpler example demonstrating the essential pitfall.  We start by defining a standard function for taking the tail of a stream.  Since streams are infinite, this operation is total. *)

Definition tl A (s : stream A) : stream A :=
  match s with
    | Cons _ s' => s'
  end.

(** Coq rejects the following definition that uses [tl].
[[
CoFixpoint bad : stream nat := tl (Cons 0 bad).
]]

Imagine that Coq had accepted our definition, and consider how we might evaluate [approx bad 1].  We would be trying to calculate the first element in the stream [bad].  However, it is not hard to see that the definition of [bad] "begs the question": unfolding the definition of [tl], we see that we essentially say "define [bad] to equal itself"!  Of course such an equation admits no single well-defined solution, which does not fit well with the determinism of Gallina reduction.

Coq's complete rule for co-recursive definitions includes not just the basic guardedness condition, but also a requirement about where co-recursive calls may occur.  In particular, a co-recursive call must be a direct argument to a constructor, _nested only inside of other constructor calls or [fun] or [match] expressions_.  In the definition of [bad], we erroneously nested the co-recursive call inside a call to [tl], and we nested inside a call to [interleave] in the definition of [map'].

Coq helps the user out a little by performing the guardedness check after using computation to simplify terms.  For instance, any co-recursive function definition can be expanded by inserting extra calls to an identity function, and this change preserves guardedness.  However, in other cases computational simplification can reveal why definitions are dangerous.  Consider what happens when we inline the definition of [tl] in [bad]:
[[
CoFixpoint bad : stream nat := bad.
]]
This is the same looping definition we rejected earlier.  A similar inlining process reveals an alternate view on our failed definition of [map']:
[[
CoFixpoint map' (s : stream A) : stream B :=
  match s with
    | Cons h t => Cons (f h) (Cons (f h) (interleave (map' t) (map' t)))
  end.
]]
Clearly in this case the [map'] calls are not immediate arguments to constructors, so we violate the guardedness condition. *)
(* end thide *)

(** A more interesting question is why that condition is the right one.  We can make an intuitive argument that the original [map'] definition is perfectly reasonable and denotes a well-understood transformation on streams, such that every output would behave properly with [approx].  The guardedness condition is an example of a syntactic check for%\index{productivity}% _productivity_ of co-recursive definitions.  A productive definition can be thought of as one whose outputs can be forced in finite time to any finite approximation level, as with [approx].  If we replaced the guardedness condition with more involved checks, we might be able to detect and allow a broader range of productive definitions.  However, mistakes in these checks could cause inconsistency, and programmers would need to understand the new, more complex checks.  Coq's design strikes a balance between consistency and simplicity with its choice of guard condition, though we can imagine other worthwhile balances being struck, too. *)

(** * Infinite Proofs *)

(** Let us say we want to give two different definitions of a stream of all ones, and then we want to prove that they are equivalent. *)

CoFixpoint ones : stream nat := Cons 1 ones.
Definition ones' := map S zeroes.

(** The obvious statement of the equality is this: *)

Theorem ones_eq : ones = ones'.

(* begin hide *)
(* begin thide *)
Definition foo := @eq.
(* end thide *)
(* end hide *)

  (** However, faced with the initial subgoal, it is not at all clear how this theorem can be proved.  In fact, it is unprovable.  The [eq] predicate that we use is fundamentally limited to equalities that can be demonstrated by finite, syntactic arguments.  To prove this equivalence, we will need to introduce a new relation. *)
(* begin thide *)

Abort.

(** Co-inductive datatypes make sense by analogy from Haskell.  What we need now is a _co-inductive proposition_.  That is, we want to define a proposition whose proofs may be infinite, subject to the guardedness condition.  The idea of infinite proofs does not show up in usual mathematics, but it can be very useful (unsurprisingly) for reasoning about infinite data structures.  Besides examples from Haskell, infinite data and proofs will also turn out to be useful for modelling inherently infinite mathematical objects, like program executions.

We are ready for our first %\index{co-inductive predicates}%co-inductive predicate. *)

Section stream_eq.
  Variable A : Type.

  CoInductive stream_eq : stream A -> stream A -> Prop :=
  | Stream_eq : forall h t1 t2,
    stream_eq t1 t2
    -> stream_eq (Cons h t1) (Cons h t2).
End stream_eq.

(** We say that two streams are equal if and only if they have the same heads and their tails are equal.  We use the normal finite-syntactic equality for the heads, and we refer to our new equality recursively for the tails.

We can try restating the theorem with [stream_eq]. *)

Theorem ones_eq : stream_eq ones ones'.
  (** Coq does not support tactical co-inductive proofs as well as it supports tactical inductive proofs.  The usual starting point is the [cofix] tactic, which asks to structure this proof as a co-fixpoint. *)

  cofix.
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq ones ones'

   ]]

   It looks like this proof might be easier than we expected! *)

  assumption.
  (** <<
Proof completed.
>>

  Unfortunately, we are due for some disappointment in our victory lap.
  [[
Qed.
]]

<<
Error:
Recursive definition of ones_eq is ill-formed.

In environment
ones_eq : stream_eq ones ones'

unguarded recursive call in "ones_eq"
>>

Via the Curry-Howard correspondence, the same guardedness condition applies to our co-inductive proofs as to our co-inductive data structures.  We should be grateful that this proof is rejected, because, if it were not, the same proof structure could be used to prove any co-inductive theorem vacuously, by direct appeal to itself!

Thinking about how Coq would generate a proof term from the proof script above, we see that the problem is that we are violating the guardedness condition.  During our proofs, Coq can help us check whether we have yet gone wrong in this way.  We can run the command [Guarded] in any context to see if it is possible to finish the proof in a way that will yield a properly guarded proof term.%\index{Vernacular commands!Guarded}%
     [[
Guarded.
]]

     Running [Guarded] here gives us the same error message that we got when we tried to run [Qed].  In larger proofs, [Guarded] can be helpful in detecting problems _before_ we think we are ready to run [Qed].

     We need to start the co-induction by applying [stream_eq]'s constructor.  To do that, we need to know that both arguments to the predicate are [Cons]es.  Informally, this is trivial, but [simpl] is not able to help us. *)

  Undo.
  simpl.
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq ones ones'

   ]]

   It turns out that we are best served by proving an auxiliary lemma. *)

Abort.

(** First, we need to define a function that seems pointless at first glance. *)

Definition frob A (s : stream A) : stream A :=
  match s with
    | Cons h t => Cons h t
  end.

(** Next, we need to prove a theorem that seems equally pointless. *)

Theorem frob_eq : forall A (s : stream A), s = frob s.
  destruct s; reflexivity.
Qed.

(** But, miraculously, this theorem turns out to be just what we needed. *)

Theorem ones_eq : stream_eq ones ones'.
  cofix.

  (** We can use the theorem to rewrite the two streams. *)

  rewrite (frob_eq ones).
  rewrite (frob_eq ones').
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq (frob ones) (frob ones')

   ]]

   Now [simpl] is able to reduce the streams. *)

  simpl.
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq (Cons 1 ones)
     (Cons 1
        ((cofix map (s : stream nat) : stream nat :=
            match s with
            | Cons h t => Cons (S h) (map t)
            end) zeroes))

            ]]

  Note the [cofix] notation for anonymous co-recursion, which is analogous to the [fix] notation we have already seen for recursion.  Since we have exposed the [Cons] structure of each stream, we can apply the constructor of [stream_eq]. *)

  constructor.
  (** [[
  ones_eq : stream_eq ones ones'
  ============================
   stream_eq ones
     ((cofix map (s : stream nat) : stream nat :=
         match s with
         | Cons h t => Cons (S h) (map t)
         end) zeroes)

         ]]

  Now, modulo unfolding of the definition of [map], we have matched our assumption. *)

  assumption.
Qed.

(** Why did this silly-looking trick help?  The answer has to do with the constraints placed on Coq's evaluation rules by the need for termination.  The [cofix]-related restriction that foiled our first attempt at using [simpl] is dual to a restriction for [fix].  In particular, an application of an anonymous [fix] only reduces when the top-level structure of the recursive argument is known.  Otherwise, we would be unfolding the recursive definition ad infinitum.

   Fixpoints only reduce when enough is known about the _definitions_ of their arguments.  Dually, co-fixpoints only reduce when enough is known about _how their results will be used_.  In particular, a [cofix] is only expanded when it is the discriminee of a [match].  Rewriting with our superficially silly lemma wrapped new [match]es around the two [cofix]es, triggering reduction.

   If [cofix]es reduced haphazardly, it would be easy to run into infinite loops in evaluation, since we are, after all, building infinite objects.

   One common source of difficulty with co-inductive proofs is bad interaction with standard Coq automation machinery.  If we try to prove [ones_eq'] with automation, like we have in previous inductive proofs, we get an invalid proof. *)

Theorem ones_eq' : stream_eq ones ones'.
  cofix; crush.
  (** %\vspace{-.25in}%[[
  Guarded.
  ]]
  %\vspace{-.25in}%
  *)
Abort.

(** The standard [auto] machinery sees that our goal matches an assumption and so applies that assumption, even though this violates guardedness.  A correct proof strategy for a theorem like this usually starts by [destruct]ing some parameter and running a custom tactic to figure out the first proof rule to apply for each case.  Alternatively, there are tricks that can be played with "hiding" the co-inductive hypothesis.

   %\medskip%

   Must we always be cautious with automation in proofs by co-induction?  Induction seems to have dual versions of the same pitfalls inherent in it, and yet we avoid those pitfalls by encapsulating safe Curry-Howard recursion schemes inside named induction principles.  It turns out that we can usually do the same with%\index{co-induction principles}% _co-induction principles_.  Let us take that tack here, so that we can arrive at an [induction x; crush]-style proof for [ones_eq'].

   An induction principle is parameterized over a predicate characterizing what we mean to prove, _as a function of the inductive fact that we already know_.  Dually, a co-induction principle ought to be parameterized over a predicate characterizing what we mean to prove, _as a function of the arguments to the co-inductive predicate that we are trying to prove_.

   To state a useful principle for [stream_eq], it will be useful first to define the stream head function. *)

Definition hd A (s : stream A) : A :=
  match s with
    | Cons x _ => x
  end.

(** Now we enter a section for the co-induction principle, based on %\index{Park's principle}%Park's principle as introduced in a tutorial by Gim%\'%enez%~\cite{IT}%. *)

Section stream_eq_coind.
  Variable A : Type.
  Variable R : stream A -> stream A -> Prop.

  (** This relation generalizes the theorem we want to prove, defining a set of pairs of streams that we must eventually prove contains the particular pair we care about. *)

  Hypothesis Cons_case_hd : forall s1 s2, R s1 s2 -> hd s1 = hd s2.
  Hypothesis Cons_case_tl : forall s1 s2, R s1 s2 -> R (tl s1) (tl s2).

  (** Two hypotheses characterize what makes a good choice of [R]: it enforces equality of stream heads, and it is %``%#<i>#hereditary#</i>#%''% in the sense that an [R] stream pair passes on "[R]-ness" to its tails.  An established technical term for such a relation is%\index{bisimulation}% _bisimulation_. *)

  (** Now it is straightforward to prove the principle, which says that any stream pair in [R] is equal.  The reader may wish to step through the proof script to see what is going on. *)

  Theorem stream_eq_coind : forall s1 s2, R s1 s2 -> stream_eq s1 s2.
    cofix; destruct s1; destruct s2; intro.
    generalize (Cons_case_hd H); intro Heq; simpl in Heq; rewrite Heq.
    constructor.
    apply stream_eq_coind.
    apply (Cons_case_tl H).
  Qed.
End stream_eq_coind.

(** To see why this proof is guarded, we can print it and verify that the one co-recursive call is an immediate argument to a constructor. *)

Print stream_eq_coind.

(** We omit the output and proceed to proving [ones_eq''] again.  The only bit of ingenuity is in choosing [R], and in this case the most restrictive predicate works. *)

Theorem ones_eq'' : stream_eq ones ones'.
  apply (stream_eq_coind (fun s1 s2 => s1 = ones /\ s2 = ones')); crush.
Qed.

(** Note that this proof achieves the proper reduction behavior via [hd] and [tl], rather than [frob] as in the last proof.  All three functions pattern match on their arguments, catalyzing computation steps.

   Compared to the inductive proofs that we are used to, it still seems unsatisfactory that we had to write out a choice of [R] in the last proof.  An alternate is to capture a common pattern of co-recursion in a more specialized co-induction principle.  For the current example, that pattern is: prove [stream_eq s1 s2] where [s1] and [s2] are defined as their own tails. *)

Section stream_eq_loop.
  Variable A : Type.
  Variables s1 s2 : stream A.

  Hypothesis Cons_case_hd : hd s1 = hd s2.
  Hypothesis loop1 : tl s1 = s1.
  Hypothesis loop2 : tl s2 = s2.

  (** The proof of the principle includes a choice of [R], so that we no longer need to make such choices thereafter. *)

  Theorem stream_eq_loop : stream_eq s1 s2.
    apply (stream_eq_coind (fun s1' s2' => s1' = s1 /\ s2' = s2)); crush.
  Qed.
End stream_eq_loop.

Theorem ones_eq''' : stream_eq ones ones'.
  apply stream_eq_loop; crush.
Qed.
(* end thide *)

(** Let us put [stream_eq_coind] through its paces a bit more, considering two different ways to compute infinite streams of all factorial values.  First, we import the [fact] factorial function from the standard library. *)

Require Import Arith.
Print fact.
(** %\vspace{-.15in}%[[
fact =
fix fact (n : nat) : nat :=
  match n with
  | 0 => 1
  | S n0 => S n0 * fact n0
  end
     : nat -> nat
]]
*)

(** The simplest way to compute the factorial stream involves calling [fact] afresh at each position. *)

CoFixpoint fact_slow' (n : nat) := Cons (fact n) (fact_slow' (S n)).
Definition fact_slow := fact_slow' 1.

(** A more clever, optimized method maintains an accumulator of the previous factorial, so that each new entry can be computed with a single multiplication. *)

CoFixpoint fact_iter' (cur acc : nat) := Cons acc (fact_iter' (S cur) (acc * cur)).
Definition fact_iter := fact_iter' 2 1.

(** We can verify that the streams are equal up to particular finite bounds. *)

Eval simpl in approx fact_iter 5.
(** %\vspace{-.15in}%[[
     = 1 :: 2 :: 6 :: 24 :: 120 :: nil
     : list nat
]]
*)
Eval simpl in approx fact_slow 5.
(** %\vspace{-.15in}%[[
     = 1 :: 2 :: 6 :: 24 :: 120 :: nil
     : list nat
]]

Now, to prove that the two versions are equivalent, it is helpful to prove (and add as a proof hint) a quick lemma about the computational behavior of [fact].  (I intentionally skip explaining its proof at this point.) *)

(* begin thide *)
Lemma fact_def : forall x n,
  fact_iter' x (fact n * S n) = fact_iter' x (fact (S n)).
  simpl; intros; f_equal; ring.
Qed.

Hint Resolve fact_def.

(** With the hint added, it is easy to prove an auxiliary lemma relating [fact_iter'] and [fact_slow'].  The key bit of ingenuity is introduction of an existential quantifier for the shared parameter [n]. *)

Lemma fact_eq' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  intro; apply (stream_eq_coind (fun s1 s2 => exists n, s1 = fact_iter' (S n) (fact n)
    /\ s2 = fact_slow' n)); crush; eauto.
Qed.

(** The final theorem is a direct corollary of [fact_eq']. *)

Theorem fact_eq : stream_eq fact_iter fact_slow.
  apply fact_eq'.
Qed.

(** As in the case of [ones_eq'], we may be unsatisfied that we needed to write down a choice of [R] that seems to duplicate information already present in a lemma statement.  We can facilitate a simpler proof by defining a co-induction principle specialized to goals that begin with single universal quantifiers, and the strategy can be extended in a straightforward way to principles for other counts of quantifiers.  (Our [stream_eq_loop] principle is effectively the instantiation of this technique to zero quantifiers.) *)

Section stream_eq_onequant.
  Variables A B : Type.
  (** We have the types [A], the domain of the one quantifier; and [B], the type of data found in the streams. *)

  Variables f g : A -> stream B.
  (** The two streams we compare must be of the forms [f x] and [g x], for some shared [x].  Note that this falls out naturally when [x] is a shared universally quantified variable in a lemma statement. *)

  Hypothesis Cons_case_hd : forall x, hd (f x) = hd (g x).
  Hypothesis Cons_case_tl : forall x, exists y, tl (f x) = f y /\ tl (g x) = g y.
  (** These conditions are inspired by the bisimulation requirements, with a more general version of the [R] choice we made for [fact_eq'] inlined into the hypotheses of [stream_eq_coind]. *)

  Theorem stream_eq_onequant : forall x, stream_eq (f x) (g x).
    intro; apply (stream_eq_coind (fun s1 s2 => exists x, s1 = f x /\ s2 = g x)); crush; eauto.
  Qed.
End stream_eq_onequant.

Lemma fact_eq'' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  apply stream_eq_onequant; crush; eauto.
Qed.

(** We have arrived at one of our customary automated proofs, thanks to the new principle. *)
(* end thide *)

(** * Simple Modeling of Non-Terminating Programs *)

(** We close the chapter with a quick motivating example for more complex uses of co-inductive types.  We will define a co-inductive semantics for a simple imperative programming language and use that semantics to prove the correctness of a trivial optimization that removes spurious additions by 0.  We follow the technique of%\index{co-inductive big-step operational semantics}% _co-inductive big-step operational semantics_ %\cite{BigStep}%.

   We define a suggestive synonym for [nat], as we will consider programs over infinitely many variables, represented as [nat]s. *)

Definition var := nat.

(** We define a type [vars] of maps from variables to values.  To define a function [set] for setting a variable's value in a map, we use the standard library function [beq_nat] for comparing natural numbers. *)

Definition vars := var -> nat.
Definition set (vs : vars) (v : var) (n : nat) : vars :=
  fun v' => if beq_nat v v' then n else vs v'.

(** We define a simple arithmetic expression language with variables, and we give it a semantics via an interpreter. *)

Inductive exp : Set :=
| Const : nat -> exp
| Var : var -> exp
| Plus : exp -> exp -> exp.

Fixpoint evalExp (vs : vars) (e : exp) : nat :=
  match e with
    | Const n => n
    | Var v => vs v
    | Plus e1 e2 => evalExp vs e1 + evalExp vs e2
  end.

(** Finally, we define a language of commands.  It includes variable assignment, sequencing, and a <<while>> form that repeats as long as its test expression evaluates to a nonzero value. *)

Inductive cmd : Set :=
| Assign : var -> exp -> cmd
| Seq : cmd -> cmd -> cmd
| While : exp -> cmd -> cmd.

(** We could define an inductive relation to characterize the results of command evaluation.  However, such a relation would not capture _nonterminating_ executions.  With a co-inductive relation, we can capture both cases.  The parameters of the relation are an initial state, a command, and a final state.  A program that does not terminate in a particular initial state is related to _any_ final state.  For more realistic languages than this one, it is often possible for programs to _crash_, in which case a semantics would generally relate their executions to no final states; so relating safely non-terminating programs to all final states provides a crucial distinction. *)

CoInductive evalCmd : vars -> cmd -> vars -> Prop :=
| EvalAssign : forall vs v e, evalCmd vs (Assign v e) (set vs v (evalExp vs e))
| EvalSeq : forall vs1 vs2 vs3 c1 c2, evalCmd vs1 c1 vs2
  -> evalCmd vs2 c2 vs3
  -> evalCmd vs1 (Seq c1 c2) vs3
| EvalWhileFalse : forall vs e c, evalExp vs e = 0
  -> evalCmd vs (While e c) vs
| EvalWhileTrue : forall vs1 vs2 vs3 e c, evalExp vs1 e <> 0
  -> evalCmd vs1 c vs2
  -> evalCmd vs2 (While e c) vs3
  -> evalCmd vs1 (While e c) vs3.

(** Having learned our lesson in the last section, before proceeding, we build a co-induction principle for [evalCmd]. *)

Section evalCmd_coind.
  Variable R : vars -> cmd -> vars -> Prop.

  Hypothesis AssignCase : forall vs1 vs2 v e, R vs1 (Assign v e) vs2
    -> vs2 = set vs1 v (evalExp vs1 e).

  Hypothesis SeqCase : forall vs1 vs3 c1 c2, R vs1 (Seq c1 c2) vs3
    -> exists vs2, R vs1 c1 vs2 /\ R vs2 c2 vs3.

  Hypothesis WhileCase : forall vs1 vs3 e c, R vs1 (While e c) vs3
    -> (evalExp vs1 e = 0 /\ vs3 = vs1)
    \/ exists vs2, evalExp vs1 e <> 0 /\ R vs1 c vs2 /\ R vs2 (While e c) vs3.

  (** The proof is routine.  We make use of a form of %\index{tactics!destruct}%[destruct] that takes an%\index{intro pattern}% _intro pattern_ in an [as] clause.  These patterns control how deeply we break apart the components of an inductive value, and we refer the reader to the Coq manual for more details. *)

  Theorem evalCmd_coind : forall vs1 c vs2, R vs1 c vs2 -> evalCmd vs1 c vs2.
    cofix; intros; destruct c.
    rewrite (AssignCase H); constructor.
    destruct (SeqCase H) as [? [? ?]]; econstructor; eauto.
    destruct (WhileCase H) as [[? ?] | [? [? [? ?]]]]; subst; econstructor; eauto.
  Qed.
End evalCmd_coind.

(** Now that we have a co-induction principle, we should use it to prove something!  Our example is a trivial program optimizer that finds places to replace [0 + e] with [e]. *)

Fixpoint optExp (e : exp) : exp :=
  match e with
    | Plus (Const 0) e => optExp e
    | Plus e1 e2 => Plus (optExp e1) (optExp e2)
    | _ => e
  end.

Fixpoint optCmd (c : cmd) : cmd :=
  match c with
    | Assign v e => Assign v (optExp e)
    | Seq c1 c2 => Seq (optCmd c1) (optCmd c2)
    | While e c => While (optExp e) (optCmd c)
  end.

(** Before proving correctness of [optCmd], we prove a lemma about [optExp].  This is where we have to do the most work, choosing pattern match opportunities automatically. *)

(* begin thide *)
Lemma optExp_correct : forall vs e, evalExp vs (optExp e) = evalExp vs e.
  induction e; crush;
    repeat (match goal with
              | [ |- context[match ?E with Const _ => _ | _ => _ end] ] => destruct E
              | [ |- context[match ?E with O => _ | S _ => _ end] ] => destruct E
            end; crush).
Qed.

Hint Rewrite optExp_correct.

(** The final theorem is easy to establish, using our co-induction principle and a bit of Ltac smarts that we leave unexplained for now.  Curious readers can consult the Coq manual, or wait for the later chapters of this book about proof automation.  At a high level, we show inclusions between behaviors, going in both directions between original and optimized programs. *)

Ltac finisher := match goal with
                   | [ H : evalCmd _ _ _ |- _ ] => ((inversion H; [])
                     || (inversion H; [|])); subst
                 end; crush; eauto 10.

Lemma optCmd_correct1 : forall vs1 c vs2, evalCmd vs1 c vs2
  -> evalCmd vs1 (optCmd c) vs2.
  intros; apply (evalCmd_coind (fun vs1 c' vs2 => exists c, evalCmd vs1 c vs2
    /\ c' = optCmd c)); eauto; crush;
    match goal with
      | [ H : _ = optCmd ?E |- _ ] => destruct E; simpl in *; discriminate
        || injection H; intros; subst
    end; finisher.
Qed.

Lemma optCmd_correct2 : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2
  -> evalCmd vs1 c vs2.
  intros; apply (evalCmd_coind (fun vs1 c vs2 => evalCmd vs1 (optCmd c) vs2));
    crush; finisher.
Qed.

Theorem optCmd_correct : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2
  <-> evalCmd vs1 c vs2.
  intuition; apply optCmd_correct1 || apply optCmd_correct2; assumption.
Qed.
(* end thide *)

(** In this form, the theorem tells us that the optimizer preserves observable behavior of both terminating and nonterminating programs, but we did not have to do more work than for the case of terminating programs alone.  We merely took the natural inductive definition for terminating executions, made it co-inductive, and applied the appropriate co-induction principle.  Curious readers might experiment with adding command constructs like <<if>>; the same proof script should continue working, after the co-induction principle is extended to the new evaluation rules. *)


(**************************************************************)
(*   Copyright                                                *)
(*             Jean-François Monin           [+]              *)
(*             Dominique Larchey-Wendling    [*]              *)
(*                                                            *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Lia Utf8 Extraction.

(** Target : nb of g steps to get some condition b

      let rec ns x = match b x with true => 0 | false => S (ns (g x))

   Algorithm using an accumulator

      let rec nsa x n = match b x with true => n | false => nsa (g x) (S n)

   We prove that ns computes the same result as nsa

   We characterize their domains with the below iterator
         g↑n = g o g o ... o g   n times
*)

(* The iterator, tail-recursive *)

Reserved Notation "g ↑ n" (at level 1, format "g ↑ n").
Fixpoint iter {X} g n (x : X) :=
  match n with
    | 0   => x
    | S n => g↑n (g x)
  end
where "g ↑ n" := (iter g n).

(* A small tactic to eliminate goal where b = true and b = false appear as hypotheses *)

Tactic Notation "bool" "discr" :=
  try match goal with
    | H: ?a = true , G: ?b = false |- _ => exfalso; now rewrite H in G
  end.

Section ns_nsa.

Variable (X : Type) (g : X -> X) (b : X -> bool).

Unset Elimination Schemes.

Fact true_false {x} : x = true -> x = false -> False.
Proof. intros; bool discr. Qed.

(** The custom inductive domain of ns and nsa *)

(*
(* Coq knowledgeable users know that it is a better policy
   to put x as a parameter rather than an indice.
   This would allow a short-cut in projections
   as shown below in this comment,
   but this would not suit more general situations.
*)
Inductive 𝔻ns (x: X) : Prop :=
  | 𝔻ns_tt : b x = true  → 𝔻ns x
  | 𝔻ns_ff : b x = false → 𝔻ns (g x) → 𝔻ns x
  .

Definition 𝜋_𝔻ns {x} (G : b x = false) (D : 𝔻ns x) :  𝔻ns (g x) :=
  match D with
  | 𝔻ns_tt _ E     => match true_false E G with end
  | 𝔻ns_ff _ _ Dgx => Dgx
  end.
*)

(* *This definition with x as an indice corresponds to the rules of the paper *)
Inductive 𝔻ns : X -> Prop :=
  | 𝔻ns_tt : ∀x, b x = true  → 𝔻ns x
  | 𝔻ns_ff : ∀x, b x = false → 𝔻ns (g x) → 𝔻ns x
  .

(** The inversion of constructor 𝔻ns_ff *)

Definition 𝜋_𝔻ns {x} (D : 𝔻ns x) : b x = false → 𝔻ns (g x) :=
  match D with
  | 𝔻ns_tt x E     => λ G, match true_false E G with end
  | 𝔻ns_ff x E Dgx => λ G, Dgx
  end.

Set Elimination Schemes.

Section sec_direct_ns.

(** First we define ns/nsa as structural fixpoint on
    the domain predicate with a weak spec *)

(* "Let" in order to forget ns and nsa after this section *)

Let
Fixpoint ns x (D : 𝔻ns x) : nat :=
  match b x as bx return b x = bx → _ with
  | true  => λ _, 0
  | false => λ G, S (ns (g x) (𝜋_𝔻ns D G))
  end eq_refl.

(* We get fixpoints equation by simpl!! *)
Let ns_fix_tt x E : ns x (𝔻ns_tt x E) = 0.
Proof. simpl; now rewrite E. Qed.

Let ns_fix_ff x E D : ns x (𝔻ns_ff x E D) = S (ns (g x) D).
Proof. simpl; now rewrite E. Qed.

Let
Fixpoint nsa x (n : nat) (D : 𝔻ns x) : nat :=
  match b x as bx return b x = bx → _ with
  | true  => λ _, n
  | false => λ G, nsa (g x) (S n) (𝜋_𝔻ns D G)
  end eq_refl.

Let nsa_fix_tt x n E : nsa x n (𝔻ns_tt x E) = n.
Proof. simpl; now rewrite E. Qed.

Let nsa_fix_ff x n E D : nsa x n (𝔻ns_ff x E D) = nsa (g x) (S n) D.
Proof. simpl; now rewrite E. Qed.

(* We can show this identity by structural recursion on D *)

Lemma ns_nsa_n_direct : ∀x n D, nsa x n D = ns x D + n.
Proof.
  refine (fix loop x n D { struct D } := _).
  destruct D as [ x E | x E D ]; simpl.
  - now rewrite E.
  - now rewrite loop, E, <- plus_n_Sm.
Qed.

Corollary ns_nsa_direct : ∀x (D: 𝔻ns x), nsa x 0 D = ns x D.
Proof. intros; now rewrite ns_nsa_n_direct, plus_n_O. Qed.

End sec_direct_ns.

(** We build a proof-irrelevant Type bounded eliminator for 𝔻ns *)

Section eliminator_for_𝔻ns.

  Variable P : ∀x, 𝔻ns x -> Type.

  Hypothesis (HPi : ∀x D1 D2, P x D1 → P x D2)
             (HP0 : ∀x E, P _ (𝔻ns_tt x E))
             (HP1 : ∀x E D, P _ D → P _ (𝔻ns_ff x E D)).

  Fixpoint 𝔻ns_rect x D { struct D } : P x D.
  Proof.
    case_eq (b x); intros G.
    + apply HPi with (1 := HP0 _ G).
    + apply HPi with (1 := HP1 _ G _ (𝔻ns_rect _ (𝜋_𝔻ns D G))).
  Qed.

End eliminator_for_𝔻ns.

(* The computational graph of ns *)

Reserved Notation "x '⟼ns' y" (at level 70, no associativity).
Inductive 𝔾ns : X → nat → Prop :=
  | in_grns_0 x   : b x = true               → x ⟼ns 0
  | in_grns_1 x o : b x = false → g x ⟼ns o → x ⟼ns S o
where "x ⟼ns o" := (𝔾ns x o).

(* The computational graph of nsa *)

Reserved Notation "x ';' n '⟼nsa' y" (at level 70, no associativity).
Inductive 𝔾nsa : X → nat → nat → Prop :=
  | in_grnsa_0 x n   : b x = true                       →  x;n ⟼nsa n
  | in_grnsa_1 x n o : b x = false  →  g x;S n ⟼nsa o  →  x;n ⟼nsa o
where "x ; n ⟼nsa o" := (𝔾nsa x n o).

(* Both graphs are deterministic/functional *)

Fact 𝔾ns_fun x u v : x ⟼ns u  →  x ⟼ns v  →  u = v.
Proof.
  intros H; revert H v.
  induction 1; inversion 1; auto; bool discr.
Qed.

Fact 𝔾nsa_fun x n u v : x;n ⟼nsa u  →  x;n ⟼nsa v  →  u = v.
Proof.
  intros H; revert H v.
  induction 1; inversion 1; auto; bool discr.
Qed.

Section pwc.

(** First we define ns/nsa as structural fixpoint over the
    custom domain predicate but here strongly specified wrt
    their respective coputational graphs *)

Let
Fixpoint ns_pwc x (D : 𝔻ns x) : {o | x ⟼ns o}.
Proof. refine(
   match b x as bx return b x = bx → _ with
   | true  => λ G, exist _ 0 _
   | false => λ G, let (o,Co) := ns_pwc (g x) (𝜋_𝔻ns D G)
                   in exist _ (S o) _
   end eq_refl).
  + now constructor.
  + now constructor.
Qed.

Definition ns (x: X) D : nat := proj1_sig (ns_pwc x D).

Fact ns_spec x D : x ⟼ns ns x D.
Proof. apply (proj2_sig _). Qed.

Let Fixpoint nsa_pwc x n (D: 𝔻ns x) : {o | x;n ⟼nsa o}.
Proof. refine(
   match b x as bx return b x = bx → _ with
   | true =>  λ G, exist _ n _
   | false => λ G, let (o,Co) := nsa_pwc (g x) (S n) (𝜋_𝔻ns D G)
                   in exist _ o _
   end eq_refl).
  + now constructor.
  + now constructor.
Qed.

Definition nsa (x: X) (n: nat) D : nat := proj1_sig (nsa_pwc x n D).

Fact nsa_spec x n D : x;n ⟼nsa nsa x n D.
Proof. apply (proj2_sig _). Qed.

End pwc.

(* 𝔻ns cover all values where there is a possible output for ns *)

Fact ns_complete x : 𝔻ns x ↔ exists o, x ⟼ns o.
Proof.
  split.
  + intros D; exists (ns _ D); apply ns_spec.
  + intros (o & Co); revert Co.
    induction 1.
    * now constructor 1.
    * now constructor 2.
Qed.

Fact ns_pirr {x} D1 D2 : ns x D1 = ns x D2.
Proof. apply (𝔾ns_fun x); apply ns_spec. Qed.

Fact ns_fix_tt x E : ns x (𝔻ns_tt x E) = 0.
Proof. apply 𝔾ns_fun with (1 := ns_spec _ _); now constructor. Qed.

Fact ns_fix_ff x E D : ns x (𝔻ns_ff x E D) = S (ns (g x) D).
Proof. apply 𝔾ns_fun with (1 := ns_spec _ _); constructor; auto; apply ns_spec. Qed.

(* (λ x _, 𝔻ns x) cover all values where there is a possible output for nsa *)

Fact nsa_complete x n : 𝔻ns x ↔ exists o, x;n ⟼nsa o.
Proof.
  split.
  + intros D; exists (nsa _ n D); apply nsa_spec.
  + intros (o & Co); revert Co.
    induction 1.
    * now constructor 1.
    * now constructor 2.
Qed.

Fact nsa_pirr {x n} D1 D2 : nsa x n D1 = nsa x n D2.
Proof. apply (𝔾nsa_fun x n); apply nsa_spec. Qed.

Fact nsa_fix_tt x n E : nsa x n (𝔻ns_tt x E) = n.
Proof. apply 𝔾nsa_fun with (1 := nsa_spec _ _ _); now constructor. Qed.

Fact nsa_fix_ff x n E D : nsa x n (𝔻ns_ff x E D) = nsa (g x) (S n) D.
Proof. apply 𝔾nsa_fun with (1 := nsa_spec _ _ _); constructor; auto; apply nsa_spec. Qed.

(* Identity by proof-irrelevant dependent induction on D *)

Lemma nsa_ns_n x D : ∀n, nsa x n D = ns x D + n.
Proof.
  induction D as [ x D1 D2 | x E | x E D IH] using 𝔻ns_rect; intro n; simpl.
  + now rewrite (nsa_pirr _ D1), (ns_pirr _ D1).
  + now rewrite nsa_fix_tt, ns_fix_tt.
  + now rewrite nsa_fix_ff, ns_fix_ff, IH, <- plus_n_Sm.
Qed.

Corollary ns_nsa : ∀x (D: 𝔻ns x), nsa x 0 D = ns x D.
Proof. intros; now rewrite nsa_ns_n, plus_n_O. Qed.

(* Variant 1, by induction on the graph 𝔾ns *)

Lemma nsa_ns_n_𝔾ns : ∀x (D : 𝔻ns x) n, nsa x n D = ns x D + n.
Proof.
  intros x D n.
  generalize (ns x D) (ns_spec x D).
  intros o H; revert H n D.
  induction 1; intros n D; destruct D; bool discr.
  + now rewrite nsa_fix_tt.
  + now rewrite nsa_fix_ff, plus_Snm_nSm.
Qed.

(* Variant 2, by induction on the graph 𝔾nsa *)

Lemma nsa_ns_n_𝔾nsa : ∀x (D : 𝔻ns x) n, nsa x n D = ns x D + n.
Proof.
  intros x D n.
  generalize (nsa x n D) (nsa_spec x n D).
  intros o H; revert H D.
  induction 1; intros D; destruct D; bool discr.
  + now rewrite ns_fix_tt.
  + now rewrite ns_fix_ff, plus_Snm_nSm.
Qed.

Section termination.

(** m is the first nat such that b (g↑m x) = true *)

Definition is_first x m :=
       b (g↑m x) = true
     ∧ forall k, k < m → b (g↑k x) = false.

Theorem ns_partially_correct x D : is_first x (ns x D).
Proof.
  generalize x (ns _ D) (ns_spec _ D); clear x D.
  induction 1 as [ x Ex | x u Ex _ [ H1 H2 ] ].
  + split; auto; intros; lia.
  + split; auto.
    intros [] ?; auto; apply H2; lia.
Qed.

(** m is the first nat above b such that b (g↑(m-n) x) = true *)

Definition is_first_above x n m :=
      n ≤ m
    ∧ b (g↑(m-n) x) = true
    ∧ ∀k, k+n < m → b (g↑k x) = false.

Theorem nsa_partially_correct x n D : is_first_above x n (nsa x n D).
Proof.
  revert n; induction D as [ x D1 D2 | x E | x E D IH ] using 𝔻ns_rect; intros n.
  + now rewrite (nsa_pirr _ D1).
  + rewrite nsa_fix_tt; split; [ | split ]; auto.
    * replace (n-n) with 0 by lia; auto.
    * intros; lia.
  + destruct (IH (S n)) as (H1 & H2 & H3).
    rewrite nsa_fix_ff; split; [ | split ]; try lia.
    * now replace (nsa _ (S n) D-n) with (S (nsa _ (S n) D - S n)) by lia.
    * intros [] ?; auto; apply H3; lia.
Qed.

(* find first under a given informative bounded *)

Theorem first_under_bound x n : b (g↑n x) = true → ∃m, is_first x m.
Proof.
  revert x; induction n as [ | n IHn ]; intros x Hx.
  + exists 0; split; auto; intros; lia.
  + case_eq (b x); intros H.
    * exists 0; split; auto; intros; lia.
    * destruct IHn with (1 := Hx) as (m & H1 & H2).
      exists (S m); split; auto.
      intros [] ?; auto; apply H2; lia.
Qed.

(* Domain of both ns and nsa:

          ns x and ns x n terminate
      iff there is k s.t. b (g↑k x) = true
*)

Theorem 𝔻ns_high_level x : 𝔻ns x ↔ ∃k, b (g↑k x) = true.
Proof.
  split.
  + intros D; exists (ns _ D); apply ns_partially_correct.
  + intros (n & Hn).
    destruct first_under_bound with (1 := Hn) as (m & Hm).
    clear n Hn; revert m x Hm.
    induction m as [ | n IHn ]; intros x (H1 & H2).
    * constructor 1; apply H1.
    * constructor 2.
      - apply (H2 0); lia.
      - apply IHn; split; auto.
        intros; apply (H2 (S _)); lia.
Qed.

End termination.

End ns_nsa.

Extract Inductive bool => "bool" [ "true" "false" ].

Recursive Extraction ns nsa.


(*
 * Formal specification of signals defined over set of Allen's intervals
 * Essentials lemmas
 * Proofs of equivalences between some basic signal functions
 *
 * Bernard P. Serpette
 * Nic Volanschi
 *)
Set Implicit Arguments.
Unset Strict Implicit.

Require Import basics.
Require Import enat.
Require Import allen.
Require Import signal.
Require Import compare.
Require Import include.
Require Import borders.
Require Import extend.
Require Import allenfuns.

Section spec.

Ltac G x := generalize x.

Ltac BAD := intros BAD; inversion BAD.

(*
 * Equivalences
 *)

(*
 * DN
 *)
Definition dn_new (p:sig) := (and_sig (not_sig p) (delay 1 p)).

Lemma dn_equiv_l (p:sig) : (inc_sig (dn p) (dn_new p)).
intros t (I,(Right,IInp)).
G (previous_right (eq_sym Right)). intros (pt,T). rewrite T in *. clear T t.
- split;[|split].
  + apply (bounded_right_out IInp (eq_sym Right)).
  + apply (le_succ (le_0 pt)).
  + replace (S pt - 1) with pt; auto with arith.
    apply (in_sig_slice IInp (t:=pt)).
    G (wf I); rewrite <- Right.
    split; [auto with arith|].
    rewrite <- Right; simpl; auto with arith.
Qed.

Lemma dn_equiv_r (p:sig) : (inc_sig (dn_new p) (dn p)).
intros t (NOT,(SUP1,ISUB)).
G (gt0_has_previous SUP1). intros (pt,T). rewrite T in *. clear T SUP1 t.
replace (S pt - 1) with pt in ISUB; [|auto with arith].
generalize (down_allen_left ISUB NOT); intros (I,(IN,RIGHT)).
exists I; auto.
Qed.

Lemma dn_equiv (p:sig) : (eq_sig (dn p) (dn_new p)).
apply inc_sig_asym;[apply dn_equiv_l|apply dn_equiv_r].
Qed.

(*
 * UP
 *)
Definition up_new (p:sig) := (dn (not_sig p)).

Lemma up_equiv_l (p:sig) : (inc_sig (up p) (up_new p)).
intros t (W,(I,(EQL,(Left,(Right,Slice))))).
G (gt0_has_previous W). intros (pt,T). rewrite T in *; clear T W t.
rewrite <- EQL in Left.
cut (p (S pt)).
- intros PS.
  generalize (up_allen_left Left PS); intros (I',(EQR,IN)).
  exists I'; auto.
- apply Slice; split.
  + rewrite EQL; auto.
  + G (wf I); rewrite EQL; auto.
Qed.

Lemma up_equiv_r (p:sig) : (inc_sig (up_new p) (up p)).
intros t (I,(EQR,(LEFT,(RIGHT,SLICE)))).
G (previous_right (eq_sym EQR)). intros (pt,T). rewrite T in *. clear T t.
apply up_succ.
- apply SLICE.
  split.
  + G (wf I). rewrite <- EQR. auto with arith.
  + rewrite <- EQR. simpl; auto.
- rewrite <- EQR in RIGHT.
  rewrite <- not_not_sig_def; auto.
Qed.

Lemma up_equiv (p:sig) : (eq_sig (up p) (up_new p)).
apply inc_sig_asym;[apply up_equiv_l|apply up_equiv_r].
Qed.

(*
 * MET
 *)
Definition met_new (p q:sig) := (occurs (and_sig (dn q) (up p)) p).

Lemma met_equiv_l (p q:sig) : (inc_sig (met p q) (met_new p q)).
intros t (I,(tIp,(J,(JInq,EQ)))).
unfold MetBy in EQ.
exists I. split;[auto|].
exists (left I). split;[apply in_allen_left|].
split.
- exists J; auto.
- split.
  + G (in_sig_fixl_gt0 J). rewrite <- EQ; auto.
  + exists I. split;[auto|apply (tas_sig tIp)].
Qed.

Lemma met_equiv_r (p q:sig) : (inc_sig (met_new p q) (met p q)).
intros t (I,(tIp,(t',(t'InI,((J,(EQR,JInq)),(LT,(II,(EL,IIInp)))))))).
rewrite EL in *; clear EL.
exists I. split;[auto|].
exists J. split;[auto|].
unfold MetBy. rewrite <- EQR.
rewrite (tas_uniq_left (tas_mov tIp t'InI) (in_sig_tas_left IIInp)).
auto.
Qed.

Lemma met_equiv (p q:sig) : (eq_sig (met p q) (met_new p q)).
apply inc_sig_asym;[apply met_equiv_l|apply met_equiv_r].
Qed.

(*
 * OCCURS
 *)
Definition occurs_new (p q:sig) := (and_sig q (not_sig (holds (not_sig p) q))).

Lemma occurs_equiv_l (p q:sig) : (inc_sig (occurs p q) (occurs_new p q)).
intros t (I,(tIq,(t',(t'InI,Pt')))).
split.
- apply (tas_p tIq); auto.
- apply all_not_not_ex; intros J (tJq,F).
  apply (F t' (in_sig_inc_allen tIq tJq t'InI) Pt').
Qed.

Lemma occurs_equiv_r (p q:sig) : (inc_sig (occurs_new p q) (occurs p q)).
intros t (Qt,NEX).
G (get_sig Qt); intros (I,tIq).
exists I.
split;[auto|].
G (not_and_or _ _ (not_ex_all_not allen _ NEX I)). intros [O1|O2].
- exfalso; auto.
- G (not_all_ex_not _ _ O2); intros (t',P).
  G (not_imply_and P). rewrite not_not_sig_def. exists t'; auto.
Qed.

Lemma occurs_equiv (p q:sig) : (eq_sig (occurs p q) (occurs_new p q)).
apply inc_sig_asym;[apply occurs_equiv_l|apply occurs_equiv_r].
Qed.

(*
 * INIT
 *)
Definition init_new (p:sig) := (and_sig p (not_sig (met p (not_sig p)))).

Lemma init_equiv_l (p:sig) : (inc_sig (init p) (init_new p)).
intros t (I,(tIp,LI)).
split.
- apply (tas_p tIp).
- intros (K,(tKp,(L,(LInp,MET)))).
  G (allen_right_gt0 L).
  rewrite <- MET, <- (tas_uniq_left tIp tKp), LI.
  apply lt_irrefl.
Qed.

Lemma init_equiv_r (p:sig) : (inc_sig (init_new p) (init p)).
intros t (Pt,NM).
G (get_sig Pt). intros (I,tIp).
exists I. split;[auto|].
G NM. apply contra. rewrite not_sig_def, not_not.
intros LI. G (not0 LI). clear LI. intros (n,LI).
exists I. split;[auto|].
G (previous_left_out (tas_sig tIp) LI). intros NOTF.
G (in_left (tas_sig tIp)). rewrite LI. intros F.
G (up_allen_left NOTF F). intros (J,(JInNotp,Met)).
exists J. split;[auto|].
unfold MetBy. rewrite LI; auto.
Qed.

Lemma init_equiv (p:sig) : (eq_sig (init p) (init_new p)).
apply inc_sig_asym;[apply init_equiv_l|apply init_equiv_r].
Qed.

(*
 * FINAL
 *)
Definition final_new (p:sig) := (occurs (holds p (delay 1 p)) p).

Lemma final_equiv_l (p:sig) : (inc_sig (final p) (final_new p)).
intros t (I,(tIp,RI)).
exists I. split;[auto|].
exists (S (left I)). split;[|].
- split;[auto|rewrite RI;simpl;auto].
- cut (ilt (Fix (S (left I))) Inf);[intros WF|simpl;auto].
  exists (make_allen (m:=(S (left I))) (M:=Inf) WF).
  split;[split|].
  + split; auto.
  + G (in_sig_close_in_sig_delay 1 (tas_sig tIp)).
    apply eq_allen_in_sig.
    split; simpl; auto.
    rewrite RI; auto.
  + intros t' (LEFT,_). simpl in LEFT.
    apply (in_sig_slice (tas_sig tIp) (t:=t')).
    split;[|rewrite RI;simpl;auto].
    G LEFT; apply le_trans; auto.
Qed.

Lemma final_equiv_r (p:sig) : (inc_sig (final_new p) (final p)).
intros t (I,(tIp,(tt,(ttInI,(J,(ttJDY,SLI)))))).
exists I. split;[auto|].
apply contra_inf.
intros (t',RI).
G (bounded_right_out (tas_sig tIp) RI).
apply not_not.
apply SLI.
G (in_sig_close_in_sig_delay 1 (tas_sig tIp)). intros MAInDY.
apply (eq_allen_in_allen (I:=(make_allen (m:=1+left I) (M:=(fiadd 1 (right I))) (wf_shift 1 I)))).
- G (in_sig_delay1_eq_sig (tas_def ttInI (tas_sig tIp)) ttJDY).
  apply eq_allen_sym.
- apply in_allen_previous_right.
  simpl; rewrite RI; auto.
Qed.

Lemma final_equiv (p:sig) : (eq_sig (final p) (final_new p)).
apply inc_sig_asym;[apply final_equiv_l|apply final_equiv_r].
Qed.

(*
 * EQ
 *)
Definition eq_new (p q:sig) := (and_sig (holds p q) (holds q p)).

Lemma eq_equiv_l (p q:sig) : (inc_sig (eq p q) (eq_new p q)).
intros t ext. G (ext_inc ext Eq_inc). intros (I,(tIp,(J,(tJq,EQ)))). clear ext.
split.
- exists J. split;[auto|].
  intros t' t'InJ.
  apply (tas_p (tas_def t'InJ (eq_allen_in_sig EQ (tas_sig tIp)))).
- exists I. split;[auto|].
  intros t' t'InI.
  apply (tas_p (tas_def (eq_allen_in_allen EQ t'InI) (tas_sig tJq))).
Qed.

Lemma eq_equiv_r (p q:sig) : (inc_sig (eq_new p q) (eq p q)).
intros t ((J,(tJq,SLJp)),(I,(tIp,SLIq))).
exists I. split;[auto|].
exists J. split;[(apply (tas_sig tJq))|].
G (in_allen_in_sig_slice__inc_allen2 (tas_allen tJq) tIp SLJp).
G (in_allen_in_sig_slice__inc_allen2 (tas_allen tIp) tJq SLIq).
apply inc_allen_asym.
Qed.

Lemma eq_equiv (p q:sig) : (eq_sig (eq p q) (eq_new p q)).
apply inc_sig_asym;[apply eq_equiv_l|apply eq_equiv_r].
Qed.

(*
 * OVER
 *)
Definition over_new (p q:sig) :=
  (and_sig (occurs (not_sig p) (occurs_up q p))
           (occurs (up_after p q) (and_sig p q)) ).

Lemma over_over_new_left (p q:sig) :
 (inc_sig (over p q) (occurs (not_sig p) (occurs_up q p))).
intros t (I,(tIp,(J,(tJq,(LIJ,RIJ))))).
G tIp; intros (tInI,IInp). G tJq; intros (tInJ,JInq).
G (allen_has_intersection tInJ tInI); intros LIRJ.
exists J. split;[|].
- apply (overlaps_occurs_up tIp tJq LIJ RIJ).
- G (ilt_left_is_fix RIJ); intros (r,RI). exists r.
  split.
  + split.
    * rewrite RI in LIRJ; simpl in LIRJ; apply (lt_le LIRJ).
    * rewrite <- RI; auto.
  + apply (bounded_right_out IInp RI).
Qed.

Lemma over_over_new_right (p q:sig) :
  (inc_sig (over p q) (occurs (up_after p q) (and_sig p q))).
intros t (I,(tIp,(J,(tJq,(LIJ,RIJ))))).
G (tas_has_intersection tJq tIp); intros WF.
exists (make_allen (m:=(left J)) (M:=(right I)) WF).
split.
  + apply (over_over_new_right_left WF tIp tJq LIJ RIJ).
  + exists (left J); split;[split;[auto|auto]|].
    apply (overlaps_up_after_left tIp tJq LIJ RIJ WF).
Qed.

Lemma over_equiv_l (p q:sig) : (inc_sig (over p q) (over_new p q)).
intros t OVR.
split.
- apply (over_over_new_left OVR).
- apply (over_over_new_right OVR).
Qed.

Lemma over_equiv_r (p q:sig) : (inc_sig (over_new p q) (over p q)).
intros t ((I,(tIO,(t',(t'InI,NPt')))),(J,(tJA,(u',(u'InJ,NPu'))))).
G (get_sig (and_left (tas_p tJA))). intros (K, tKp).
G tIO; intros (tInI,IInO).
G tJA; intros (tInJ,JInA).
G tKp; intros (tInK,KInp).
exists K. split;[auto|].
exists I. split;[|split].
- apply (tas_filter_tas_arg tIO).
- apply (occurs_up_after_on_left tIO tJA tKp u'InJ NPu').
- apply (on_right_before (tas_on tKp) t'InI NPt').
  apply lt_le.
  apply (occurs_up_after_on_left tIO tJA tKp u'InJ NPu').
Qed.

Lemma over_equiv (p q:sig) : (eq_sig (over p q) (over_new p q)).
apply inc_sig_asym;[apply over_equiv_l|apply over_equiv_r].
Qed.

(*
 * OVERLAPPED
 *)
Definition overlapped_new (p q:sig) := (occurs (over q p) p).

Lemma overlapped_equiv_l (p q:sig) :
 (inc_sig (overlapped p q) (overlapped_new p q)).
intros t (I,(tIp,(J,(JInQ,(LT_LL,(LT_LR,LT_RR)))))).
exists I. split;[auto|].
exists (left I). split;[apply in_allen_left|].
exists J. split;[split;[|auto]|].
  + split;[apply (lt_le LT_LL)|auto].
  + exists I. split;[apply (tas_left tIp)|split;auto].
Qed.

Lemma overlapped_equiv_r (p q:sig) :
 (inc_sig (overlapped_new p q) (overlapped p q)).
intros t (I,(tIp,(t',(t'InI,(J,(t'Jq,(K,(t'Kp,(LTLL,LTRR))))))))).
exists I. split;[auto|].
exists J. split;[apply (tas_sig t'Jq)|split;[|split]].
- rewrite (tas_uniq_left (tas_mov tIp t'InI) t'Kp); auto.
- apply (allen_has_intersection t'InI (tas_allen t'Jq)).
- rewrite (tas_uniq_right (tas_mov tIp t'InI) t'Kp); auto.
Qed.

Lemma overlapped_equiv (p q:sig) :
 (eq_sig (overlapped p q) (overlapped_new p q)).
apply inc_sig_asym;[apply overlapped_equiv_l|apply overlapped_equiv_r].
Qed.

(*
 * OVERLAPS
 *)
Definition overlaps_new (p q:sig) := (occurs (over p q) p).

Lemma overlaps_equiv_l (p q:sig) : (inc_sig (overlaps p q) (overlaps_new p q)).
intros t (I,(tIp,(J,(JInQ,(LT_LL,(LT_LR,LT_RR)))))).
exists I. split;[auto|].
exists (left J). split;[split;[apply (lt_le LT_LL)|auto]|].
exists I. split;[split;[split;[|]|apply (tas_sig tIp)]|];auto.
- apply (lt_le LT_LL).
- exists J. split;[apply (in_sig_tas_left JInQ)|auto].
Qed.

Lemma overlaps_equiv_r (p q:sig) : (inc_sig (overlaps_new p q) (overlaps p q)).
intros t (I,(tIp,(t',(t'InI,(J,(t'Jp,(K,(t'Kq,(LTLL,LTRR))))))))).
exists I. split;[auto|].
exists K. split;[apply (tas_sig t'Kq)|split;[|split]].
- rewrite (tas_uniq_left (tas_mov tIp t'InI) t'Jp); auto.
- apply (allen_has_intersection (tas_allen t'Kq) t'InI).
- rewrite (tas_uniq_right (tas_mov tIp t'InI) t'Jp); auto.
Qed.

Lemma overlaps_equiv (p q:sig) : (eq_sig (overlaps p q) (overlaps_new p q)).
apply inc_sig_asym;[apply overlaps_equiv_l|apply overlaps_equiv_r].
Qed.

(*
 * STARTS
 *)
Definition starts_new (p q:sig) :=
 (or_sig (and_sig (occurs (sync p q) p)
                  (occurs (not_sig p) (occurs (sync p q) q)) )
         (and_sig (and_sig (init p) (init q))
                  (occurs (not_sig p) q) )).

Lemma starts_equiv_l (p q:sig) : (inc_sig (starts p q) (starts_new p q)).
intros t (I,(tIp,(J,(JInq,STR)))).
G STR; intros (LL,RR).
G (tas_inc_tas tIp JInq (Starts_inc STR)); intros tJq.
case_eq (left I);[intros Z;right|intros li LI;left].
- split;[split;[|]|].
  + exists I. auto.
  + exists J. split;[auto|rewrite <- LL;auto].
  + exists J. split;[auto|].
    apply(ilt_right_down_point tIp tJq RR).
- split.
  + exists I. split;[auto|].
    exists (left I). split;[apply (in_allen_left I)|].
    apply (sync_left tIp tJq LL LI).
  + exists J. split;[|].
    * apply (filter_tas tJq).
      exists (left J). split;[apply in_allen_left|].
      rewrite <- LL.
      apply (sync_left tIp tJq LL LI).
    * apply(ilt_right_down_point tIp tJq RR).
Qed.

Lemma starts_new_left_starts (p q:sig) :
 (inc_sig (and_sig (occurs (sync p q) p)
                   (occurs (not_sig p) (occurs (sync p q) q)) )
          (starts p q) ).
intros t ((I,(tIp,(t1,(t1InI,SY)))),(J,(tJO,(t2,(t2InJ,Np2))))).
G (inc_sig_allen_filter (tas_sig tJO)); intros JInq.
exists I. split;[auto|].
exists J;split;[auto|].
G (sync_shared_left__starts tIp tJO t1InI SY); intros LE.
split;[auto|].
apply (on_right_before (tas_on tIp) t2InJ Np2 (eq_le LE)).
Qed.

Lemma starts_new_right_starts (p q:sig) :
 (inc_sig (and_sig (and_sig (init p) (init q)) (occurs (not_sig p) q))
          (starts p q) ).
intros t (((I,(tIp,LI)),(J,(tJq,LJ))),OCN).
exists I. split;[auto|].
exists J. split;[apply (tas_sig tJq)|split].
- rewrite LI; auto.
- apply (occurs_not_right tIp tJq OCN).
  rewrite LI, LJ; auto.
Qed.

Lemma starts_equiv_r (p q:sig) : (inc_sig (starts_new p q) (starts p q)).
intros t [LE|RI].
- apply (starts_new_left_starts LE).
-  apply (starts_new_right_starts RI).
Qed.

Lemma starts_equiv (p q:sig) : (eq_sig (starts p q) (starts_new p q)).
apply inc_sig_asym;[apply starts_equiv_l|apply starts_equiv_r].
Qed.

(*
 * STARTED : started(p,q) = occurs(starts(q,p),p)
 *)

Definition started_new (p q:sig) := (occurs (starts q p) p).

Lemma started_equiv_l (p q:sig) : (inc_sig (started p q) (started_new p q)).
intros t (I,(tIp,(J,(JInQ,STR)))).
exists I. split;[auto|].
exists (left I); split;[apply in_allen_left|].
exists J. split;[split;[rewrite (proj1 STR); apply in_allen_left|auto]|].
exists I. split;[apply (tas_sig tIp)|apply (startedBy_Starts STR)].
Qed.

Lemma started_equiv_r (p q:sig) : (inc_sig (started_new p q) (started p q)).
intros t (I,((tInI,IInp),(t',(t'InI,(J,((t'InJ,JInq),(K,(KInp,(LL,LTRR))))))))).
G (in_allen_by_include_right t'InJ LL LTRR); intros t'InK.
exists I;split;[split;auto|].
exists J;split;[auto|split;[auto|]].
- rewrite (tas_uniq_left (tas_def t'InI IInp) (tas_def t'InK KInp)); auto.
- rewrite (tas_uniq_right (tas_def t'InI IInp) (tas_def t'InK KInp)); auto.
Qed.

Lemma started_equiv (p q:sig) : (eq_sig (started p q) (started_new p q)).
apply inc_sig_asym;[apply started_equiv_l|apply started_equiv_r].
Qed.

(*
 * ENDS
 *)
Definition ends_new (p q:sig) :=
 (or_sig (and_sig (over q (imp_sig q p)) (not_sig (over q p)))
         (and_sig (final p) (and_sig (final q) (occurs (not_sig p) q))) ).

Lemma ends_equiv_l (p q:sig) : (inc_sig (ends p q) (ends_new p q)).
intros t (I,(tIp,(J,(JInq,ENDS)))).
G (tas_inc_tas tIp JInq (Ends_inc ENDS)). intros tJq.
G ENDS; intros (LL,RR).
case_eq (right I);[intros ri RI;left;split|intros RI; right;split;[|split]].
- apply (ends_fix_over tIp tJq LL RR RI).
- intros (K,((tInK,KInq),(L,((tInL,LInp),(_,RRKL))))).
  G RRKL.
  rewrite <- (tas_uniq_right tIp (tas_def tInL LInp)).
  rewrite <- (tas_uniq_right tJq (tas_def tInK KInq)).
  rewrite RR.
  apply ilt_irrefl.
- exists I. auto.
- rewrite RR in RI; exists J. split;[auto|auto].
- exists J. split;[auto|].
  case_eq (left I).
  + intros LI; exfalso; apply (lt_eq0_false LL LI).
  + intros pli LI.
    exists pli. split;[split|].
    * rewrite LI in LL.
      rewrite <- ltS__le; auto.
    * rewrite <- RR.
      G (wf I); rewrite LI.
      apply ilt_trans; simpl; auto with arith.
    * apply (previous_left_out (tas_sig tIp) LI).
Qed.

Lemma ends_new_left_ends (p q:sig) :
 (inc_sig (and_sig (over q (imp_sig q p)) (not_sig (over q p)))
          (ends p q) ).
intros t ((J,(tJq,(I,(tIO,(LL,RR))))),NOV).
cut (p t).
- intros Pt.
  G (get_sig Pt).
  intros (K,tKp).
  exists K. split;[auto|].
  exists J. split;[apply (tas_sig tJq)|split].
  + apply (in_sig_imply_left tJq tKp tIO LL).
  + G NOV. apply contra. rewrite not_sig_def, not_not.
    intros DIFF.
    exists J. split;[auto|].
    exists K. split;[auto|split].
    * apply (in_sig_imply_left tJq tKp tIO LL).
    * G (in_sig_imply_right tJq tKp tIO RR).
      apply (diff_ile_ilt DIFF).
- apply (or_sig_exclude_left (tas_p tIO)).
  rewrite not_sig_def, not_sig_def, not_not.
  apply (tas_p tJq).
Qed.

Lemma ends_new_right_ends (p q:sig) :
 (inc_sig (and_sig (final p) (and_sig (final q) (occurs (not_sig p) q)))
          (ends p q) ).
intros t ((I,(tIp,RI)),((J,(tJq,RJ)),
                                (JJ,(tJJq,(ot,(otInJJ,NPot)))))).
- exists I. split;[auto|].
  exists J. split;[apply (tas_sig tJq)|split;[|]].
  + G (eq_allen_in_allen (tas_uniq tJJq tJq) otInJJ). intros otInJ.
    G (nat_compare_le_lt (left I) (left J));intros [LE|GT]; [exfalso|auto].
    G (on_right_before (tas_on tIp) otInJ NPot LE).
    rewrite RI, RJ; auto.
  + rewrite RI, RJ; auto.
Qed.

Lemma ends_equiv_r (p q:sig) : (inc_sig (ends_new p q) (ends p q)).
intros t [LE|RI].
- apply (ends_new_left_ends LE).
- apply (ends_new_right_ends RI).
Qed.

Lemma ends_equiv (p q:sig) : (eq_sig (ends p q) (ends_new p q)).
apply inc_sig_asym;[apply ends_equiv_l|apply ends_equiv_r].
Qed.

(*
 * ENDED
 *)
Definition ended_new (p q:sig) := (occurs (ends q p) p).

Lemma ended_equiv_l (p q:sig) : (inc_sig (ended p q) (ended_new p q)).
intros t (I,(tIp,(J,(JInQ,EDB)))).
G EDB; intros (LTLL,RR).
exists I. split;[auto|].
exists (left J). split;[|].
- apply (inc_allen_has_left ((EndedBy_inc) EDB)).
- exists J. split;[split;[apply in_allen_left|auto]|].
  exists I. split;[apply (tas_sig tIp)|split;auto].
Qed.

Lemma ended_equiv_r (p q:sig) : (inc_sig (ended_new p q) (ended p q)).
intros t (I,((tInI,IInp),(t',(t'InI,(J,((t'InJ,JInq),(K,(KInp,(LTLL,RR))))))))).
G (in_allen_by_include_left t'InJ LTLL RR); intros t'InK.
exists I. split;[split;auto|].
exists J. split;[auto|split;[auto|]].
- rewrite (tas_uniq_left (tas_def t'InI IInp) (tas_def t'InK KInp)); auto.
- rewrite (tas_uniq_right (tas_def t'InI IInp) (tas_def t'InK KInp)); auto.
Qed.

Lemma ended_equiv (p q:sig) : (eq_sig (ended p q) (ended_new p q)).
apply inc_sig_asym;[apply ended_equiv_l|apply ended_equiv_r].
Qed.

(*
 * MEETS
 *)
Definition meets_new (p q:sig) :=
  (and_sig (not_sig (final p))
           (or_sig (ends p (not_sig q))
                   (or_sig (eq p (not_sig q)) (ended p (not_sig q))) )).

Lemma meets_equiv_l (p q:sig) : (inc_sig (meets p q) (meets_new p q)).
intros t (I,(tIp,(J,(JInQ,IJ)))).
G IJ; unfold Meets.
case_eq (right I);[intros ri RI|intros RI;BAD].
rewrite eq_fix; intros LJ.
G (previous_right RI); intros (pr,PR). rewrite PR in LJ.
G (previous_left_out JInQ (eq_sym LJ)). rewrite <- not_sig_def. intros NQpr.
G (get_sig NQpr); intros (K,(prInK,KInNq)).
split.
- intros (II,(tIIp,RII)).
  rewrite (tas_uniq_right tIp tIIp) in RI.
  rewrite RI in RII.
  inversion RII.
- cut ((right I)=(right K)).
  + G (nat_compare (left I) (left K)). intros [LT|[EQ|GT]].
    * right; right.
      exists I. split;[|exists K; split;[|split]];auto.
    * right; left.
      exists I. split;[|exists K; split;[|split]];auto.
    * left.
      exists I. split;[|exists K; split;[|split]];auto.
  + rewrite RI, PR, LJ.
    rewrite <- (not_sig_follow (p:=(not_sig q)) (I:=K) (J:=J) (pr:=pr)); auto.
    rewrite (eq_sig__in_sig J (eq_sig_not_not q)); auto.
Qed.

Lemma meets_equiv_r (p q:sig) : (inc_sig (meets_new p q) (meets p q)).
intros t (NotF,
         [(I,(tIp,(J,(JInNq,(LI,RI)))))|
         [(I,(tIp,(J,(JInNq,(LI,RI)))))|
          (I,(tIp,(J,(JInNq,(LI,RI)))))]]);
apply (meets_by_end tIp JInNq RI NotF).
Qed.

Lemma meets_equiv (p q:sig) : (eq_sig (meets p q) (meets_new p q)).
apply inc_sig_asym;[apply meets_equiv_l|apply meets_equiv_r].
Qed.

(*
 * DURING
 *)
Definition during_new (p q:sig) :=
 (and_sig (occurs_up p q)
          (and_sig (not_sig (occurs (not_sig q) (occurs_up p q)))
                   (not_sig (ends p q)) )).

Lemma during_occup (p q:sig) (t:nat) :
 (during p q t) ->
 (occurs_up p q t).
intros (I,(tIp,(J,(JInq,DRG)))).
exists I. split;[auto|].
G (During_in_allen_left DRG). intros LIInJ.
exists (left I). split;[apply in_allen_left|].
split.
 - G tIp; intros (_,IInp).
   split;[apply (lt_0lt (proj1 DRG))|exists I; auto].
 - split.
   + apply (in_sig_slice JInq LIInJ).
   + intros (_,(JJ,(LL,JJInq))).
     G (proj1 DRG). rewrite LL.
     apply (tas_uniq_left_wrong (tas_def LIInJ JInq)).
     rewrite LL; apply (in_sig_tas_left JJInq).
Qed.

Lemma during_Noccocc (p q:sig) :
 (inc_sig (during p q)
          (not_sig (occurs (not_sig q) (occurs_up p q))) ).
intros t (I,(tIp,(J,(JInq,DRG)))).
intros (K,((tInK,KInOU),(tt,(ttInK,NotQtt)))).
G NotQtt. apply not_not.
apply (tas_p (I:=J) (p:=q)).
split;[|auto].
apply (inc_allen_in_allen (I:=I)).
- apply (During_inc_allen DRG).
- G ttInK; apply eq_allen_in_allen.
  apply eq_allen_sym.
  apply (tas_uniq tIp).
  split;[auto|].
  apply ((inc_sig_allen_occurs_up (p:=p) (q:=q)) _ KInOU).
Qed.

Lemma during_Nends (p q:sig) : (inc_sig (during p q) (not_sig (ends p q))).
intros t Drg Ends. G Ends. G Drg.
apply (contra_extend ends_safe During_inc Ends_inc).
intros I J (LL1,RR1) (LL2,RR2).
G RR1. apply tilde; rewrite <- ile__not_ilt.
right; auto.
Qed.

Lemma during_equiv_l (p q:sig) : (inc_sig (during p q) (during_new p q)).
intros t drg.
split;[|split;[|]].
- apply (during_occup drg).
- apply (during_Noccocc drg).
- apply (during_Nends drg).
Qed.

Lemma during_equiv_r (p q:sig) : (inc_sig (during_new p q) (during p q)).
intros t.
intros ((I,(tIp,(tt,(ttI,((GT0,(II,(LI,IIp))),(Qtt,NUPQtt)))))),(NOCC,NENDS)).
rewrite LI in *. clear LI tt.
exists I. split;[assumption|].
G (get_sig Qtt). intros (J,ttJq). clear Qtt.
exists J. split;[apply (tas_sig ttJq)|].
rewrite <- (tas_uniq_left (tas_def ttI (tas_sig tIp))
                          (in_sig_tas_left IIp)) in *.
clear ttI IIp.
split.
- apply (in_allen_NoUp_left ttJq NUPQtt GT0).
- G(inat_compare (right J) (right I)); intros [LT|[EQ|GT]];
  [exfalso|exfalso|auto].
  + G NOCC. apply tilde. rewrite not_sig_def, not_not. clear NOCC.
    apply (occoccup tIp ttJq GT0 NUPQtt LT).
  + G NENDS; apply tilde. apply not_not. clear NENDS.
    exists I. split;[assumption|].
    exists J. split;[apply (tas_sig ttJq)|split;[|auto]].
    apply (in_allen_NoUp_left ttJq NUPQtt GT0).
Qed.

Lemma during_equiv (p q:sig) : (eq_sig (during p q) (during_new p q)).
apply inc_sig_asym;[apply during_equiv_l|apply during_equiv_r].
Qed.

(*
 * CONTAINS
 *)
Definition contains_new (p q:sig) := (occurs (during q p) p).

Lemma contains_equiv_l (p q:sig) : (inc_sig (contains p q) (contains_new p q)).
intros t (I,(tIp,(J,(JQ,CNT)))).
exists I. split;[assumption|].
exists (left J). split;[|].
- apply (contains_has_left CNT).
- exists J. split.
  + apply (in_sig_tas_left JQ).
  + exists I. split.
    * apply (tas_sig tIp).
    * apply (Contains_During CNT).
Qed.

Lemma contains_equiv_r (p q:sig) : (inc_sig (contains_new p q) (contains p q)).
intros t (I,(tIp,(t',(t'InI,(J,(t'Jq,(K,(KInp,DRG)))))))).
exists I. split;[assumption|].
exists J. split;[apply (tas_sig t'Jq)|].
apply During_Contains.
G DRG; apply eq_right_during.
G (tas_mov tIp t'InI); apply tas_uniq.
G KInp; apply tas_def.
apply ((During_inc_allen DRG) t' (tas_allen t'Jq)).
Qed.

Lemma contains_equiv (p q:sig) : (eq_sig (contains p q) (contains_new p q)).
apply inc_sig_asym;[apply contains_equiv_l|apply contains_equiv_r].
Qed.

End spec.


(** **********************************************************

Benedikt Ahrens, Chris Kapulkin, Mike Shulman

january 2013

************************************************************)

(** **********************************************************

Contents :  Definition of
		Precategories,
	        Categories (aka saturated precategories)
                Setcategories

                Isomorphisms
                  various lemmas:
                    uniqueness of inverse, composition etc.
                    stability under composition

                Categories have groupoid as objects

************************************************************)

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.auxiliary_lemmas_HoTT.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.

Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

(** * Definition of a precategory *)

Definition precategory_ob_mor := total2 (
  fun ob : UU => ob -> ob -> hSet).

Definition precategory_ob_mor_pair (ob : UU)(mor : ob -> ob -> hSet) :
    precategory_ob_mor := tpair _ ob mor.

Definition ob (C : precategory_ob_mor) : Type := @pr1 _ _ C.
Coercion ob : precategory_ob_mor >-> Sortclass.

Definition precategory_morphisms { C : precategory_ob_mor } :
       C ->  C -> hSet := pr2 C.

(** We introduce notation for morphisms *)
(** in order for this notation not to pollute subsequent files,
    we define this notation locally *)

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).

(** ** [precategory_data] *)
(** data of a precategory :
    - objects
    - morphisms
    - identity morphisms
    - composition
*)

Definition precategory_id_comp (C : precategory_ob_mor) :=
     dirprod (forall c : C, c --> c) (* identities *)
             (forall a b c : C,
                 a --> b -> b --> c -> a --> c).

Definition precategory_data := total2 precategory_id_comp.

Definition precategory_data_pair (C : precategory_ob_mor)
    (id : forall c : C, c --> c)
    (comp: forall a b c : C,
         a --> b -> b --> c -> a --> c) : precategory_data :=
   tpair _ C (dirprodpair id comp).

Definition precategory_ob_mor_from_precategory_data (C : precategory_data) :
     precategory_ob_mor := pr1 C.
Coercion precategory_ob_mor_from_precategory_data :
  precategory_data >-> precategory_ob_mor.

Definition identity { C : precategory_data } :
    forall c : C, c --> c :=
         pr1 (pr2 C).

Definition compose { C : precategory_data }
  { a b c : C } :
    a --> b -> b --> c -> a --> c := pr2 (pr2 C) a b c.

Local Notation "f ;; g" := (compose f g)(at level 50).

(** ** Axioms of a precategory *)
(**
        - identity is left and right neutral for composition
        - composition is associative
*)

Definition is_precategory (C : precategory_data) :=
   dirprod (dirprod (forall (a b : C) (f : a --> b),
                         identity a ;; f == f)
                     (forall (a b : C) (f : a --> b),
                         f ;; identity b == f))
            (forall (a b c d : C)
                    (f : a --> b)(g : b --> c) (h : c --> d),
                     f ;; (g ;; h) == (f ;; g) ;; h).

Lemma isaprop_is_precategory (C : precategory_data)
  : isaprop (is_precategory C).
Proof.
  apply isofhleveltotal2.
  { apply isofhleveltotal2. { repeat (apply impred; intro); apply setproperty. }
    intros _. repeat (apply impred; intro); apply setproperty. }
  intros _. repeat (apply impred; intro); apply setproperty.
Qed.

Definition precategory := total2 is_precategory.

Definition precategory_data_from_precategory (C : precategory) :
       precategory_data := pr1 C.
Coercion precategory_data_from_precategory : precategory >-> precategory_data.

Lemma eq_precategory : forall C D : precategory,
    precategory_data_from_precategory C == precategory_data_from_precategory D -> C == D.
Proof.
  intros C D H.
  apply total2_paths_hProp.
  - apply isaprop_is_precategory.
  - apply H.
Defined.

Definition id_left (C : precategory) :
   forall (a b : C) (f : a --> b),
           identity a ;; f == f := pr1 (pr1 (pr2 C)).

Definition id_right (C : precategory) :
   forall (a b : C) (f : a --> b),
           f ;; identity b == f := pr2 (pr1 (pr2 C)).

Definition assoc (C : precategory) :
   forall (a b c d : C)
          (f : a --> b)(g : b --> c) (h : c --> d),
                     f ;; (g ;; h) == (f ;; g) ;; h := pr2 (pr2 C).

(** Any equality on objects a and b induces a morphism from a to b *)

Definition idtomor {C : precategory_data}
   (a b : C) (H : a == b) : a --> b.
Proof.
  destruct H.
  exact (identity a).
Defined.

Definition idtomor_inv {C : precategory}
    (a b : C) (H : a == b) : b --> a.
Proof.
  destruct H.
  exact (identity a).
Defined.

Lemma cancel_postcomposition (C : precategory_data) (a b c: C)
   (f f' : a --> b) (g : b --> c) : f == f' -> f ;; g == f' ;; g.
Proof.
  intro H.
  destruct H.
  apply idpath.
Defined.

(** * Setcategories: Precategories whose objects form a set *)

Definition setcategory := total2 (
   fun C : precategory => isaset (ob C)).

Definition precategory_from_setcategory (C : setcategory) : precategory := pr1 C.
Coercion precategory_from_setcategory : setcategory >-> precategory.

Definition setcategory_objects_set (C : setcategory) : hSet :=
    hSetpair (ob C) (pr2 C).

Lemma setcategory_eq_morphism_pi (C : setcategory) (a b : ob C)
      (e e': a == b) : idtomor _ _ e == idtomor _ _ e'.
Proof.
  assert (h : e == e').
  apply uip. apply (pr2 C).
  apply (maponpaths (idtomor _ _ ) h).
Qed.

(** * Isomorphisms in a precategory *)

(** ** Definition of isomorphisms *)

Definition is_inverse_in_precat {C : precategory} {a b : C}
  (f : a --> b) (g : b --> a) :=
  dirprod (f ;; g == identity a)
          (g ;; f == identity b).

Lemma isaprop_is_inverse_in_precat (C : precategory) (a b : ob C)
   (f : a --> b) (g : b --> a) : isaprop (is_inverse_in_precat f g).
Proof.
  apply isapropdirprod.
  apply (pr2 (a --> a)).
  apply (pr2 (b --> b)).
Qed.

Lemma inverse_unique_precat (C : precategory) (a b : ob C)
   (f : a --> b) (g g': b --> a) (H : is_inverse_in_precat f g)
    (H' : is_inverse_in_precat f g') : g == g'.
Proof.
  destruct H as [eta eps].
  destruct H' as [eta' eps'].
  assert (H : g == identity b ;; g).
    rewrite id_left; apply idpath.
  apply (pathscomp0 H).
  rewrite <- eps'.
  rewrite <- assoc.
  rewrite eta.
  apply id_right.
Qed.

Definition is_isomorphism {C : precategory} {a b : ob C}
  (f : a --> b) := total2 (fun g => is_inverse_in_precat f g).

Lemma isaprop_is_isomorphism {C : precategory} {a b : ob C}
     (f : a --> b) : isaprop (is_isomorphism f).
Proof.
  apply invproofirrelevance.
  intros g g'.
  set (Hpr1 := inverse_unique_precat _ _ _ _ _ _ (pr2 g) (pr2 g')).
  apply (total2_paths Hpr1).
  destruct g as [g [eta eps]].
  destruct g' as [g' [eta' eps']].
  simpl in *.
  apply pairofobuip.
Qed.

Definition iso {C : precategory} (a b :ob C) := total2
    (fun f : a --> b => is_isomorphism f).

Lemma eq_iso (C : precategory)(a b : ob C)
   (f g : iso a b) : pr1 f == pr1 g -> f == g.
Proof.
  intro H.
  apply (total2_paths H).
  apply proofirrelevance.
  apply isaprop_is_isomorphism.
Defined.

Definition morphism_from_iso (C : precategory)(a b : ob C)
   (f : iso a b) : a --> b := pr1 f.
Coercion morphism_from_iso : iso >-> pr1hSet.

Lemma isaset_iso {C : precategory} (a b :ob C) :
  isaset (iso a b).
Proof.
  change isaset with (isofhlevel 2).
  apply isofhleveltotal2.
  apply (pr2 (a --> b)).
  intro f.
  apply isasetaprop.
  apply isaprop_is_isomorphism.
Qed.

Lemma identity_is_iso (C : precategory) (a : ob C) :
    is_isomorphism (identity a).
Proof.
  exists (identity a).
  simpl; split;
  apply id_left.
Defined.

Definition identity_iso {C : precategory} (a : ob C) :
   iso a a := tpair _ _ (identity_is_iso C a).

Definition inv_from_iso {C : precategory} {a b : ob C}
  (f : iso a b) : b --> a := pr1 (pr2 f).

Lemma is_iso_inv_from_iso {C : precategory} (a b : ob C)
  (f : iso a b) : is_isomorphism (inv_from_iso f).
Proof.
  exists (pr1 f).
  simpl; split; simpl.
  unfold inv_from_iso.
  apply (pr2 (pr2 (pr2 f))).
  apply (pr1 (pr2 (pr2 f))).
Defined.

Definition iso_inv_from_iso {C : precategory} {a b : ob C}
  (f : iso a b) : iso b a.
Proof.
  exists (inv_from_iso f).
  apply is_iso_inv_from_iso.
Defined.

Definition iso_inv_from_is_iso {C : precategory} {a b : ob C}
  (f : a --> b) (H : is_isomorphism f) : iso b a :=
  iso_inv_from_iso (tpair _ f H).

Definition iso_inv_after_iso (C : precategory) (a b : ob C)
   (f : iso a b) : f;; inv_from_iso f == identity _ :=
      pr1 (pr2 (pr2 f)).

Definition iso_after_iso_inv (C : precategory) (a b : ob C)
   (f : iso a b) : inv_from_iso f ;; f == identity _ :=
      pr2 (pr2 (pr2 f)).

Lemma iso_inv_on_right (C : precategory) (a b c: ob C)
  (f : iso a  b) (g : b --> c) (h : a --> c) (H : h == f;;g) :
     inv_from_iso f ;; h == g.
Proof.
  assert (H2 : inv_from_iso f;; h ==
                  inv_from_iso f;; (f ;; g)).
  apply maponpaths; assumption.
  rewrite assoc in H2.
  rewrite H2.
  rewrite iso_after_iso_inv.
  apply id_left.
Qed.

Lemma iso_inv_on_left (C : precategory) (a b c: ob C)
  (f : a --> b) (g : iso b c) (h : a --> c) (H : h == f;;g) :
     f == h ;; inv_from_iso g.
Proof.
  assert (H2 : h ;; inv_from_iso g ==
                         (f;; g) ;; inv_from_iso g).
    rewrite H. apply idpath.
  rewrite <- assoc in H2.
  rewrite iso_inv_after_iso in H2.
  rewrite id_right in H2.
  apply pathsinv0.
  assumption.
Qed.

(** ** Properties of isomorphisms *)
(** Stability under composition, inverses etc *)

Lemma are_inverse_comp_of_inverses (C : precategory) (a b c : C)
     (f : iso a b) (g : iso b c) :
  is_inverse_in_precat (f;; g) (inv_from_iso g;; inv_from_iso f).
Proof.
  simpl; split; simpl;
  unfold inv_from_iso; simpl.
  destruct f as [f [f' Hf]]. simpl in *.
  destruct g as [g [g' Hg]]; simpl in *.
  pathvia ((f ;; (g ;; g')) ;; f').
  repeat rewrite assoc; apply idpath.
  rewrite (pr1 Hg).
  rewrite id_right.
  rewrite (pr1 Hf).
  apply idpath.

  destruct f as [f [f' Hf]]. simpl in *.
  destruct g as [g [g' Hg]]; simpl in *.
  pathvia ((g' ;; (f' ;; f)) ;; g).
  repeat rewrite assoc; apply idpath.
  rewrite (pr2 Hf).
  rewrite id_right.
  rewrite (pr2 Hg).
  apply idpath.
Qed.

Lemma is_iso_comp_of_isos {C : precategory} {a b c : ob C}
  (f : iso a b) (g : iso b c) : is_isomorphism (f ;; g).
Proof.
  exists (inv_from_iso g ;; inv_from_iso f). simpl.
  apply are_inverse_comp_of_inverses.
Defined. (* Qed. *)

Definition iso_comp {C : precategory} {a b c : ob C}
  (f : iso a b) (g : iso b c) : iso a c.
Proof.
  exists (f ;; g).
  apply is_iso_comp_of_isos.
Defined.

Lemma inv_iso_unique (C : precategory) (a b : ob C)
  (f : iso a b) (g : iso b a) :
  is_inverse_in_precat f g -> g == iso_inv_from_iso f.
Proof.
  intro H.
  apply eq_iso.
  apply (inverse_unique_precat _ _ _ f).
  assumption.
  split.
  apply iso_inv_after_iso.
  set (h := iso_after_iso_inv _ _ _ f).
  unfold iso_inv_from_iso.
  simpl in *.
  apply h.
Qed.

Lemma iso_inv_of_iso_comp (C : precategory) (a b c : ob C)
   (f : iso a b) (g : iso b c) :
   iso_inv_from_iso (iso_comp f g) == iso_comp (iso_inv_from_iso g) (iso_inv_from_iso f).
Proof.
  apply eq_iso.
  reflexivity.
Qed.

Lemma iso_inv_of_iso_id (C : precategory) (a : ob C) :
   iso_inv_from_iso (identity_iso a) == identity_iso a.
Proof.
  apply eq_iso.
  apply idpath.
Qed.

Lemma iso_inv_iso_inv (C : precategory) (a b : ob C)
   (f : iso a b) :
     iso_inv_from_iso (iso_inv_from_iso f) == f.
Proof.
  apply eq_iso.
  reflexivity.
Defined.

Lemma pre_comp_with_iso_is_inj (C : precategory) (a b c : ob C)
    (f : a --> b) (H : is_isomorphism f) (g h : b --> c) : f ;; g == f ;; h -> g == h.
Proof.
  intro HH.
  pathvia (pr1 H ;; f ;; g).
  rewrite (pr2 (pr2 H)).
  rewrite id_left.
  apply idpath.
  pathvia ((pr1 H ;; f) ;; h).
  repeat rewrite <- assoc.
  apply maponpaths. assumption.
  rewrite (pr2 (pr2 H)).
  rewrite id_left.
  apply idpath.
Qed.

Lemma post_comp_with_iso_is_inj (C : precategory) (b c : ob C)
     (h : b --> c) (H : is_isomorphism h)
   (a : ob C) (f g : a --> b) : f ;; h == g ;; h -> f == g.
Proof.
  intro HH.
  pathvia (f ;; (h ;; pr1 H)).
  rewrite (pr1 (pr2 H)).
  rewrite id_right.
  apply idpath.
  pathvia (g ;; (h ;; pr1 H)).
  repeat rewrite assoc.
  rewrite HH. apply idpath.
  rewrite (pr1 (pr2 H)).
  rewrite id_right.
  apply idpath.
Qed.

(** ***  *)

Lemma iso_comp_right_isweq {C:precategory} {a b:ob C} (h:iso a b) (c:C) :
  isweq (fun f : b --> c => h ;; f).
Proof.
  intros. apply (gradth _ (fun g => inv_from_iso h ;; g)).
       { intros f. refine (_ @ maponpaths (fun m => m ;; f) (pr2 (pr2 (pr2 h))) @ _).
         { apply assoc. } { apply id_left. } }
       { intros g. refine (_ @ maponpaths (fun m => m ;; g) (pr1 (pr2 (pr2 h))) @ _).
         { apply assoc. } { apply id_left. } }
Qed.

(** * Categories (aka saturated precategories) *)

(** ** Definition of categories *)

Definition idtoiso {C : precategory} {a b : ob C}:
      a == b -> iso a b.
Proof.
  intro H.
  destruct H.
  exact (identity_iso a).
Defined.

(* use eta expanded version to force printing of object arguments *)
Definition is_category (C : precategory) := forall (a b : ob C),
    isweq (fun p : a == b => idtoiso p).

Lemma eq_idtoiso_idtomor {C:precategory} (a b:ob C) (e:a == b) :
    pr1 (idtoiso e) == idtomor _ _ e.
Proof.
  destruct e; reflexivity.
Defined.

Lemma isaprop_is_category (C : precategory) : isaprop (is_category C).
Proof.
  apply impred.
  intro a.
  apply impred.
  intro b.
  apply isapropisweq.
Qed.

Definition category := total2 (fun C : precategory => is_category C).

Definition precat_from_cat (C : category) : precategory := pr1 C.
Coercion precat_from_cat : category >-> precategory.

Lemma category_has_groupoid_ob (C : category) :
  isofhlevel 3 (ob C).
Proof.
  change (isofhlevel 3 C) with
        (forall a b : C, isofhlevel 2 (a == b)).
  intros a b.
  apply (isofhlevelweqb _ (tpair _ _ (pr2 C a b))).
  apply isaset_iso.
Qed.

(** ** Definition of [isotoid] *)

Definition isotoid (C : precategory) (H : is_category C) {a b : ob C}:
      iso a b -> a == b := invmap (weqpair _ (H a b)).

Lemma idtoiso_isotoid (C : precategory) (H : is_category C) (a b : ob C)
    (f : iso a b) : idtoiso (isotoid _ H f) == f.
Proof.
  unfold isotoid.
  set (Hw := homotweqinvweq (weqpair idtoiso (H a b))).
  simpl in Hw.
  apply Hw.
Qed.

Lemma isotoid_idtoiso (C : precategory) (H : is_category C) (a b : ob C)
    (p : a == b) : isotoid _ H (idtoiso p) == p.
Proof.
  unfold isotoid.
  set (Hw := homotinvweqweq (weqpair idtoiso (H a b))).
  simpl in Hw.
  apply Hw.
Qed.

(** ** Properties of [idtoiso] and [isotoid] *)

Definition double_transport {C : precategory} {a a' b b' : ob C}
   (p : a == a') (q : b == b') (f : a --> b) : a' --> b' :=
  transportf (fun c => a' --> c) q (transportf (fun c => c --> b) p f).

Lemma idtoiso_postcompose (C : precategory) (a b b' : ob C)
  (p : b == b') (f : a --> b) :
      f ;; idtoiso p == transportf (fun b => a --> b) p f.
Proof.
  destruct p.
  apply id_right.
Qed.

Lemma idtoiso_postcompose_iso (C : precategory) (a b b' : ob C)
  (p : b == b') (f : iso a b) :
    iso_comp f (idtoiso p) == transportf (fun b => iso a b) p f.
Proof.
  destruct p.
  apply eq_iso.
  simpl.
  apply id_right.
Qed.

Lemma idtoiso_precompose (C : precategory) (a a' b : ob C)
  (p : a == a') (f : a --> b) :
      (idtoiso (!p)) ;; f == transportf (fun a => a --> b) p f.
Proof.
  destruct p.
  apply id_left.
Qed.

Lemma idtoiso_precompose_iso (C : precategory) (a a' b : ob C)
  (p : a == a') (f : iso a b) :
      iso_comp (idtoiso (!p)) f == transportf (fun a => iso a b) p f.
Proof.
  destruct p.
  apply eq_iso.
  simpl.
  apply id_left.
Qed.

Lemma double_transport_idtoiso (C : precategory) (a a' b b' : ob C)
  (p : a == a') (q : b == b')  (f : a --> b) :
  double_transport p q f == inv_from_iso (idtoiso p) ;; f ;; idtoiso q.
Proof.
  destruct p.
  destruct q.
  rewrite id_right.
  rewrite id_left.
  apply idpath.
Qed.

Lemma idtoiso_inv (C : precategory) (a a' : ob C)
  (p : a == a') : idtoiso (!p) == iso_inv_from_iso (idtoiso p).
Proof.
  destruct p.
  apply idpath.
Qed.

Lemma idtoiso_concat (C : precategory) (a a' a'' : ob C)
  (p : a == a') (q : a' == a'') :
  idtoiso (p @ q) == iso_comp (idtoiso p) (idtoiso q).
Proof.
  destruct p.
  destruct q.
  apply eq_iso.
  simpl;
  rewrite id_left.
  apply idpath.
Qed.

Lemma idtoiso_inj (C : precategory) (H : is_category C) (a a' : ob C)
   (p p' : a == a') : idtoiso p == idtoiso p' -> p == p'.
Proof.
  apply invmaponpathsincl.
  apply isinclweq.
  apply H.
Qed.

Lemma isotoid_inj (C : precategory) (H : is_category C) (a a' : ob C)
   (f f' : iso a a') : isotoid _ H f == isotoid _ H f' -> f == f'.
Proof.
  apply invmaponpathsincl.
  apply isinclweq.
  apply isweqinvmap.
Qed.

Lemma isotoid_comp (C : precategory) (H : is_category C) (a b c : ob C)
  (e : iso a b) (f : iso b c) :
  isotoid _ H (iso_comp e f) == isotoid _ H e @ isotoid _ H f.
Proof.
  apply idtoiso_inj.
    assumption.
  rewrite idtoiso_concat.
  repeat rewrite idtoiso_isotoid.
  apply idpath.
Qed.

Lemma isotoid_identity_iso (C : precategory) (H : is_category C) (a : C) :
  isotoid _ H (identity_iso a) == idpath _ .
Proof.
  apply idtoiso_inj; try assumption.
  rewrite idtoiso_isotoid;
  apply idpath.
Qed.

Lemma inv_isotoid (C : precategory) (H : is_category C) (a b : C)
    (f : iso a b) : ! isotoid _ H f == isotoid _ H (iso_inv_from_iso f).
Proof.
  apply idtoiso_inj; try assumption.
  rewrite idtoiso_isotoid.
  rewrite idtoiso_inv.
  rewrite idtoiso_isotoid.
  apply idpath.
Qed.

Lemma transportf_isotoid (C : precategory) (H : is_category C)
   (a a' b : ob C) (p : iso a a') (f : a --> b) :
 transportf (fun a0 : C => a0 --> b) (isotoid C H p) f == inv_from_iso p ;; f.
Proof.
  rewrite <- idtoiso_precompose.
  rewrite idtoiso_inv.
  rewrite idtoiso_isotoid.
  apply idpath.
Qed.

Lemma transportf_isotoid_dep (C : precategory)
   (a a' : C) (p : a == a') (f : forall c, a --> c) :
 transportf (fun x : C => forall c, x --> c) p f == fun c => idtoiso (!p) ;; f c.
Proof.
  destruct p.
  simpl.
  apply funextsec.
  intro.
  rewrite id_left.
  apply idpath.
Qed.

Lemma transportf_isotoid_dep' (J C : precategory)
  (F : J -> C)
   (a a' : C) (p : a == a') (f : forall c, a --> F c) :
 transportf (fun x : C => forall c, x --> F c) p f == fun c => idtoiso (!p) ;; f c.
Proof.
  destruct p.
  apply funextsec.
  intro. simpl.
  apply (! id_left _ _ _ _).
Defined.

(** ** Precategories in style of essentially algebraic cats *)
(** Of course we later want SETS of objects, rather than types,
    but the construction can already be specified.
*)

Definition total_morphisms (C : precategory_ob_mor) := total2 (
   fun ab : dirprod (ob C)(ob C) =>
        precategory_morphisms (pr1 ab) (pr2 ab)).

Lemma isaset_setcategory_total_morphisms (C : setcategory) :
   isaset (total_morphisms C).
Proof.
  change isaset with (isofhlevel 2).
  apply isofhleveltotal2.
  apply isofhleveldirprod.
  exact (pr2 C).
  exact (pr2 C).
  exact (fun x => (pr2 (pr1 x --> pr2 x))).
Qed.

Definition setcategory_total_morphisms_set (C : setcategory) : hSet :=
    hSetpair _ (isaset_setcategory_total_morphisms C).

Definition precategory_source (C : precategory_ob_mor) :
     total_morphisms C -> ob C :=
     fun abf => pr1 (pr1 abf).

Definition precategory_target (C : precategory_ob_mor) :
     total_morphisms C -> ob C :=
     fun abf => pr2 (pr1 abf).

Definition precategory_total_id (C : precategory_data) :
      ob C -> total_morphisms C :=
      fun c => tpair _ (dirprodpair c c) (identity c).

Definition precategory_total_comp'' (C : precategory_data) :
      forall f g : total_morphisms C,
        precategory_target C f == precategory_source C g ->
         total_morphisms C.
Proof.
  intros f g e.
  destruct f as [[a b] f]. simpl in *.
  destruct g as [[b' c] g]. simpl in *.
  unfold precategory_target in e; simpl in e.
  unfold precategory_source in e; simpl in e.
  simpl.
  exists (dirprodpair a c). simpl.
  exact ((f ;; idtomor _ _ e) ;; g).
Defined.

Definition precategory_total_comp (C : precategory_data) :
      forall f g : total_morphisms C,
        precategory_target C f == precategory_source C g ->
         total_morphisms C :=
  fun f g e =>
     tpair _ (dirprodpair (pr1 (pr1 f))(pr2 (pr1 g)))
        ((pr2 f ;; idtomor _ _ e) ;; pr2 g).


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing {#N} $\ensuremath{\mathrel\#_{\mathbb N}}$ *)

Require Export Coq.Arith.Peano_dec.
Require Export Coq.Relations.Relations.
Require Import CoRN.logic.CLogic.
From Coq Require Import Lia.

(**
* [nat]
** About [nat]

We prove some basic lemmas of the natural numbers.

A variant of [0_S] from the standard library
*)

Lemma S_O : forall n : nat, S n <> 0.
Proof.
 intro n.
 red in |- *.
 intro H.
 generalize O_S.
 intro H0.
 red in H0.
 apply H0 with n.
 apply sym_eq.
 exact H.
Qed.

(**
*** Apartness
*)

Definition ap_nat (x y : nat) := ~ (x = y :>nat).

Infix "{#N}" := ap_nat (no associativity, at level 90).

Lemma ap_nat_irreflexive0 : forall x : nat, Not (x{#N}x).
Proof.
 red in |- *.
 unfold ap_nat in |- *.
 intros x X.
 apply X.
 auto.
Qed.

Lemma ap_nat_symmetric0 : forall x y : nat, (x{#N}y) -> y{#N}x.
Proof.
 intros x y.
 unfold ap_nat in |- *.
 intros X.
 intro Y.
 apply X.
 auto.
Qed.

Lemma ap_nat_cotransitive0 : forall x y : nat,
 (x{#N}y) -> forall z : nat, (x{#N}z) or (z{#N}y).
Proof.
 intros x y X z.
 unfold ap_nat in |- *.
 case (eq_nat_dec x z).
  intro e.
  right.
  rewrite <- e.
  assumption.
 intro.
 left.
 intro.
 elim n.
 assumption.
Qed.

Lemma ap_nat_tight0 : forall x y : nat, Not (x{#N}y) <-> x = y.
Proof.
 intros x y.
 red in |- *.
 split.
  unfold ap_nat in |- *.
  intro H.
  case (eq_nat_dec x y).
   intro e.
   assumption.
  intro n.
  elim H.
  intro H0.
  elim n.
  assumption.
 intro H.
 unfold ap_nat in |- *.
 intro H0.
 elim H0.
 assumption.
Qed.

(**
*** Addition
*)

Lemma plus_strext0 : forall x1 x2 y1 y2 : nat,
 (x1+y1{#N}x2+y2) -> (x1{#N}x2) or (y1{#N}y2).
Proof.
 intros x1 x2 y1 y2 H.
 unfold ap_nat in |- *.
 unfold ap_nat in H.
 case (eq_nat_dec x1 x2).
  intro e.
  right.
  red in |- *.
  intro H0.
  apply H.
  auto.
 intro n.
 left.
 intro H0.
 elim n.
 assumption.
Qed.

(** There is no inverse for addition, because every candidate will fail for 2
*)

Lemma no_inverse0 : forall f : nat -> nat, ~ ((2+f 2) = 0 /\ (f 2+2) = 0).
Proof.
 intro f.
 simpl in |- *.
 red in |- *.
 intro H.
 elim H.
 intros H1 H2.
 set (H3 := O_S (S (f 2))) in *.
 generalize H3.
 unfold not in |- *.
 intro H4.
 apply H4.
 lia.
Qed.

(**
*** Multiplication
*)

Lemma mult_strext0 : forall x1 x2 y1 y2 : nat,
 (x1*y1{#N}x2*y2) -> (x1{#N}x2) or (y1{#N}y2).
Proof.
 unfold ap_nat in |- *.
 intros x1 x2 y1 y2 H.
 cut ({x1 = x2} + {x1 <> x2}).
  intro H1.
  elim H1.
   intro e.
   right.
   red in |- *.
   intro H0.
   apply H.
   exact (f_equal2 mult e H0).
  intro X.
  auto.
 apply eq_nat_dec.
Qed.

(**
*** Decidability
*)
Lemma not_or:(forall (p q:nat), (p<>q)-> p<q or q<p):CProp.
Proof.
 simpl.
 intros p q H.
 set (H0:=(lt_eq_lt_dec p q)).
 elim H0.
  clear H0.
  intros H0.
  elim H0.
   clear H0.
   intros H0.
   left.
   exact H0.
  clear H0.
  intros H0.
  intuition.
 clear H0.
 intros H0.
 right.
 exact H0.
Qed.

(* begin hide *)

Lemma k_zero:forall (k i l:nat),
Not (0<k or 0=k and i<l)-> k=0.
Proof.
 intros k i l H.
 unfold Not in H.
 set (H1:=(lt_eq_lt_dec 0 k)).
 elim H1.
  clear H1.
  intro H1.
  elim H1.
   clear H1.
   intuition.
  intuition.
 intuition.
Qed.

Lemma lexi_dec:(forall (k i l:nat),
Cdecidable (0<k or 0=k and i<l)):CProp.
Proof.
 intros k i l.
 unfold Cdecidable.
 set (H:=(lt_eq_lt_dec 0 k)).
 elim H.
  clear H.
  intro H.
  elim H.
   clear H.
   intro H.
   left.
   left.
   exact H.
  clear H.
  intro H.
  elim (le_gt_dec l i).
   intro H1.
   right.
   unfold Not.
   intro H2.
   intuition.
  intro H1.
  left.
  right.
  intuition.
 intuition.
Qed.

(* end hide *)