(** * ProofObjects: The Curry-Howard Correspondence *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From LF Require Export IndProp.

(** "Algorithms are the computational content of proofs."
    (Robert Harper) *)

(** We have seen that Coq has mechanisms both for _programming_,
    using inductive data types like [nat] or [list] and functions over
    these types, and for _proving_ properties of these programs, using
    inductive propositions (like [ev]), implication, universal
    quantification, and the like.  So far, we have mostly treated
    these mechanisms as if they were quite separate, and for many
    purposes this is a good way to think.  But we have also seen hints
    that Coq's programming and proving facilities are closely related.
    For example, the keyword [Inductive] is used to declare both data
    types and propositions, and [->] is used both to describe the type
    of functions on data and logical implication.  This is not just a
    syntactic accident!  In fact, programs and proofs in Coq are
    almost the same thing.  In this chapter we will study how this
    works.

    We have already seen the fundamental idea: provability in Coq is
    represented by concrete _evidence_.  When we construct the proof
    of a basic proposition, we are actually building a tree of
    evidence, which can be thought of as a data structure.

    If the proposition is an implication like [A -> B], then its proof
    will be an evidence _transformer_: a recipe for converting
    evidence for A into evidence for B.  So at a fundamental level,
    proofs are simply programs that manipulate evidence. *)

(** Question: If evidence is data, what are propositions themselves?

    Answer: They are types! *)

(** Look again at the formal definition of the [ev] property.  *)

Print ev.
(* ==>
  Inductive ev : nat -> Prop :=
    | ev_0 : ev 0
    | ev_SS : forall n, ev n -> ev (S (S n)).
*)

(** Suppose we introduce an alternative pronunciation of "[:]".
    Instead of "has type," we can say "is a proof of."  For example,
    the second line in the definition of [ev] declares that [ev_0 : ev
    0].  Instead of "[ev_0] has type [ev 0]," we can say that "[ev_0]
    is a proof of [ev 0]." *)

(** This pun between types and propositions -- between [:] as "has type"
    and [:] as "is a proof of" or "is evidence for" -- is called the
    _Curry-Howard correspondence_.  It proposes a deep connection
    between the world of logic and the world of computation:

                 propositions  ~  types
                 proofs        ~  data values

    See [Wadler 2015] (in Bib.v) for a brief history and up-to-date
    exposition. *)

(** Many useful insights follow from this connection.  To begin with,
    it gives us a natural interpretation of the type of the [ev_SS]
    constructor: *)

Check ev_SS
  : forall n,
    ev n ->
    ev (S (S n)).

(** This can be read "[ev_SS] is a constructor that takes two
    arguments -- a number [n] and evidence for the proposition [ev
    n] -- and yields evidence for the proposition [ev (S (S n))]." *)

(** Now let's look again at a previous proof involving [ev]. *)

Theorem ev_4 : ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_0. Qed.

(** As with ordinary data values and functions, we can use the [Print]
    command to see the _proof object_ that results from this proof
    script. *)

Print ev_4.
(* ===> ev_4 = ev_SS 2 (ev_SS 0 ev_0)
      : ev 4  *)

(** Indeed, we can also write down this proof object directly,
    without the need for a separate proof script: *)

Check (ev_SS 2 (ev_SS 0 ev_0))
  : ev 4.

(** The expression [ev_SS 2 (ev_SS 0 ev_0)] can be thought of as
    instantiating the parameterized constructor [ev_SS] with the
    specific arguments [2] and [0] plus the corresponding proof
    objects for its premises [ev 2] and [ev 0].  Alternatively, we can
    think of [ev_SS] as a primitive "evidence constructor" that, when
    applied to a particular number, wants to be further applied to
    evidence that this number is even; its type,

      forall n, ev n -> ev (S (S n)),

    expresses this functionality, in the same way that the polymorphic
    type [forall X, list X] expresses the fact that the constructor
    [nil] can be thought of as a function from types to empty lists
    with elements of that type. *)

(** We saw in the [Logic] chapter that we can use function
    application syntax to instantiate universally quantified variables
    in lemmas, as well as to supply evidence for assumptions that
    these lemmas impose.  For instance: *)

Theorem ev_4': ev 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.

(* ################################################################# *)
(** * Proof Scripts *)

(** The _proof objects_ we've been discussing lie at the core of how
    Coq operates.  When Coq is following a proof script, what is
    happening internally is that it is gradually constructing a proof
    object -- a term whose type is the proposition being proved.  The
    tactics between [Proof] and [Qed] tell it how to build up a term
    of the required type.  To see this process in action, let's use
    the [Show Proof] command to display the current state of the proof
    tree at various points in the following tactic proof. *)

Theorem ev_4'' : ev 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.

(** At any given moment, Coq has constructed a term with a
    "hole" (indicated by [?Goal] here, and so on), and it knows what
    type of evidence is needed to fill this hole.

    Each hole corresponds to a subgoal, and the proof is
    finished when there are no more subgoals.  At this point, the
    evidence we've built is stored in the global context under the name
    given in the [Theorem] command. *)

(** Tactic proofs are useful and convenient, but they are not
    essential: in principle, we can always construct the required
    evidence by hand, as shown above. Then we can use [Definition]
    (rather than [Theorem]) to give a global name directly to this
    evidence. *)

Definition ev_4''' : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

(** All these different ways of building the proof lead to exactly the
    same evidence being saved in the global environment. *)

Print ev_4.
(* ===> ev_4    =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'.
(* ===> ev_4'   =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4''.
(* ===> ev_4''  =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'''.
(* ===> ev_4''' =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)

(** **** Exercise: 2 stars, standard (eight_is_even)

    Give a tactic proof and a proof object showing that [ev 8]. *)

Theorem ev_8 : ev 8.
Proof.
  repeat constructor.
Qed.

Definition ev_8' : ev 8 :=
  ev_SS 6 (ev_SS 4 (ev_SS 2 (ev_SS 0 ev_0))).
(** [] *)

(* ################################################################# *)
(** * Quantifiers, Implications, Functions *)

(** In Coq's computational universe (where data structures and
    programs live), there are two sorts of values that have arrows in
    their types: _constructors_ introduced by [Inductive]ly defined
    data types, and _functions_.

    Similarly, in Coq's logical universe (where we carry out proofs),
    there are two ways of giving evidence for an implication:
    constructors introduced by [Inductive]ly defined propositions,
    and... functions! *)

(** For example, consider this statement: *)

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n H. simpl.
  apply ev_SS.
  apply ev_SS.
  apply H.
Qed.

(** What is the proof object corresponding to [ev_plus4]?

    We're looking for an expression whose _type_ is [forall n, ev n ->
    ev (4 + n)] -- that is, a _function_ that takes two arguments (one
    number and a piece of evidence) and returns a piece of evidence!

    Here it is: *)

Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) => fun (H : ev n) =>
    ev_SS (S (S n)) (ev_SS n H).

(** Recall that [fun n => blah] means "the function that, given [n],
    yields [blah]," and that Coq treats [4 + n] and [S (S (S (S n)))]
    as synonyms. Another equivalent way to write this definition is: *)

Definition ev_plus4'' (n : nat) (H : ev n)
                    : ev (4 + n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''
  : forall n : nat,
    ev n ->
    ev (4 + n).

(** When we view the proposition being proved by [ev_plus4] as a
    function type, one interesting point becomes apparent: The second
    argument's type, [ev n], mentions the _value_ of the first
    argument, [n].

    While such _dependent types_ are not found in conventional
    programming languages, they can be useful in programming too, as
    the recent flurry of activity in the functional programming
    community demonstrates. *)

(** Notice that both implication ([->]) and quantification ([forall])
    correspond to functions on evidence.  In fact, they are really the
    same thing: [->] is just a shorthand for a degenerate use of
    [forall] where there is no dependency, i.e., no need to give a
    name to the type on the left-hand side of the arrow:

           forall (x:nat), nat
        =  forall (_:nat), nat
        =  nat -> nat
*)

(** For example, consider this proposition: *)

Definition ev_plus2 : Prop :=
  forall n, forall (E : ev n), ev (n + 2).

(** A proof term inhabiting this proposition would be a function
    with two arguments: a number [n] and some evidence [E] that [n] is
    even.  But the name [E] for this evidence is not used in the rest
    of the statement of [ev_plus2], so it's a bit silly to bother
    making up a name for it.  We could write it like this instead,
    using the dummy identifier [_] in place of a real name: *)

Definition ev_plus2' : Prop :=
  forall n, forall (_ : ev n), ev (n + 2).

(** Or, equivalently, we can write it in a more familiar way: *)

Definition ev_plus2'' : Prop :=
  forall n, ev n -> ev (n + 2).

(** In general, "[P -> Q]" is just syntactic sugar for
    "[forall (_:P), Q]". *)

(* ################################################################# *)
(** * Programming with Tactics *)

(** If we can build proofs by giving explicit terms rather than
    executing tactic scripts, you may be wondering whether we can
    build _programs_ using _tactics_ rather than explicit terms.
    Naturally, the answer is yes! *)

Definition add1 : nat -> nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n. Defined.

Print add1.
(* ==>
    add1 = fun n : nat => S n
         : nat -> nat
*)

Compute add1 2.
(* ==> 3 : nat *)

(** Notice that we terminate the [Definition] with a [.] rather than
    with [:=] followed by a term.  This tells Coq to enter _proof
    scripting mode_ to build an object of type [nat -> nat].  Also, we
    terminate the proof with [Defined] rather than [Qed]; this makes
    the definition _transparent_ so that it can be used in computation
    like a normally-defined function.  ([Qed]-defined objects are
    opaque during computation.)

    This feature is mainly useful for writing functions with dependent
    types, which we won't explore much further in this book.  But it
    does illustrate the uniformity and orthogonality of the basic
    ideas in Coq. *)

(* ################################################################# *)
(** * Logical Connectives as Inductive Types *)

(** Inductive definitions are powerful enough to express most of the
    connectives we have seen so far.  Indeed, only universal
    quantification (with implication as a special case) is built into
    Coq; all the others are defined inductively.  We'll see these
    definitions in this section. *)

Module Props.

(* ================================================================= *)
(** ** Conjunction *)

(** To prove that [P /\ Q] holds, we must present evidence for both
    [P] and [Q].  Thus, it makes sense to define a proof object for [P
    /\ Q] as consisting of a pair of two proofs: one for [P] and
    another one for [Q]. This leads to the following definition. *)

Module And.

Inductive and (P Q : Prop) : Prop :=
  | conj : P -> Q -> and P Q.

Arguments conj [P] [Q].

Notation "P /\ Q" := (and P Q) : type_scope.

(** Notice the similarity with the definition of the [prod] type,
    given in chapter [Poly]; the only difference is that [prod] takes
    [Type] arguments, whereas [and] takes [Prop] arguments. *)

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

(** This similarity should clarify why [destruct] and [intros]
    patterns can be used on a conjunctive hypothesis.  Case analysis
    allows us to consider all possible ways in which [P /\ Q] was
    proved -- here just one (the [conj] constructor). *)

Theorem proj1' : forall P Q,
  P /\ Q -> P.
Proof.
  intros P Q HPQ. destruct HPQ as [HP HQ]. apply HP.
  Show Proof.
Qed.

(** Similarly, the [split] tactic actually works for any inductively
    defined proposition with exactly one constructor.  In particular,
    it works for [and]: *)

Lemma and_comm : forall P Q : Prop, P /\ Q <-> Q /\ P.
Proof.
  intros P Q. split.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
  - intros [HQ HP]. split.
    + apply HP.
    + apply HQ.
Qed.

End And.

(** This shows why the inductive definition of [and] can be
    manipulated by tactics as we've been doing.  We can also use it to
    build proofs directly, using pattern-matching.  For instance: *)

Definition and_comm'_aux P Q (H : P /\ Q) : Q /\ P :=
  match H with
  | conj HP HQ => conj HQ HP
  end.

Definition and_comm' P Q : P /\ Q <-> Q /\ P :=
  conj (and_comm'_aux P Q) (and_comm'_aux Q P).

(** **** Exercise: 2 stars, standard (conj_fact)

    Construct a proof object for the following proposition. *)

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
(** [] *)

(* ================================================================= *)
(** ** Disjunction *)

(** The inductive definition of disjunction uses two constructors, one
    for each side of the disjunct: *)

Module Or.

Inductive or (P Q : Prop) : Prop :=
  | or_introl : P -> or P Q
  | or_intror : Q -> or P Q.

Arguments or_introl [P] [Q].
Arguments or_intror [P] [Q].

Notation "P \/ Q" := (or P Q) : type_scope.

(** This declaration explains the behavior of the [destruct] tactic on
    a disjunctive hypothesis, since the generated subgoals match the
    shape of the [or_introl] and [or_intror] constructors. *)

(** Once again, we can also directly write proof objects for theorems
    involving [or], without resorting to tactics. *)

Definition inj_l : forall (P Q : Prop), P -> P \/ Q :=
  fun P Q HP => or_introl HP.

Theorem inj_l' : forall (P Q : Prop), P -> P \/ Q.
Proof.
  intros P Q HP. left. apply HP.
Qed.

Definition or_elim : forall (P Q R : Prop), (P \/ Q) -> (P -> R) -> (Q -> R) -> R :=
  fun P Q R HPQ HPR HQR =>
    match HPQ with
    | or_introl HP => HPR HP
    | or_intror HQ => HQR HQ
    end.

Theorem or_elim' : forall (P Q R : Prop), (P \/ Q) -> (P -> R) -> (Q -> R) -> R.
Proof.
  intros P Q R HPQ HPR HQR.
  destruct HPQ as [HP | HQ].
  - apply HPR. apply HP.
  - apply HQR. apply HQ.
Qed.

End Or.

(** **** Exercise: 2 stars, standard (or_commut')

    Construct a proof object for the following proposition. *)

Definition or_commut' : forall P Q, P \/ Q -> Q \/ P :=
  fun P Q HPQ =>
    match HPQ with
    | or_introl HP => or_intror HP
    | or_intror HQ => or_introl HQ
    end.
(** [] *)

(* ================================================================= *)
(** ** Existential Quantification *)

(** To give evidence for an existential quantifier, we package a
    witness [x] together with a proof that [x] satisfies the property
    [P]: *)

Module Ex.

Inductive ex {A : Type} (P : A -> Prop) : Prop :=
  | ex_intro : forall x : A, P x -> ex P.

Notation "'exists' x , p" :=
  (ex (fun x => p))
    (at level 200, right associativity) : type_scope.

End Ex.

(** This may benefit from a little unpacking.  The core definition is
    for a type former [ex] that can be used to build propositions of
    the form [ex P], where [P] itself is a _function_ from witness
    values in the type [A] to propositions.  The [ex_intro]
    constructor then offers a way of constructing evidence for [ex P],
    given a witness [x] and a proof of [P x].

    The notation in the standard library is a slight variant of
    the above, enabling syntactic forms such as [exists x y, P x y]. *)

(** The more familiar form [exists x, P x] desugars to an expression
    involving [ex]: *)

Check ex (fun n => ev n) : Prop.

(** Here's how to define an explicit proof object involving [ex]: *)

Definition some_nat_is_even : exists n, ev n :=
  ex_intro ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

(** **** Exercise: 2 stars, standard (ex_ev_Sn)

    Construct a proof object for the following proposition. *)

Definition ex_ev_Sn : ex (fun n => ev (S n)) :=
    ex_intro (fun n => ev (S n)) 3 (ev_SS 2 (ev_SS 0 ev_0)).
(** [] *)

(* ================================================================= *)
(** ** [True] and [False] *)

(** The inductive definition of the [True] proposition is simple: *)

Inductive True : Prop :=
  | I : True.

(** It has one constructor (so every proof of [True] is the same, so
    being given a proof of [True] is not informative.) *)

(** **** Exercise: 1 star, standard (p_implies_true)

    Construct a proof object for the following proposition. *)

Definition p_implies_true : forall P, P -> True :=
  fun P HP => I.
(** [] *)

(** [False] is equally simple -- indeed, so simple it may look
    syntactically wrong at first glance! *)

Inductive False : Prop := .

(** That is, [False] is an inductive type with _no_ constructors --
    i.e., no way to build evidence for it. For example, there is
    no way to complete the following definition such that it
    succeeds (rather than fails). *)

Fail Definition contra : False :=
  0 = 1.

(** But it is possible to destruct [False] by pattern matching. There can
    be no patterns that match it, since it has no constructors.  So
    the pattern match also is so simple it may look syntactically
    wrong at first glance. *)

Definition false_implies_zero_eq_one : False -> 0 = 1 :=
  fun contra => match contra with end.

(** Since there are no branches to evaluate, the [match] expression
    can be considered to have any type we want, including [0 = 1].
    Indeed, it's impossible to ever cause the [match] to be evaluated,
    because we can never construct a value of type [False] to pass to
    the function. *)

(** **** Exercise: 1 star, standard (ex_falso_quodlibet')

    Construct a proof object for the following proposition. *)

Definition ex_falso_quodlibet' : forall P, False -> P :=
  fun P contra => match contra with end.
(** [] *)

End Props.

(* ################################################################# *)
(** * Equality *)

(** Even Coq's equality relation is not built in.  We can define
    it ourselves: *)

Module MyEquality.

Inductive eq {X:Type} : X -> X -> Prop :=
  | eq_refl : forall x, eq x x.

Notation "x == y" := (eq x y)
                       (at level 70, no associativity)
                     : type_scope.

(** The way to think about this definition (which is just a slight
    variant of the standard library's) is that, given a set [X], it
    defines a _family_ of propositions "[x] is equal to [y]," indexed
    by pairs of values ([x] and [y]) from [X].  There is just one way
    of constructing evidence for members of this family: applying the
    constructor [eq_refl] to a type [X] and a single value [x : X],
    which yields evidence that [x] is equal to [x].

    Other types of the form [eq x y] where [x] and [y] are not the
    same are thus uninhabited. *)

(** We can use [eq_refl] to construct evidence that, for example, [2 =
    2].  Can we also use it to construct evidence that [1 + 1 = 2]?
    Yes, we can.  Indeed, it is the very same piece of evidence!

    The reason is that Coq treats as "the same" any two terms that are
    _convertible_ according to a simple set of computation rules.

    These rules, which are similar to those used by [Compute], include
    evaluation of function application, inlining of definitions, and
    simplification of [match]es.  *)

Lemma four: 2 + 2 == 1 + 3.
Proof.
  apply eq_refl.
Qed.

(** The [reflexivity] tactic that we have used to prove
    equalities up to now is essentially just shorthand for [apply
    eq_refl].

    In tactic-based proofs of equality, the conversion rules are
    normally hidden in uses of [simpl] (either explicit or implicit in
    other tactics such as [reflexivity]).

    But you can see them directly at work in the following explicit
    proof objects: *)

Definition four' : 2 + 2 == 1 + 3 :=
  eq_refl 4.

Definition singleton : forall (X:Type) (x:X), []++[x] == x::[]  :=
  fun (X:Type) (x:X) => eq_refl [x].

(** **** Exercise: 2 stars, standard (equality__leibniz_equality)

    The inductive definition of equality implies _Leibniz equality_:
    what we mean when we say "[x] and [y] are equal" is that every
    property on [P] that is true of [x] is also true of [y].  *)

Lemma equality__leibniz_equality : forall (X : Type) (x y: X),
  x == y -> forall P:X->Prop, P x -> P y.
Proof.
  intros.
  inversion H.
  subst.
  assumption.
Qed.
(** [] *)

(** **** Exercise: 3 stars, standard, optional (leibniz_equality__equality)

    Show that, in fact, the inductive definition of equality is
    _equivalent_ to Leibniz equality.  Hint: the proof is quite short;
    about all you need to do is to invent a clever property [P] to
    instantiate the antecedent.*)

Lemma leibniz_equality__equality : forall (X : Type) (x y: X),
  (forall P:X->Prop, P x -> P y) -> x == y.
Proof.
  intros.
  specialize (H (fun z => x == z)).
  simpl in H.
  assert (x == x). {constructor. }
  apply H in H0.
  assumption.
Qed.
(** [] *)

End MyEquality.

(* ================================================================= *)
(** ** Inversion, Again *)

(** We've seen [inversion] used with both equality hypotheses and
    hypotheses about inductively defined propositions.  Now that we've
    seen that these are actually the same thing, we're in a position
    to take a closer look at how [inversion] behaves.

    In general, the [inversion] tactic...

    - takes a hypothesis [H] whose type [P] is inductively defined,
      and

    - for each constructor [C] in [P]'s definition,

      - generates a new subgoal in which we assume [H] was
        built with [C],

      - adds the arguments (premises) of [C] to the context of
        the subgoal as extra hypotheses,

      - matches the conclusion (result type) of [C] against the
        current goal and calculates a set of equalities that must
        hold in order for [C] to be applicable,

      - adds these equalities to the context (and, for convenience,
        rewrites them in the goal), and

      - if the equalities are not satisfiable (e.g., they involve
        things like [S n = O]), immediately solves the subgoal. *)

(** _Example_: If we invert a hypothesis built with [or], there are
    two constructors, so two subgoals get generated.  The
    conclusion (result type) of the constructor ([P \/ Q]) doesn't
    place any restrictions on the form of [P] or [Q], so we don't get
    any extra equalities in the context of the subgoal. *)

(** _Example_: If we invert a hypothesis built with [and], there is
    only one constructor, so only one subgoal gets generated.  Again,
    the conclusion (result type) of the constructor ([P /\ Q]) doesn't
    place any restrictions on the form of [P] or [Q], so we don't get
    any extra equalities in the context of the subgoal.  The
    constructor does have two arguments, though, and these can be seen
    in the context in the subgoal. *)

(** _Example_: If we invert a hypothesis built with [eq], there is
    again only one constructor, so only one subgoal gets generated.
    Now, though, the form of the [eq_refl] constructor does give us
    some extra information: it tells us that the two arguments to [eq]
    must be the same!  The [inversion] tactic adds this fact to the
    context. *)

(* ################################################################# *)
(** * The Coq Trusted Computing Base *)

(** One issue that arises with any automated proof assistant is
    "why trust it?": what if there is a bug in the implementation that
    renders all its reasoning suspect?

    While it is impossible to allay such concerns completely, the fact
    that Coq is based on the Curry-Howard correspondence gives it a
    strong foundation. Because propositions are just types and proofs
    are just terms, checking that an alleged proof of a proposition is
    valid just amounts to _type-checking_ the term.  Type checkers are
    relatively small and straightforward programs, so the "trusted
    computing base" for Coq -- the part of the code that we have to
    believe is operating correctly -- is small too.

    What must a typechecker do?  Its primary job is to make sure that
    in each function application the expected and actual argument
    types match, that the arms of a [match] expression are constructor
    patterns belonging to the inductive type being matched over and
    all arms of the [match] return the same type, and so on. *)

(** There are a few additional wrinkles:

    First, since Coq types can themselves be expressions, the checker
    must normalize these (by using the computation rules) before
    comparing them.

    Second, the checker must make sure that [match] expressions are
    _exhaustive_.  That is, there must be an arm for every possible
    constructor.  To see why, consider the following alleged proof
    object: *)

Fail Definition or_bogus : forall P Q, P \/ Q -> P :=
  fun (P Q : Prop) (A : P \/ Q) =>
    match A with
    | or_introl H => H
    end.

(** All the types here match correctly, but the [match] only
    considers one of the possible constructors for [or].  Coq's
    exhaustiveness check will reject this definition.

    Third, the checker must make sure that each recursive function
    terminates.  It does this using a syntactic check to make sure
    that each recursive call is on a subexpression of the original
    argument.  To see why this is essential, consider this alleged
    proof: *)

Fail Fixpoint infinite_loop {X : Type} (n : nat) {struct n} : X :=
  infinite_loop n.
Fail Definition falso : False := infinite_loop 0.

(** Recursive function [infinite_loop] purports to return a
    value of any type [X] that you would like.  (The [struct]
    annotation on the function tells Coq that it recurses on argument
    [n], not [X].)  Were Coq to allow [infinite_loop], then [falso]
    would be definable, thus giving evidence for [False].  So Coq rejects
    [infinite_loop]. *)

(** Note that the soundness of Coq depends only on the
    correctness of this typechecking engine, not on the tactic
    machinery.  If there is a bug in a tactic implementation (and this
    certainly does happen!), that tactic might construct an invalid
    proof term.  But when you type [Qed], Coq checks the term for
    validity from scratch.  Only theorems whose proofs pass the
    type-checker can be used in further proof developments.  *)

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


From mathcomp Require Import all_ssreflect.

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

(* csm_5_set_theory.v は不使用である。 *)

Section ライブラリfinsetの利用.
  Variable M : finType.

  Check setP : forall (T : finType) (A B : {set T}), A =i B <-> A = B. (* 定理 *)

  (* 有限集合の ∪ (:|:) と ∩ (:&:) を ∈ (\in) と || と && にする。 *)
  Check in_setU : forall (T : finType) (x : T) (A B : {set T}),
      (x \in A :|: B) = (x \in A) || (x \in B).

  Check in_setI : forall (T : finType) (x : T) (A B : {set T}),
      (x \in A :&: B) = (x \in A) && (x \in B).

  (* 実際は、inEだけ覚えておけばよい。 *)
  Check inE.                                (* 略 *)

  Lemma demorgan (A B C : {set M}) : (A :&: B) :|: C = (A :|: C) :&: (B :|: C).
  Proof.
    (* = を =i に変換する。 *)
    (* ``P =i Q`` は ``∀x, x \in P = x \in Q`` の構文糖衣である。 *)
    apply/setP => x.
    (* Goal : A :&: B :|: C =i (A :|: C) :&: (B :|: C) *)
    (* Goal : (x \in A :&: B :|: C) = (x \in (A :|: C) :&: (B :|: C)) *)

    (* Goal : (x \in A :&: B :|: C) = (x \in (A :|: C) :&: (B :|: C)) *)
    (* :|: と :&: を || と && に変換する。 *)
(*
    rewrite !in_setU.
    rewrite !in_setI.
    rewrite !in_setU.
    Undo 3.
*)
    rewrite !inE.
    (* Goal : (x \in A) && (x \in B) || (x \in C) =
       ((x \in A) || (x \in C)) && ((x \in B) || (x \in C)) *)

    (* || と && の ド・モルガンの定理 *)
    Check orb_andl : forall x y z : bool, x && y || z = (x || z) && (y || z).
      by rewrite -orb_andl.
  Qed.

End ライブラリfinsetの利用.

(* END *)


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_NCdistinct.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_ABB.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_conga_sss :
	forall A B C a b c,
	Cong A B a b->
	Cong A C a c ->
	Cong B C b c ->
	nCol A B C ->
	nCol a b c ->
	CongA A B C a b c.
Proof.
	intros A B C a b c.
	intros Cong_AB_ab.
	intros Cong_AC_ac.
	intros Cong_BC_bc.
	intros nCol_A_B_C.
	intros nCol_a_b_c.

	pose proof (
		lemma_NCdistinct _ _ _ nCol_A_B_C
	) as (_ & neq_B_C & _ & neq_B_A & _).
	pose proof (lemma_s_onray_assert_ABB _ _ neq_B_A) as OnRay_BA_A.
	pose proof (lemma_s_onray_assert_ABB _ _ neq_B_C) as OnRay_BC_C.

	pose proof (
		lemma_NCdistinct _ _ _ nCol_a_b_c
	) as (neq_a_b & neq_b_c & neq_a_c & neq_b_a & _).
	pose proof (lemma_s_onray_assert_ABB _ _ neq_b_a) as OnRay_ba_a.
	pose proof (lemma_s_onray_assert_ABB _ _ neq_b_c) as OnRay_bc_c.

	pose proof (lemma_congruenceflip _ _ _ _ Cong_AB_ab) as (Cong_BA_ba & _).

	unfold CongA.
	exists A, C, a, c.
	split.
	exact OnRay_BA_A.
	split.
	exact OnRay_BC_C.
	split.
	exact OnRay_ba_a.
	split.
	exact OnRay_bc_c.
	split.
	exact Cong_BA_ba.
	split.
	exact Cong_BC_bc.
	split.
	exact Cong_AC_ac.
	exact nCol_A_B_C.
Qed.

End Euclid.


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

 Hom functor for enriched categories

 Enrichments can also be formulated using functors and natural
 transformations. In this file, we show that every enrichment gives
 rise to a hom functor, and that the identity and composition give rise
 to natural transformations.

 Note that formulating enrichments using functors and natural
 transformations have additional laws, which expresses the
 functoriality and the naturality of the hom-functor and the identity
 and composition. The laws for enrichments have the same formulation
 irregardless of whether we use a formulation with functors and
 transformations or as given in Enrichments.v.

 Contents
 1. The enriched hom functor
 2. The transformation that is pointwise the enriched identity
 3. The transformation that is pointwise the enriched composition

 **********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Core.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.Monoidal.Categories.

Import MonoidalNotations.

Local Open Scope cat.
Local Open Scope moncat.

Local Notation "C ⊠ D" := (category_binproduct C D) (at level 38).

Section HomFunctor.
  Context {V : monoidal_cat}
          {C : category}
          (E : enrichment C V).

  (**
   1. The enriched hom functor
   *)
  Definition enriched_hom_functor_data
    : functor_data (category_binproduct C^op C) V.
  Proof.
    use make_functor_data.
    - exact (λ x, E ⦃ pr1 x , pr2 x ⦄).
    - exact (λ x y f, precomp_arr E (pr2 x) (pr1 f) · postcomp_arr E (pr1 y) (pr2 f)).
  Defined.

  Definition enriched_hom_functor_laws
    : is_functor enriched_hom_functor_data.
  Proof.
    split.
    - intros x ; cbn.
      rewrite precomp_arr_id, postcomp_arr_id.
      apply id_left.
    - intros x y z f g ; cbn.
      rewrite precomp_arr_comp, postcomp_arr_comp ; cbn.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      apply precomp_postcomp_arr.
  Qed.

  Definition enriched_hom_functor
    : category_binproduct C^op C ⟶ V.
  Proof.
    use make_functor.
    - exact enriched_hom_functor_data.
    - exact enriched_hom_functor_laws.
  Defined.

  (**
   2. The transformation that is pointwise the enriched identity
   *)
  Definition enriched_id_nat_trans_data
    : nat_trans_data
        (constant_functor (core C) V (I_{V}))
        (core_diag C ∙ enriched_hom_functor)
    := λ x, enriched_id E x.

  Definition enriched_id_nat_trans_laws
    : is_nat_trans
        _ _
        enriched_id_nat_trans_data.
  Proof.
    intros x y f ; unfold enriched_id_nat_trans_data ; cbn.
    rewrite id_left.
    rewrite !assoc.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      apply enriched_id_precomp_arr.
    }
    etrans.
    {
      apply enriched_from_arr_postcomp.
    }
    etrans.
    {
      apply maponpaths.
      exact (z_iso_after_z_iso_inv f).
    }
    apply enriched_from_arr_id.
  Qed.

  Definition enriched_id_nat_trans
    : constant_functor _ V (I_{V}) ⟹ core_diag _ ∙ enriched_hom_functor.
  Proof.
    use make_nat_trans.
    - exact enriched_id_nat_trans_data.
    - exact enriched_id_nat_trans_laws.
  Defined.

  (**
   3. The transformation that is pointwise the enriched composition
   *)
  Definition enriched_comp_nat_trans_left_functor
    : category_binproduct (category_binproduct C^op (core C)) C ⟶ V
    := bindelta_pair_functor
         (bindelta_pair_functor
            (pr1_functor _ _ ∙ pr2_functor _ _ ∙ functor_core_op _)
            (pr2_functor _ _)
            ∙ enriched_hom_functor)
         (bindelta_pair_functor
            (pr1_functor _ _ ∙ pr1_functor _ _)
            (pr1_functor _ _ ∙ pr2_functor _ _ ∙ functor_core _)
          ∙ enriched_hom_functor)
       ∙ monoidal_cat_tensor _.

  Definition enriched_comp_nat_trans_right_functor
    : C^op ⊠ core C ⊠ C ⟶ V
    := bindelta_pair_functor
         (pr1_functor _ _ ∙ pr1_functor _ _)
         (pr2_functor _ _)
       ∙ enriched_hom_functor.

  Definition enriched_comp_nat_trans_data
    : nat_trans_data
        enriched_comp_nat_trans_left_functor
        enriched_comp_nat_trans_right_functor
    := λ x, enriched_comp E (pr11 x) (pr21 x) (pr2 x).

  Definition enriched_comp_nat_trans_laws
    : is_nat_trans _ _ enriched_comp_nat_trans_data.
  Proof.
    intros x y f ; cbn.
    enough ((precomp_arr E (pr2 x) (inv_from_z_iso (pr21 f))
             · postcomp_arr E (pr21 y) (pr2 f))
            #⊗ (precomp_arr E (pr21 x) (pr11 f) · postcomp_arr E (pr11 y) (pr121 f))
            · enriched_comp_nat_trans_data y
            =
            enriched_comp_nat_trans_data x
            · precomp_arr E (pr2 x) (pr11 f)
            · postcomp_arr E (pr11 y) (pr2 f)) as X.
    {
      rewrite !assoc.
      exact X.
    }
    unfold enriched_comp_nat_trans_data.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      apply enriched_comp_precomp_arr.
    }
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply enriched_comp_postcomp_arr.
    }
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      exact (!(tensor_split _ _)).
    }
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply precomp_postcomp_arr.
      }
      apply tensor_comp_mor.
    }
    rewrite !assoc'.
    apply maponpaths.
    etrans.
    {
      apply maponpaths_2.
      apply tensor_split.
    }
    unfold precomp_arr.
    etrans.
    {
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      apply tensor_comp_id_r.
    }
    rewrite !assoc'.
    etrans.
    {
      do 2 apply maponpaths.
      apply enrichment_assoc.
    }
    rewrite !assoc.
    refine (_ @ id_left _).
    apply maponpaths_2.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_comp_id_r.
      }
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_lassociator.
      }
      rewrite !assoc'.
      apply maponpaths.
      exact (!(tensor_comp_id_l _ _)).
    }
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      apply mon_inv_triangle.
    }
    etrans.
    {
      apply maponpaths.
      exact (!(tensor_comp_id_l _ _)).
    }
    refine (!(tensor_comp_id_l _ _) @ _).
    refine (_ @ tensor_id_id _ _).
    apply maponpaths.
    refine (_ @ !(postcomp_arr_comp E (pr121 f) (inv_from_z_iso (pr21 f))) @ _).
    - apply maponpaths.
      rewrite !assoc.
      apply idpath.
    - etrans.
      {
        apply maponpaths.
        exact (z_iso_inv_after_z_iso (pr21 f)).
      }
      apply postcomp_arr_id.
  Qed.

  Definition enriched_comp_nat_trans
    : enriched_comp_nat_trans_left_functor ⟹ enriched_comp_nat_trans_right_functor.
  Proof.
    use make_nat_trans.
    - exact enriched_comp_nat_trans_data.
    - exact enriched_comp_nat_trans_laws.
  Defined.
End HomFunctor.


Require Import Lia Frap Datatypes.
Require Import Compare_dec.

Notation t := nat.

Inductive tree :=
| Leaf (* an empty tree *)
| Node (d : t) (l r : tree).

Notation compare := Compare_dec.lt_eq_lt_dec.
Notation Lt := (inleft (left _)) (only parsing).
Notation Eq := (inleft (right _)) (only parsing).
Notation Gt := (inright _) (only parsing).

Module Type S.
  Definition Singleton (v: t) := Node v Leaf Leaf.
  Parameter bst : forall (tr : tree) (s : t -> Prop), Prop.

  Parameter rotate : tree -> tree.

  (*[10%]*) Axiom bst_rotate : forall T s (H : bst T s), bst (rotate T) s.

  Fixpoint insert (a: t) (tr: tree) : tree :=
    match tr with
    | Leaf => Singleton a
    | Node v lt rt =>
      match compare a v with
      | Lt => Node v (insert a lt) rt
      | Eq => tr
      | Gt => Node v lt (insert a rt)
      end
    end.

  Fixpoint rightmost (tr: tree) : option t :=
    match tr with
    | Leaf => None
    | Node v _ rt =>
      match rightmost rt with
      | None => Some v
      | r => r
      end
    end.

  Definition is_leaf (tr : tree) : bool :=
    match tr with Leaf => true | _ => false end.

  Fixpoint delete_rightmost (tr: tree) : tree :=
    match tr with
    | Leaf => Leaf
    | Node v lt rt =>
      if is_leaf rt
      then lt
      else Node v lt (delete_rightmost rt)
    end.

  Definition merge_ordered lt rt :=
    match rightmost lt with
    | Some rv => Node rv (delete_rightmost lt) rt
    | None => rt
    end.

  Fixpoint delete (a: t) (tr: tree) : tree :=
    match tr with
    | Leaf => Leaf
    | Node v lt rt =>
      match compare a v with
      | Lt => Node v (delete a lt) rt
      | Eq => merge_ordered lt rt
      | Gt => Node v lt (delete a rt)
      end
    end.

  (*[40%]*) Axiom bst_insert :
    forall tr s a,
      bst tr s ->
      bst (insert a tr) (fun x => s x \/ x = a).

  (*[50%]*) Axiom bst_delete :
    forall tr s a, bst tr s ->
              bst (delete a tr) (fun x => s x /\ x <> a).
End S.

(* three-way comparisions and [cases] support for them *)
Ltac cases E :=
  (is_var E; destruct E) ||
    match type of E with
    | sumor (sumbool _ _) _ => destruct E as [[]|]
    | {_} + {_} => destruct E
    | _ => let Heq := fresh "Heq" in
           destruct E eqn:Heq
    end;
   repeat
    match goal with
    | H:_ = left _ |- _ => clear H
    | H:_ = right _ |- _ => clear H
    | H:_ = inleft _ |- _ => clear H
    | H:_ = inright _ |- _ => clear H
    end.


Require Export XR_Rplus_assoc.
Require Export XR_Rplus_0_l.
Require Export XR_Rplus_opp_l.
Require Export XR_Rplus_lt_compat_l.

Local Open Scope R_scope.

Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2.
Proof.
  intros x y z.
  intro h.
  pattern y ; rewrite <- Rplus_0_l.
  pattern z ; rewrite <- Rplus_0_l.
  rewrite <- Rplus_opp_l with x.
  repeat rewrite Rplus_assoc.
  apply Rplus_lt_compat_l.
  exact h.
Qed.


(* This file contains basic definitions and lemmas common to all other files in
  the repository. *)

Require Import vcfloat.VCFloat.

Definition rounded (t : type) r:=
(Generic_fmt.round Zaux.radix2 (SpecFloat.fexp (fprec t) (femax t))
     (BinarySingleNaN.round_mode BinarySingleNaN.mode_NE) r).

Definition neg_zero {t: type} := Binary.B754_zero (fprec t) (femax t) true.

Section NAN.

Definition default_rel (t: FPCore.type) : R :=
  / 2 * Raux.bpow Zaux.radix2 (- fprec t + 1).

Definition default_abs (t: FPCore.type) : R :=
  / 2 * Raux.bpow Zaux.radix2 (3 - femax t - fprec t).

Lemma default_rel_sep_0 t :
  default_rel t <> 0.
Proof.
unfold default_rel; apply Rabs_lt_pos.
rewrite Rabs_pos_eq; [apply Rmult_lt_0_compat; try nra; apply bpow_gt_0 |
  apply Rmult_le_pos; try nra; apply bpow_ge_0].
Qed.

Lemma default_rel_gt_0 t :
  0 < default_rel t.
Proof.
unfold default_rel.
apply Rmult_lt_0_compat; try nra.
apply bpow_gt_0.
Qed.

Lemma default_rel_ge_0 t :
  0 <= default_rel t.
Proof. apply Rlt_le; apply default_rel_gt_0; auto. Qed.

Lemma default_rel_plus_1_ge_1 t :
1 <= 1 + default_rel t.
Proof.
rewrite Rplus_comm.
apply Rcomplements.Rle_minus_l; field_simplify.
apply default_rel_ge_0.
Qed.

Lemma default_rel_plus_1_gt_1 t :
1 < 1 + default_rel t.
Proof.
rewrite Rplus_comm.
apply Rcomplements.Rlt_minus_l; field_simplify.
apply default_rel_gt_0.
Qed.

Lemma default_rel_plus_1_gt_0 t :
0 < 1 + default_rel t.
Proof.
eapply Rlt_trans with 1; [nra | ].
apply default_rel_plus_1_gt_1.
Qed.

Lemma default_rel_plus_1_ge_1' t n:
1 <= (1 + default_rel t) ^ n.
Proof.
induction n; simpl; auto; try nra.
eapply Rle_trans with (1 * 1); try nra.
apply Rmult_le_compat; try nra.
apply default_rel_plus_1_ge_1.
Qed.

Lemma default_abs_gt_0 t :
  0 < default_abs t.
Proof.
unfold default_abs.
apply Rmult_lt_0_compat; try nra.
apply bpow_gt_0.
Qed.

Lemma default_abs_ge_0 t :
  0 <= default_abs t.
Proof. apply Rlt_le; apply default_abs_gt_0; auto. Qed.

Definition g (t: type) (n: nat) : R := ((1 + (default_rel t )) ^ n - 1).

Lemma g_pos t n:
  0 <= g t n.
Proof.
unfold g. induction n.
simpl; nra. eapply Rle_trans; [apply IHn| apply Rplus_le_compat; try nra].
simpl. eapply Rle_trans with (1 * (1+default_rel t)^n); try nra.
apply Rmult_le_compat; try nra. rewrite Rplus_comm. apply Rcomplements.Rle_minus_l.
field_simplify. apply default_rel_ge_0.
Qed.

Lemma le_g_Sn t n :
  g t n <= g t (S n).
Proof.
induction n; unfold g; simpl.
  { field_simplify. apply default_rel_ge_0. }
  unfold g in IHn. eapply Rplus_le_compat; try nra.
  eapply Rmult_le_compat_l.
  apply Rplus_le_le_0_compat; try nra; try apply default_rel_ge_0.
  rewrite tech_pow_Rmult. apply Rle_pow; try lia.
  rewrite Rplus_comm. apply Rcomplements.Rle_minus_l.
  field_simplify; apply default_rel_ge_0.
Qed.

Lemma d_le_g t n:
default_rel t <= g t (n + 1).
Proof. unfold g. induction n; simpl; field_simplify; try nra.
eapply Rle_trans; [apply IHn|].
apply Rplus_le_compat_r.
replace (default_rel t * (1 + default_rel t) ^ (n + 1) + (1 + default_rel t) ^ (n + 1))
with
((1 + default_rel t) ^ (n + 1) * (default_rel t  + 1)) by nra.
eapply Rle_trans with ((1 + default_rel t) ^ (n + 1) * 1); try nra.
eapply Rmult_le_compat; try nra.
{ apply pow_le. apply Fourier_util.Rle_zero_pos_plus1. apply default_rel_ge_0. }
apply Rcomplements.Rle_minus_l. field_simplify; apply default_rel_ge_0.
Qed.

Lemma d_le_g_1 t n:
(1<= n)%nat -> default_rel t <= g t n.
Proof.
intros; unfold g.
eapply Rle_trans with ((1 + default_rel t)^1 - 1).
field_simplify; nra.
apply Rplus_le_compat; try nra.
apply Rle_pow; try lia.
apply default_rel_plus_1_ge_1.
Qed.

Lemma one_plus_d_mul_g t a n:
  (1 + default_rel t) * g t n * a + default_rel t * a  = g t (n + 1) * a.
Proof. unfold g. rewrite Rmult_minus_distr_l. rewrite tech_pow_Rmult.
field_simplify. f_equal. rewrite Rmult_comm; repeat f_equal; lia.
Qed.

Definition g1 (t: type) (n1: nat) (n2: nat) : R :=
  INR n1 * default_abs t * (1 + g t n2 ).

Lemma g1_pos t n m : 0 <= g1 t n m.
Proof. unfold g1.
apply Rmult_le_pos; try apply pos_INR.
apply Rmult_le_pos; try apply pos_INR.
apply default_abs_ge_0. unfold g; field_simplify.
apply pow_le.
apply Fourier_util.Rle_zero_pos_plus1.
apply default_rel_ge_0.
Qed.

Lemma one_plus_d_mul_g1 t n:
(1 <= n )%nat ->
g1 t n (n - 1) * (1 + default_rel t)  =  g1 t n n.
Proof.
intros.
unfold g1, g; field_simplify.
symmetry. replace n with (S (n-1)) at 2.
rewrite <- tech_pow_Rmult.
field_simplify; nra.
rewrite <- Nat.sub_succ_l; auto.
simpl; lia.
Qed.

Lemma one_plus_d_mul_g1' t n m:
g1 t n m * (1 + default_rel t)  =  g1 t n (S m).
Proof.
intros.
unfold g1, g; field_simplify.
symmetry.
rewrite <- tech_pow_Rmult.
field_simplify; nra.
Qed.

Lemma e_le_g1 t n:
(1 <= n )%nat ->
default_abs t <= g1 t n n.
Proof.
intros; unfold g1. eapply Rle_trans with (1 * default_abs t * 1); try nra.
apply Rmult_le_compat; try nra.
rewrite Rmult_1_l.
apply default_abs_ge_0.
apply Rmult_le_compat; try nra.
apply default_abs_ge_0.
replace 1 with (INR 1) by (simpl; nra).
apply le_INR; auto.
rewrite Rplus_comm.
apply Rcomplements.Rle_minus_l.
field_simplify; apply g_pos.
Qed.

Lemma plus_d_e_g1_le' t n m:
(1 <= n )%nat -> (1 <= m)%nat ->
g1 t n m + (1 + default_rel t) * default_abs t <= g1 t (S n) m.
Proof.
intros; replace (S n) with (n + 1)%nat by lia.
unfold g1; field_simplify.
replace (INR (n + 1)) with (INR n + 1).
rewrite !Rmult_plus_distr_l.
rewrite !Rmult_1_r. rewrite <- Rplus_assoc.
apply Rplus_le_compat_r.
rewrite Rplus_comm.
rewrite Rmult_comm.
rewrite Rplus_comm.
rewrite Rmult_assoc.
rewrite  Rmult_comm.
rewrite !Rplus_assoc.
apply Rplus_le_compat_l.
rewrite  Rmult_comm.
rewrite Rplus_comm.
apply Rplus_le_compat_r.
rewrite  Rmult_comm.
apply Rmult_le_compat_l.
apply default_abs_ge_0.
apply d_le_g_1; auto.
rewrite Nat.add_comm.
rewrite S_O_plus_INR. simpl; nra.
Qed.

Lemma mult_d_e_g1_le' t n m:
(1 <= n )%nat -> (1 <= m)%nat ->
g1 t n m * (1 + default_rel t)  + default_abs t <= g1 t (S n) (S m).
Proof.
intros; replace (S n) with (n + 1)%nat by lia.
replace (S m) with (m + 1)%nat by lia.
unfold g1, g; field_simplify.
replace (INR (n + 1)) with (INR n + 1) by
  (rewrite Nat.add_comm; rewrite S_O_plus_INR; simpl; nra).
replace (INR (m + 1)) with (INR m + 1) by
  (rewrite Nat.add_comm; rewrite S_O_plus_INR; simpl; nra).
rewrite !Rmult_plus_distr_l.
rewrite !Rmult_1_r. replace
(INR n * default_abs t * (1 + default_rel t) ^ m * default_rel t +
INR n * default_abs t * (1 + default_rel t) ^ m) with
(INR n * default_abs t * (1 + default_rel t) ^ m * (1 + default_rel t)) by nra.
rewrite !Rmult_plus_distr_r.
apply Rplus_le_compat.
rewrite !Rmult_assoc.
rewrite Rmult_comm.
rewrite !Rmult_assoc.
apply Rmult_le_compat_l.
apply default_abs_ge_0.
rewrite <- !Rmult_assoc.
rewrite Rmult_comm.
apply Rmult_le_compat_l; [apply pos_INR| ].
rewrite Rmult_comm.
rewrite tech_pow_Rmult.
replace (S m) with (m + 1)%nat by lia; nra.
replace (default_abs t) with (default_abs t * 1) at 1 by nra.
apply Rmult_le_compat_l; [apply  default_abs_ge_0 | ].
apply default_rel_plus_1_ge_1'.
Qed.

Lemma plus_d_e_g1_le t n:
(1 <= n )%nat ->
g1 t n n + (1 + default_rel t) * default_abs t <= g1 t (S n) n.
Proof.
pose proof plus_d_e_g1_le' t n n; auto.
Qed.

Lemma plus_e_g1_le t n:
g1 t n n + default_abs t <= g1 t (S n) n.
Proof.
replace (S n) with (n + 1)%nat by lia.
unfold g1; field_simplify.
replace (INR (n + 1)) with (INR n + 1).
rewrite !Rmult_plus_distr_l.
rewrite !Rmult_1_r. rewrite <- Rplus_assoc.
apply Rplus_le_compat_r.
rewrite Rplus_comm.
rewrite Rmult_comm.
rewrite Rplus_comm.
apply Rplus_le_compat_r.
eapply Rle_trans with (default_abs t * INR n * g t n + 0); try nra.
apply Rplus_le_compat; try nra.
apply Rmult_le_pos.
apply default_abs_ge_0.
apply g_pos.
rewrite Nat.add_comm.
rewrite S_O_plus_INR. simpl; nra.
Qed.

Lemma g1n_le_g1Sn t n:
(1 <= n )%nat ->
g1 t n (n - 1) <= g1 t (S n) (S (n - 1)).
Proof.
intros;
replace (S n) with (n + 1)%nat by lia.
unfold g1; field_simplify.
replace (INR (n + 1)) with (INR n + 1).
rewrite !Rmult_plus_distr_l.
rewrite !Rmult_1_r.
apply Rplus_le_compat.
apply Rmult_le_compat; [
apply Rmult_le_pos; [apply pos_INR | apply default_abs_ge_0 ] |
  apply g_pos | | ].
rewrite Rplus_comm;
apply Rcomplements.Rle_minus_l; field_simplify; apply default_abs_ge_0.
replace ((n + 1 - 1))%nat with (S (n-1))%nat by lia.
apply le_g_Sn.
rewrite Rplus_comm;
apply Rcomplements.Rle_minus_l; field_simplify; apply default_abs_ge_0.
rewrite Nat.add_comm.
rewrite S_O_plus_INR. simpl; nra.
Qed.

Lemma Rplus_le_lt_compat a1 a2 b1 b2 :
 a1 <= a2 -> b1 < b2 ->  a1 + b1 < a2 + b2.
Proof.  nra. Qed.

Lemma g1n_lt_g1Sn t n:
(1 <= n )%nat ->
g1 t n (n - 1) < g1 t (S n) (S (n - 1)).
Proof.
intros;
replace (S n) with (n + 1)%nat by lia.
unfold g1; field_simplify.
replace (INR (n + 1)) with (INR n + 1).
rewrite !Rmult_plus_distr_l.
rewrite !Rmult_1_r.
assert (INR n * default_abs t < default_abs t * INR n + default_abs t).
{ apply Rle_lt_trans with (INR n * default_abs t + 0) ; try nra.
apply Rplus_le_lt_compat; try nra.
apply default_abs_gt_0. }
apply Rplus_le_lt_compat; try nra.
apply Rmult_le_compat; [
apply Rmult_le_pos; [apply pos_INR | apply default_abs_ge_0 ] |
  apply g_pos | | ].
rewrite Rplus_comm;
apply Rcomplements.Rle_minus_l; field_simplify; apply default_abs_ge_0.
apply le_g_Sn.
rewrite Nat.add_comm.
rewrite S_O_plus_INR. simpl; nra.
Qed.

Definition error_rel (t: type) (n: nat) (r : R) : R :=
  let e := default_abs t in
  let d := default_rel t in
  if (1 <=? Z.of_nat n) then
    (g t (n-1)) * (Rabs r + e/d)
  else 0%R.

End NAN.


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

Require Import Arith Omega List Permutation.

Require Import tacs rel_utils list_utils.

Require Import formula sequent_rules.
Require Import relevant_LR1 mini_LI1.

Set Implicit Arguments.

Section Relational_phase_semantics.

  Variable M : Type.

  Implicit Types A B C : M -> Prop.

  Variable cl : (M -> Prop) -> (M -> Prop).

  Hypothesis cl_increase   : forall A, A inc1 cl A.
  Hypothesis cl_monotone   : forall A B, A inc1 B -> cl A inc1 cl B.
  Hypothesis cl_idempotent : forall A, cl (cl A) inc1 cl A.

  Proposition cl_prop A B : A inc1 cl B <-> cl A inc1 cl B.
  Proof.
    split; intros H x Hx.
    apply cl_idempotent; revert Hx; apply cl_monotone; auto.
    apply H, cl_increase; auto.
  Qed.

  Definition cl_inc A B := proj1 (cl_prop A B).
  Definition inc_cl A B := proj2 (cl_prop A B).

  Fact cl_eq1 A B : A ~eq1 B -> cl A ~eq1 cl B.
  Proof.
    intros []; split; apply cl_monotone; auto.
  Qed.

  Hint Resolve cl_inc cl_eq1 : core. (* inc_cl. *)

  Notation closed := (fun x : M -> Prop => cl x inc1 x).

  Fact cl_closed A B : closed B -> A inc1 B -> cl A inc1 B.
  Proof.
    intros H1 H2.
    apply inc1_trans with (2 := H1), cl_inc,
          inc1_trans with (1 := H2), cl_increase.
  Qed.

  (* this is a relational/non-deterministic monoid *)

  Variable Compose : M -> M -> M -> Prop.

  (* Composition lifted to predicates *)

  Inductive Composes (A B : M -> Prop) : M -> Prop :=
    In_composes : forall a b c, A a -> B b -> Compose a b c -> Composes A B c.

  Infix "ø" := Composes (at level 50, no associativity).

  Proposition composes_monotone A A' B B' : A inc1 A' -> B inc1 B' ->  A ø B inc1 A' ø B'.
  Proof. intros ? ? _ [ ? ? ? ? ? H ]; apply In_composes with (3 := H); auto. Qed.

  Hint Resolve composes_monotone : core.

  Variable e : M.

  (* Stability is the important axiom in phase semantics *)

  Definition cl_stability   := forall A B, cl A ø cl B inc1 cl (A ø B).
  Definition cl_stability_l := forall A B, cl A ø    B inc1 cl (A ø B).
  Definition cl_stability_r := forall A B,    A ø cl B inc1 cl (A ø B).

  Proposition cl_stable_imp_stable_l : cl_stability -> cl_stability_l.
  Proof.
    intros H ? ? x Hx.
    apply H; revert x Hx.
    apply composes_monotone; auto.
  Qed.

  Proposition cl_stable_imp_stable_r : cl_stability -> cl_stability_r.
  Proof.
    intros H ? ? x Hx.
    apply H; revert x Hx.
    apply composes_monotone; auto.
  Qed.

  Proposition cl_stable_lr_imp_stable : cl_stability_l -> cl_stability_r -> cl_stability.
  Proof.
    intros H1 H2 A B x Hx.
    apply cl_idempotent.
    generalize (H1 _ _ _ Hx).
    apply cl_monotone, H2.
  Qed.

  Hint Resolve cl_stable_imp_stable_l cl_stable_imp_stable_r cl_stable_lr_imp_stable : core.

  Notation sg := (@eq _).

  Definition cl_neutrality_1 := forall a, cl (sg e ø sg a) a.
  Definition cl_neutrality_2 := forall a, sg e ø sg a inc1 cl (sg a).
  Definition cl_commutativity := forall a b, sg a ø sg b inc1 cl (sg b ø sg a).
  Definition cl_associativity := forall a b c, sg a ø (sg b ø sg c) inc1 cl ((sg a ø sg b) ø sg c).

  Hypothesis cl_commute : cl_commutativity.

  Fact sg_inc1 (A : M -> Prop) : forall x, A x -> sg x inc1 A.
  Proof. intros ? ? ? []; trivial. Qed.

  Proposition composes_commute_1 A B : A ø B inc1 cl (B ø A).
  Proof.
    intros _ [ a b c Ha Hb Hc ].
    apply cl_monotone with (sg b ø sg a).
    apply composes_monotone; apply sg_inc1; auto.
    apply cl_commute.
    constructor 1 with (3 := Hc); auto.
  Qed.

  Hint Resolve composes_commute_1 : core.

  Proposition composes_commute A B : cl (A ø B) ~eq1 cl (B ø A).
  Proof.
    split; intros x Hx; apply cl_idempotent; revert Hx; apply cl_monotone; auto.
  Qed.

  Proposition cl_stable_l_imp_r : cl_stability_l -> cl_stability_r.
  Proof.
    intros Hl A B x Hx.
    apply cl_idempotent.
    apply cl_monotone with (cl B ø A).
    apply inc1_trans with (cl ((cl B) ø A)); auto.
    rewrite <- cl_prop; auto.
    generalize (@composes_commute_1 B A); intros H.
    rewrite cl_prop in H; auto.
    apply composes_commute_1; auto.
  Qed.

  Proposition cl_stable_r_imp_l : cl_stability_r -> cl_stability_l.
  Proof.
    intros Hl A B.
    generalize (@composes_commute_1 B A); intros H.
    rewrite cl_prop in H; auto.
    apply inc1_trans with (B := cl (B ø cl A)),
          inc1_trans with (2 := H); auto.
    rewrite <- cl_prop; apply Hl.
  Qed.

  Hint Resolve cl_stable_l_imp_r cl_stable_r_imp_l : core.

  Proposition cl_stable_l_imp_stable : cl_stability_l -> cl_stability.    Proof. auto. Qed.
  Proposition cl_stable_r_imp_stable : cl_stability_r -> cl_stability.    Proof. auto. Qed.

  Hypothesis cl_stable_l : cl_stability_l.

  Proposition cl_stable_r : cl_stability_r.                               Proof. auto. Qed.
  Proposition cl_stable : cl_stability.                                   Proof. auto. Qed.

  Hint Resolve cl_stable_r cl_stable : core.

  Hypothesis cl_neutral_1 : cl_neutrality_1.
  Hypothesis cl_neutral_2 : cl_neutrality_2.
  Hypothesis cl_associative : cl_associativity.

  Definition Magicwand A B k := sg k ø A inc1 B.
  Infix "-ø" := Magicwand (at level 51, right associativity).

  Proposition magicwand_spec A B C : A ø B inc1 C <-> A inc1 B -ø C.
  Proof.
    split; intros H x Hx.
    intros y Hy; apply H; revert Hy; apply composes_monotone; auto.
    apply sg_inc1; auto.
    destruct Hx as [ a b x Ha Hb Hx ].
    apply (H _ Ha).
    constructor 1 with a b; auto.
  Qed.

  Definition magicwand_adj_1 A B C := proj1 (magicwand_spec A B C).
  Definition magicwand_adj_2 A B C := proj2 (magicwand_spec A B C).

(*  Hint Resolve magicwand_adj_1 magicwand_adj_2. *)

  Proposition magicwand_monotone A A' B B' : A inc1 A' -> B inc1 B' -> A' -ø B inc1 A -ø B'.
  Proof.
    intros ? HB; apply magicwand_adj_1, inc1_trans with (2 := HB).
    intros _ [? ? ? Ha ? Hc]; apply Ha, In_composes with (3 := Hc); auto.
  Qed.

  Hint Resolve magicwand_monotone : core.

  Proposition cl_magicwand_1 X Y : cl (X -ø cl Y) inc1 X -ø cl Y.
  Proof.
    apply magicwand_adj_1,
          inc1_trans with (B := cl ((X -ø cl Y) ø X)); auto.
    rewrite <- cl_prop; apply magicwand_spec; auto.
  Qed.

  Proposition cl_magicwand_2 X Y : cl X -ø Y inc1 X -ø Y.
  Proof.
    apply magicwand_monotone; auto.
  Qed.

  Hint Immediate cl_magicwand_1 cl_magicwand_2 : core.

  Proposition cl_magicwand_3 X Y : X -ø cl Y inc1 cl X -ø cl Y.
  Proof.
    intros c Hc y.
    apply inc1_trans with (B := cl (sg c ø X)); auto.
    rewrite <- cl_prop.
    intros ? [ a b d [] Hb ].
    intros; apply Hc.
    constructor 1 with c b; auto.
  Qed.

  Hint Immediate cl_magicwand_3 : core.

  Proposition closed_magicwand X Y : closed Y -> closed (X -ø Y).
  Proof.
    simpl; intros ?.
    apply inc1_trans with (B := cl (X -ø cl Y)); auto.
    apply cl_monotone, magicwand_monotone; auto.
    apply inc1_trans with (B := X -ø cl Y); auto.
    apply magicwand_monotone; auto.
  Qed.

  Hint Resolve closed_magicwand : core.

  Proposition magicwand_eq_1 X Y : X -ø cl Y ~eq1 cl X -ø cl Y.
  Proof. split; auto. Qed.

  Proposition magicwand_eq_2 X Y : cl (X -ø cl Y) ~eq1 X -ø cl Y.
  Proof. split; auto. Qed.

  Proposition magicwand_eq_3 X Y : cl (X -ø cl Y) ~eq1 cl X -ø cl Y.
  Proof.
    split; auto.
    apply inc1_trans with (B := X -ø cl Y); auto.
  Qed.

  Hint Resolve magicwand_eq_1 magicwand_eq_2 magicwand_eq_3 : core.

  Proposition cl_equiv_2 X Y : cl (cl X ø Y) ~eq1 cl (X ø Y).
  Proof.
    split.
    rewrite <- cl_prop; auto.
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Proposition cl_equiv_3 X Y : cl (X ø cl Y) ~eq1 cl (X ø Y).
  Proof.
    split.
    rewrite <- cl_prop; auto.
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Proposition cl_equiv_4 X Y : cl (cl X ø cl Y) ~eq1 cl (X ø Y).
  Proof.
    split.
    rewrite <- cl_prop; auto.
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Hint Immediate cl_equiv_2 cl_equiv_3 cl_equiv_4 : core.

  Proposition composes_associative_1 A B C : A ø (B ø C) inc1 cl ((A ø B) ø C).
  Proof.
    intros _ [a _ k Ha [b c y Hb Hc Hy] Hk].
    generalize (@cl_associative a b c k); intros H.
    spec_all H.
    apply In_composes with (3 := Hk); auto.
    apply In_composes with (3 := Hy); auto.
    revert H.
    apply cl_monotone.
    repeat apply composes_monotone; apply sg_inc1; auto.
  Qed.

  Hint Immediate composes_associative_1 : core.

  Proposition composes_associative A B C : cl (A ø (B ø C)) ~eq1 cl ((A ø B) ø C).
  Proof.
    split; auto.
    rewrite <- cl_prop; auto.
    rewrite <- cl_prop; auto.
    apply inc1_trans with (1 := @composes_commute_1 _ _).
    rewrite <- cl_prop.
    apply inc1_trans with (B := C ø cl (A ø B)); auto.
    apply composes_monotone; auto.
    apply inc1_trans with (B := C ø cl (B ø A)); auto.
    apply composes_monotone; auto.
    apply composes_commute.
    apply inc1_trans with (1 := @cl_stable_r _ _).
    rewrite <- cl_prop.
    apply inc1_trans with (1 := @composes_associative_1 _ _ _).
    rewrite <- cl_prop.
    apply inc1_trans with (1 := @composes_commute_1 _ _).
    rewrite <- cl_prop.
    apply inc1_trans with (B := A ø cl (C ø B)); auto.
    apply composes_monotone; auto.
    apply inc1_trans with (B := A ø cl (B ø C)); auto.
    apply composes_monotone; auto.
    apply composes_commute.
  Qed.

  Hint Immediate composes_associative : core.

  Proposition composes_congruent_1 A B C : A inc1 cl B -> C ø A inc1 cl (C ø B).
  Proof.
    intros ?.
    apply inc1_trans with (B := cl (C ø cl B)); auto.
    apply cl_prop, cl_monotone, composes_monotone; auto.
    apply cl_equiv_3.
  Qed.

  Hint Resolve composes_congruent_1 : core.

  Proposition composes_congruent A B C : cl A ~eq1 cl B -> cl (C ø A) ~eq1 cl (C ø B).
  Proof.
    intros [H1 H2].
    rewrite <- cl_prop in H1.
    rewrite <- cl_prop in H2.
    split; rewrite <- cl_prop;
    apply inc1_trans with (2 := @cl_stable_r _ _), composes_monotone; auto.
  Qed.

  Proposition composes_assoc_special A A' B B' : cl((A ø A') ø (B ø B')) ~eq1 cl ((A ø B) ø (A' ø B')).
  Proof.
    do 2 apply eq1_sym, eq1_trans with (2 := composes_associative _ _ _).
    apply composes_congruent.
    apply eq1_sym, eq1_trans with (1 := composes_commute _ _).
    apply eq1_sym, eq1_trans with (2 := composes_associative _ _ _).
    apply composes_congruent, composes_commute.
  Qed.

  Definition composes_assoc_special_1 A A' B B' := proj1 (composes_assoc_special A A' B B').

  Proposition composes_neutral_1 A : A inc1 cl (sg e ø A).
  Proof.
    intros a Ha.
    generalize (cl_neutral_1 a).
    apply cl_monotone, composes_monotone; auto.
    apply sg_inc1; auto.
  Qed.

  Proposition composes_neutral_2 A : sg e ø A inc1 cl A.
  Proof.
    intros _ [y a x [] Ha Hx].
    generalize (@cl_neutral_2 a x); intros H.
    spec_all H.
    constructor 1 with e a; auto.
    revert H; apply cl_monotone, sg_inc1; auto.
  Qed.

  Hint Resolve composes_neutral_1 composes_neutral_2 : core.

  Proposition composes_neutral A : cl (sg e ø A) ~eq1 cl A.
  Proof. split; rewrite <- cl_prop; auto. Qed.

  Notation "x 'glb' y " := (x cap1 y) (at level 60, no associativity).
  Notation "x 'lub' y" := (cl (x cup1 y)) (at level 60, no associativity).

  Proposition closed_glb A B : closed A -> closed B -> closed (A glb B).
  Proof.
    simpl; intros HA HB x Hx; split;
      [ apply HA | apply HB ]; revert x Hx;
      apply cl_monotone; tauto.
  Qed.

  Proposition lub_out A B C : closed C -> A inc1 C -> B inc1 C -> A lub B inc1 C.
  Proof.
    simpl.
    intros H1 H2 H3.
    apply inc1_trans with (2 := H1), cl_monotone.
    intros ? [ ]; auto.
  Qed.

  Proposition glb_in A B C : C inc1 A -> C inc1 B -> C inc1 A glb B.
  Proof. simpl; split; auto. Qed.

  Proposition closed_lub A B : closed (cl (A cup1 B)).     Proof. simpl; apply cl_idempotent. Qed.
  Proposition glb_out_l A B  : A glb B inc1 A .            Proof. simpl; tauto. Qed.
  Proposition glb_out_r A B  : A glb B inc1 B.             Proof. simpl; tauto. Qed.
  Proposition lub_in_l A B   : A inc1 A lub B.             Proof. apply inc1_trans with (2 := cl_increase _); tauto. Qed.
  Proposition lub_in_r A B   : B inc1 A lub B.             Proof. apply inc1_trans with (2 := cl_increase _); tauto. Qed.

  Notation "x '**' y " := (cl (x ø y)) (at level 59).

  Proposition closed_times A B : closed (A ** B).
  Proof. simpl; apply cl_idempotent. Qed.

  Proposition times_monotone A A' B B' : A inc1 A' -> B inc1 B' -> A ** B inc1 A' ** B'.
  Proof. simpl; intros ? ?; apply cl_monotone, composes_monotone; auto. Qed.

  Notation top := (fun _ : M => True).
  Notation bot := (cl (fun _ => False)).
  Notation unit := (cl (sg e)).

  Proposition closed_top     : closed top.         Proof. simpl; intros; auto. Qed.
  Proposition closed_bot     : closed bot.         Proof. simpl; apply cl_idempotent. Qed.
  Proposition closed_unit    : closed unit.        Proof. simpl; apply cl_idempotent. Qed.
  Proposition top_greatest A : A inc1 top.         Proof. simpl; tauto. Qed.

  Proposition bot_least A : closed A -> bot inc1 A.
  Proof. intro H; apply inc1_trans with (2 := H), cl_monotone; tauto. Qed.

  Proposition unit_neutral_1 A : closed A -> unit ** A inc1 A.
  Proof.
    intros H; apply inc1_trans with (2 := H).
    rewrite <- cl_prop.
    apply inc1_trans with (1 := @cl_stable_l _ _).
    rewrite <- cl_prop.
    apply composes_neutral_2.
  Qed.

  Proposition unit_neutral_2 A : A inc1 unit ** A.
  Proof.
    intros a Ha; simpl.
    generalize (composes_neutral_1 _ _ Ha).
    apply cl_monotone, composes_monotone; auto.
  Qed.

(*  Hint Resolve unit_neutral_1 unit_neutral_2. *)

  Proposition unit_neutral A : closed A -> unit ** A ~eq1 A.
  Proof.
    intros H; split.
    revert H; apply unit_neutral_1.
    apply unit_neutral_2.
  Qed.

  Proposition times_commute_1 A B : A ** B inc1 B ** A.
  Proof. simpl; apply cl_inc, composes_commute_1. Qed.

  Hint Resolve unit_neutral times_commute_1 : core.

  Proposition times_commute A B : A ** B ~eq1 B ** A.
  Proof. split; auto. Qed.

  Proposition unit_neutral' A : closed A -> A ** unit ~eq1 A.
  Proof. intros ?; apply eq1_trans with (1 := times_commute _ _); auto. Qed.

  Proposition times_associative A B C : ((A ** B) ** C) ~eq1 (A ** (B ** C)).
  Proof.
    apply eq1_sym, eq1_trans with (1 := cl_equiv_3 _ _ ).
    apply eq1_sym, eq1_trans with (1 := cl_equiv_2 _ _ ).
    apply eq1_sym, composes_associative.
  Qed.

  Proposition times_associative_1 A B C : (A ** B) ** C inc1 A ** (B ** C).
  Proof. apply times_associative. Qed.

  Proposition times_associative_2 A B C : A ** (B ** C) inc1 (A ** B) ** C.
  Proof. apply times_associative. Qed.

  Hint Resolve times_associative_1 times_associative_2 : core.

  Proposition times_congruence A A' B B' : A ~eq1 A' -> B ~eq1 B' -> A ** B ~eq1 A' ** B'.
  Proof.
    intros H1 H2.
    apply eq1_trans with (A ** B').
    apply composes_congruent; auto.
    do 2 apply eq1_sym, eq1_trans with (1 := times_commute _ _).
    apply composes_congruent; auto.
  Qed.

  Proposition adjunction_1 A B C : closed C -> A ** B inc1 C -> A inc1 B -ø C.
  Proof. intros ? H; apply magicwand_adj_1, inc1_trans with (2 := H); auto. Qed.

  Proposition adjunction_2 A B C : closed C -> A inc1 B -ø C -> A ** B inc1 C.
  Proof. intros H ?; apply inc1_trans with (2 := H), cl_monotone, magicwand_adj_2; auto. Qed.

  Hint Resolve times_congruence adjunction_1 (* adjunction_2 *) : core.

  Proposition adjunction A B C : closed C -> (A ** B inc1 C <-> A inc1 B -ø C).
  Proof.
    split; [ apply adjunction_1 | apply  adjunction_2 ]; auto.
  Qed.

  Proposition times_bot_distrib_l A : bot ** A inc1 bot.
  Proof.
    apply adjunction_2; auto.
    apply bot_least; auto.
  Qed.

  Proposition times_bot_distrib_r A : A ** bot inc1 bot.
  Proof. apply inc1_trans with (1 := @times_commute_1 _ _), times_bot_distrib_l. Qed.

  Hint Immediate times_bot_distrib_l times_bot_distrib_r : core.

  Proposition times_lub_distrib_l A B C : (A lub B) ** C inc1 (A ** C) lub (B ** C).
  Proof.
    apply adjunction, lub_out; auto;
    apply adjunction; auto.
  Qed.

  Proposition times_lub_distrib_r A B C : C ** (A lub B) inc1 (C ** A) lub (C ** B).
  Proof.
    apply inc1_trans with (1 := @times_commute_1 _ _),
          inc1_trans with (1 := @times_lub_distrib_l _ _ _); auto.
    apply lub_out; auto.
  Qed.

  Reserved Notation "'[[' x ']]'" (at level 50).
  Reserved Notation "'[|' x '|]'" (at level 50).

  Variable (v : Var -> M -> Prop) (Hv : forall x, cl (v x) inc1 v x).

  Fixpoint Form_sem f :=
    match f with
      | £ x    => v x
      | a %> b => [[a]] -ø [[b]]
    end
  where "[[ a ]]" := (Form_sem a).

  Fact cl_Form_sem f : cl ([[f]]) inc1 [[f]].
  Proof.
    induction f; simpl; auto.
  Qed.

  Fixpoint FList_sem ll :=
    match ll with
      | nil   => unit
      | x::ll => [[x]] ** [|ll|]
    end
  where "[| ll |]" := (FList_sem ll).

  Fact cl_FList_sem ll : cl ([|ll|]) inc1 [|ll|].
  Proof.
    induction ll; simpl; auto.
  Qed.

  Hint Resolve cl_Form_sem cl_FList_sem : core.

  Fact FList_sem_app l m : [|l++m|] ~eq1 [|l|] ** [|m|].
  Proof.
    induction l; simpl.
    apply eq1_sym, unit_neutral; auto.
    apply eq1_sym, eq1_trans with (1 := @times_associative _ _ _), eq1_sym.
    apply times_congruence; auto.
  Qed.

  Fact FList_sem_perm l m : l ~p m -> [|l|] ~eq1 [|m|].
  Proof.
    induction 1 as [ | x l m _ IHl | x y l | l m k ]; auto.
    apply composes_congruent, cl_eq1; auto.
    simpl; do 2 apply eq1_sym, eq1_trans with (2 := @times_associative _ _ _).
    apply times_congruence; auto.
    apply eq1_trans with ([|m|]); auto.
  Qed.

  Definition cl_weak_hyp := forall x, cl (sg e) x.
  Definition cl_cntr_hyp := forall x, cl (sg x ø sg x) x.

  Hypothesis cl_weak : cl_weak_hyp.
  Hypothesis cl_cntr : cl_cntr_hyp.

  Proposition cl_weakening A : A inc1 unit.
  Proof.
    intros x Hx.
    apply cl_weak.
  Qed.

  Proposition cl_contract A : A inc1 A ** A.
  Proof.
    intros x Hx.
    generalize (cl_cntr x).
    apply times_monotone;
    intros ? []; auto.
  Qed.

  Theorem sem_LR1_sound : forall s, LR1_provable s -> [|fst s|] inc1 [[snd s]].
  Proof.
    induction 1 as [ A
                   | ga A B IH
                   | ga de th A B C H1 IH1 IH2
                   | ga de A B H1 IH
                   | ga de th A B H1 IH1 IH2 ] using LR1_provable_ind; simpl in * |- *.

    apply inc1_trans with (1 := @times_commute_1 _ _), unit_neutral_1; auto.

    apply adjunction_1; auto.

    apply inc1_trans with (1 := proj1 (FList_sem_perm H1)),
          inc1_trans with (2 := IH2).
    simpl.
    apply inc1_trans with ([[A]] -ø[[B]] ** ([|ga|] ** [|de|])).
    apply times_congruence; auto.
    apply eq1_sym, FList_sem_app.
    apply inc1_trans with (1 := @times_associative_2 _ _ _).
    apply times_monotone; auto.
    apply inc1_trans with ([[A]] -ø[[B]] ** [[A]]).
    apply times_monotone; auto.
    apply adjunction_2; auto.

    apply inc1_trans with (2 := IH),
          inc1_trans with (1 := proj1 (FList_sem_perm H1)).
    apply inc1_trans with (2 := @times_associative_1 _ _ _).
    simpl; apply times_monotone; auto.
    apply cl_contract.

    apply inc1_trans with (2 := IH2),
          inc1_trans with (1 := proj1 (FList_sem_perm H1)),
          inc1_trans with (1 := proj1 (FList_sem_app _ _)).
    apply times_monotone; auto.
  Qed.

  Theorem sem_LI1_sound : forall s, LI1_provable s -> [|fst s|] inc1 [[snd s]].
  Proof.
    induction 1 as [ A
                   | ga A B IH
                   | ga de th A B C H1 IH1 IH2
                   | ga de A B H1 IH
                   | ga de A B H1 IH
                   | ga de th A B H1 IH1 IH2 ] using LI1_provable_ind; simpl in * |- *.

    apply inc1_trans with (1 := @times_commute_1 _ _), unit_neutral_1; auto.

    apply adjunction_1; auto.

    apply inc1_trans with (1 := proj1 (FList_sem_perm H1)),
          inc1_trans with (2 := IH2).
    simpl.
    apply inc1_trans with ([[A]] -ø[[B]] ** ([|ga|] ** [|de|])).
    apply times_congruence; auto.
    apply eq1_sym, FList_sem_app.
    apply inc1_trans with (1 := @times_associative_2 _ _ _).
    apply times_monotone; auto.
    apply inc1_trans with ([[A]] -ø[[B]] ** [[A]]).
    apply times_monotone; auto.
    apply adjunction_2; auto.

    apply inc1_trans with (2 := IH),
          inc1_trans with (1 := proj1 (FList_sem_perm H1)).
    apply inc1_trans with (2 := @times_associative_1 _ _ _).
    simpl; apply times_monotone; auto.
    apply cl_contract.

    apply inc1_trans with (2 := IH),
          inc1_trans with (1 := proj1 (FList_sem_perm H1)).
    apply inc1_trans with (2 := unit_neutral_1 (cl_FList_sem _)).
    simpl; apply times_monotone; auto.

    apply inc1_trans with (2 := IH2),
          inc1_trans with (1 := proj1 (FList_sem_perm H1)),
          inc1_trans with (1 := proj1 (FList_sem_app _ _)).
    apply times_monotone; auto.
  Qed.

End Relational_phase_semantics.

Section Cut_Adm.

  Local Notation " l '≻c' m " := (list_contract Form_eq_dec l m) (at level 70, no associativity).

  Variable (P : list Form -> Form -> Prop).

  Notation " g '|--' a " := (P g a) (at level 70, no associativity).

  Implicit Types (X Y : list Form -> Prop).

  Local Definition cl X de := forall ga x, (forall th, X th -> ga++th |-- x) -> ga++de |-- x.

  Local Fact cl_increase X : X inc1 cl X.
  Proof.
    intros ? ? ? ?; auto.
  Qed.

  Local Fact cl_mono X Y : X inc1 Y -> cl X inc1 cl Y.
  Proof.
    intros H1 de Hde ga x HY.
    apply Hde.
    intros; apply HY, H1; auto.
  Qed.

  Local Fact cl_idem X : cl (cl X) inc1 cl X.
  Proof.
    intros de Hde ga x HX.
    apply Hde.
    intros th Hth.
    apply Hth, HX.
  Qed.

  Local Definition comp (ga de th : list Form) := ga ++ de ~p th.
  Local Definition e : list Form := nil.

  Local Fact cl_comm : cl_commutativity cl comp.
  Proof.
    intros ga de _ [ ga' de' th ].
    intros; subst ga' de'.
    intros rho x H; apply H.
    constructor 1 with de ga; auto.
    revert H1; unfold comp.
    apply perm_trans, Permutation_app_comm.
  Qed.

  Local Fact cl_neutral_1 : cl_neutrality_1 cl comp e.
  Proof.
    intros l th x H.
    apply H.
    constructor 1 with nil l; auto.
    red; simpl; auto.
  Qed.

  Hypothesis HP_perm : forall ga de x, ga ~p de -> ga |-- x -> de |-- x.

  Local Fact cl_neutral_2 : cl_neutrality_2 cl comp e.
  Proof.
    intros ga ? [ de th ka ? ? H1 ] rho x G; subst th de.
    cbv in H1.
    generalize (G _ eq_refl).
    apply HP_perm, Permutation_app; auto.
  Qed.

  Local Fact cl_stable_l : cl_stability_l cl comp.
  Proof.
    intros X Y _ [ ga de th H1 H2 H3 ] rho x HXY.
    red in H1.
    apply HP_perm with ((rho++de)++ga).
    rewrite app_ass.
    apply Permutation_app; auto.
    apply perm_trans with (2 := H3), Permutation_app_comm.
    apply H1.
    intros ka Hka.
    rewrite app_ass.
    apply HXY.
    constructor 1 with ka de; auto.
    apply Permutation_app_comm.
  Qed.

  Local Fact cl_assoc : cl_associativity cl comp.
  Proof.
    intros ga de th _ [ ga' rho ka H2 H3 H4 ].
    destruct H3 as [ de' th' to ]; subst ga' de' th'.
    intros u x Hu.
    specialize (Hu ((ga++de)++th)).
    spec_all Hu.
    constructor 1 with (ga++de) th; auto.
    constructor 1 with ga de; auto.
    red; auto.
    red; auto.
    revert Hu.
    apply HP_perm, Permutation_app; auto.
    rewrite app_ass.
    apply Permutation_trans with (2 := H4).
    apply Permutation_app; auto.
  Qed.

  Hypothesis HP_contract : forall ga de x, ga ≻c de -> ga |-- x -> de |-- x.

  Local Fact cl_cntr : cl_cntr_hyp cl comp.
  Proof.
    intros ga rho x H.
    specialize (H (ga++ga)).
    spec_all H.
    constructor 1 with ga ga; cbv; auto.
    revert H; apply HP_contract.
    intros d; repeat rewrite occ_app.
    unfold nat_contract; omega.
  Qed.

  Hypothesis HP_weak : forall ga de x, ga |-- x -> ga++de |-- x.

  Local Fact cl_weak : cl_weak_hyp cl nil.
  Proof.
    intros ga rho x H.
    generalize (H _ eq_refl).
    rewrite <- app_nil_end.
    apply HP_weak.
  Qed.

  Local Definition dc a ga := ga |-- a.

  Local Definition v x := dc (£ x).

  Local Fact Hv x : cl (v x) inc1 v x.
  Proof.
    intros ga Hga.
    apply (Hga nil).
    simpl; auto.
  Qed.

  Local Definition cl_LR1_sound := @sem_LR1_sound _ _ cl_increase cl_mono cl_idem comp
                                    _ cl_comm cl_stable_l cl_neutral_1 cl_neutral_2 cl_assoc
                                    _ Hv cl_cntr.

  Local Definition cl_LI1_sound := @sem_LI1_sound _ _ cl_increase cl_mono cl_idem comp
                                      _ cl_comm cl_stable_l cl_neutral_1 cl_neutral_2 cl_assoc
                                      _ Hv cl_weak cl_cntr.

  Hypothesis HP_id : forall x, x :: nil |-- x.

  Local Fact rule_id x : Form_sem comp v (£ x) (£ x::nil).
  Proof. simpl; apply HP_id. Qed.

  Notation sg := (@eq _).
  Infix "-ø" := (Magicwand comp) (at level 51, right associativity).

  Hypothesis HP_r : forall ga a b, a::ga |-- b -> ga |-- a %> b.

  Local Fact rule_r A B : sg (A :: nil) -ø dc B inc1 dc (A %> B).
  Proof.
    intros th Hth.
    apply HP_r, Hth.
    constructor 1 with th (A :: nil); auto.
    apply Permutation_app_comm.
  Qed.

  Hypothesis HP_l : forall ga de a b c, ga |-- a -> b::de |-- c -> a%>b::ga++de |-- c.

  Local Fact rule_l A B : (dc A -ø cl (sg (B:: nil))) (A %> B :: nil).
  Proof.
    intros th Hth de C H.
    destruct Hth as [ rho ga th H1 H2 H3 ].
    subst rho; red in H3; simpl in H3.
    apply HP_perm with (A%>B::ga++de).
    apply perm_trans with (2 := Permutation_app_comm _ _).
    apply Permutation_app with (1 := H3); auto.
    apply HP_l; auto.
    generalize (H _ eq_refl).
    apply HP_perm, Permutation_app_comm.
  Qed.

  Hint Resolve cl_increase cl_mono cl_idem cl_stable_l Hv : core.

  Local Fact mw_mono (X Y X' Y' : _ -> Prop) : X inc1 X' -> Y inc1 Y' -> X' -ø Y inc1 X -ø Y'.
  Proof.
    apply magicwand_monotone; auto.
  Qed.

  Local Fact cl_sem A : cl (Form_sem comp v A) inc1 Form_sem comp v A.
  Proof.
    apply cl_Form_sem; eauto.
  Qed.

  Local Fact cl_clos (A B : _ -> Prop) : cl B inc1 B -> A inc1 B -> cl A inc1 B.
  Proof.
    apply cl_closed; eauto.
  Qed.

  Local Lemma cl_Okada A : Form_sem comp v A (A::nil)
                        /\ Form_sem comp v A inc1 fun ga => ga |-- A.
  Proof.
    induction A as [ x | A [ HA1 HA2 ] B [ HB1 HB2 ] ]; simpl; split.

    apply rule_id.
    intros ga; auto.

    generalize (@rule_l A B).
    apply mw_mono; auto.
    apply cl_clos; auto.
    apply cl_sem; auto.
    intros ? []; auto.

    intros th Hth.
    apply (@rule_r A B).
    revert Hth.
    revert th; apply mw_mono; auto.
    intros ? []; auto.
  Qed.

  Local Lemma cl_Okada_ctx ga : FList_sem cl comp e v ga ga.
  Proof.
    induction ga as [ | A ga Hga ]; simpl;
      apply cl_increase; auto.
    constructor 1 with (A :: nil) ga; auto.
    apply cl_Okada.
    apply Permutation_refl.
  Qed.

End Cut_Adm.

Local Hint Resolve LR1_cf_provable_perm
                   LR1_cf_provable_contract
                   LR1_cf_provable_id LR1_cf_provable_r : core.

Theorem LR1_cut_admissibility : LR1_provable inc1 LR1_cf_provable.
Proof.
  intros (ga,A) H.
  apply cl_Okada with (P := fun ga a => LR1_cf_provable (ga,a)); auto.
  apply LR1_cf_provable_perm.
  intros ? ? ? ? ?; apply LR1_cf_provable_l; auto.

  apply cl_LR1_sound with (3 := H); simpl; auto.
  apply LR1_cf_provable_perm.
  apply LR1_cf_provable_contract.
  apply cl_Okada_ctx; auto.
  apply LR1_cf_provable_perm.
  intros ? ? ? ? ?; apply LR1_cf_provable_l; auto.
Qed.

Local Hint Resolve LI1_cf_provable_perm
                   LI1_cf_provable_contract LI1_cf_provable_weakening
                   LI1_cf_provable_id LI1_cf_provable_r : core.

Theorem LI1_cut_admissibility : LI1_provable inc1 LI1_cf_provable.
Proof.
  intros (ga,A) H.
  apply cl_Okada with (P := fun ga a => LI1_cf_provable (ga,a)); auto.
  apply LI1_cf_provable_perm.
  intros ? ? ? ? ?; apply LI1_cf_provable_l; auto.

  apply cl_LI1_sound with (4 := H); simpl; auto.
  apply LI1_cf_provable_perm.
  apply LI1_cf_provable_contract.
  apply cl_Okada_ctx; auto.
  apply LI1_cf_provable_perm.
  intros ? ? ? ? ?; apply LI1_cf_provable_l; auto.
Qed.