From a968a8f97726c67a8ed3a700642f8df2ba3d0335 Mon Sep 17 00:00:00 2001 From: Thomas Portet Date: Mon, 17 Mar 2025 13:19:03 +0100 Subject: [PATCH 1/3] fixing typos --- documents/vertical-cells/main.tex | 202 +++++++++++++++--------------- 1 file changed, 101 insertions(+), 101 deletions(-) diff --git a/documents/vertical-cells/main.tex b/documents/vertical-cells/main.tex index 60f46b0..4acbb32 100644 --- a/documents/vertical-cells/main.tex +++ b/documents/vertical-cells/main.tex @@ -60,36 +60,36 @@ \section{Introduction} The formal verification of algorithms is often presented as a solution -to avoid programmation errors. It is particularly suited to domains +to avoid programming errors. It is particularly suited to domains where it is practical to give a mathematical description of the problem and expected behaviors and where the cost of errors is prohibitive. In recent years, there has been much progress in the design and acceptance of autonomous vehicles. -In the long run, we wish to describe formally +In the long run, we wish to formally describe software that plans trajectories for complex objects. One of the first case studies that comes to mind is concerned with proving that a program producing trajectories for a -point in a bi-dimensional scene is safe. We designed such a program, +point in a bidimensional scene is safe. We designed such a program, and its first component is concerned with reading the description of the scene and constructing a decomposition into cells, where each cell helps describing where it is safe to evolve. We chose to study an algorithm described in the book {\em Robot Motion - Planning} by J.-C. Latombe under the name ``vertical cell + Planning} by J.-C. Latombe under the name ``vertical cell decomposition''. In that book's presentation, the obstacles are described as polygons, but we chose to simplify the problem by -considering only obstacles described using straight line segments. +considering only obstacles described using straight-line segments. Our algorithm is a simple generalization, since any polygon can be -decomposed in a collection of edges corresponding to the polygon's +decomposed into a collection of edges corresponding to the polygon's boundary. -This algorithm is sweeping line algorithm. It can be described +This algorithm is a sweeping line algorithm. It can be described intuitively as the process of moving a line from left to right over the scene, stopping each time an event is encountered. Events occur when the extremities of obstacles are encountered. -Several obstacles may be concerned by a single event: Several +Several obstacles may be concerned by a single event: several obstacles that were present on the left side the sweeping line may be finishing at this event, and several obstacles may be starting at this event. @@ -99,7 +99,7 @@ \section{Introduction} where only the left-hand side is known, actually this side is aligned with the sweeping line. The other new cells are {\em closed}. These cells are obtained by collecting all the cells that are in contact -with the processed event and giving them a right side, again aligned +with the processed event and giving them a right side, again aligned with the current location of the sweeping line. The lateral sides of each cell are vertical, because the sweeping line @@ -110,7 +110,7 @@ \section{Introduction} points on each lateral side are given with each closed cell. For the use case that we have in mind, it is also important that cells -are non empty. To guarantee this property, we had to design specific +are non-empty. To guarantee this property, we had to design specific tests and corrective actions when two successive events are vertically aligned. So instead of processing events from left to right, which is not precise enough, we process events in lexical order: from left to @@ -136,9 +136,9 @@ \section{Introduction} element of the cell interior. All these properties have been formally formally verified using the -rocq prover and the {\sc Mathematical Components} library. +Rocq prover and the {\sc Mathematical Components} library. -There is an extra property for which the proof has not be done yet: +There is an extra property for which the proof has not been done yet: the union of all owned parts covers the inside of the bounding box. Lacking this property does not endanger the safety property, but a trivial algorithm that returns an empty sequence of cells would satisfy the safety property. @@ -154,12 +154,12 @@ \section{Introduction} last part of this paper. \section{The data components} -In this section, we describe the design choices for the various kind +In this section, we describe the design choices for the various kinds of data we manipulate in the algorithm. The way we handle obstacles deserves special attention. \subsection{points and edges} -For the proofs, ww assume that we work with a type {\tt R} of numbers +For the proofs, we assume that we work with a type {\tt R} of numbers with the structure of a real field, as understood by the {\sc Mathematical Components} library. Among other operations, this mathematical structure provides a boolean test for equality between @@ -174,7 +174,7 @@ \subsection{points and edges} equality tests and the polymorphic functions for list membership of the {\sc Mathematical Components} library can again be used for these datatypes. One peculiarity of our development -is that we chose to describe the edges as pair of points with an extra +is that we chose to describe the edges as pairs of points with an extra condition in our proofs: the first point has to have a first coordinate that is strictly smaller than the right coordinate of the second point. This is an example of design where some data invariant @@ -191,11 +191,11 @@ \subsection{points and edges} _ : left_pt.x < right_pt.x}. \end{verbatim} This definition does not give a name to the condition that the left -point has a smaller first coordinate. Such a name is given later in +point has a smaller first coordinate. Such a name is given later in our development. The most important basic block used in the algorithm is the -computation of whether a point {\tt p} is above or under an edge, or whether +computation of whether a point {\tt p} is above or below an edge, or whether it is aligned with the two extremities of the edge. To compute this condition, it is well known in computational geometry \cite{Knuth} that the following determinant can be used, where {\tt l} and {\tt r} are the @@ -211,7 +211,7 @@ \subsection{points and edges} Because it is a signed area, the value is positive if {\tt p} is above and negative if {\tt p} is below. We use the notations {\tt \(p\) <{}<{}= \(g\)} {\tt \(p\) <{}<{}< \(g\)} to express that a point -\(p\) is in the half plane below an edge \(g\) or strictly below an +\(p\) is in the half-plane below an edge \(g\) or strictly below an edge, respectively. Because the algorithm uses a vertical sweeping line, our proofs @@ -227,7 +227,7 @@ \subsection{points and edges} When a point is valid for an edge, the vertical projection of that point on that edge exists. It is computed by a function called {\tt vertical\_projection}. Computing the vertical projection of a -point on an oblique edge requires that one computes a division. This +point on an oblique edge requires that one computes a division. This is the one place in the whole algorithm where division is used. The function {\tt vertical\_projection} takes a point and an edge as arguments and returns an {\tt option} type: @@ -242,7 +242,7 @@ \subsection{points and edges} {\tt edge\_below} which expresses that the first edge is below the second one. Edge \(g_1\) is below Edge \(g_2\) if both extremities of \(g_1\) are in the half plane below -\(g_2\) of if both extremities of \(g_2\) are in the half plane above +\(g_2\) or if both extremities of \(g_2\) are in the half plane above \(g_1\). During the operation of the algorithm, we use this relation to sort edges going out of a given event. For edges that all have the same left extremity, the {\tt <|} relation is transitive, but in @@ -251,14 +251,14 @@ \subsection{The cells} Each cell has a high edge, a low edge, a left side, and a right side. For the lateral sides, we record the ordered sequence of points that correspond to events in contact with this cell. These points are -unsafe. These two sequences of points are called the {\em left - points} and {\em right points} of the cell (record projections +unsafe. These two sequences of points are called the {\em left points} +and {\em right points} of the cell (record projections named {\tt left\_pts} and {\tt right\_pts} in the code). These sequences are ordered and contain no duplication, so that the open interval between two points in a sequence is a door, a safe passage to another cell. -In a finished closed cells, the side point sequences are not empty, +In the finished closed cells, the side point sequences are not empty, as they always contain the projections of some event on the low and high edge, which may be the same point. @@ -267,7 +267,7 @@ \subsection{The cells} there is never an ambiguity as to whether some cell is open or closed. The left points sequence of a cell is intended to contain -points that are vertically aligned, the first point is on the high edge and +points that are vertically aligned, the first point is on the high edge and the last point is on the low edge. The same properties hold for the right points. We defined a predicate named {\tt open\_cell\_side\_limit\_ok} to describe the properties of the @@ -281,8 +281,8 @@ \subsection{The cells} (points whose first coordinate is strictly between the left limit and the right limit, strictly above the low edge, and strictly below the high edge) and its doors (points on each of the sides that are -strictly abouve the low edge and strictly below the high edge and -different from the side points). In what follows, the safe part of of cell +strictly above the low edge and strictly below the high edge and +different from the side points). In what follows, the safe part of a cell is described by a predicate named {\tt safe\_part}. \begin{figure} @@ -295,7 +295,7 @@ \section{The scan state} The sweeping part of the algorithm is essentially a tail recursive algorithm, consuming a sorted sequence of events and -maintaining a datastructure which we call the {\tt scan\_state}. This +maintaining a data structure which we call the {\tt scan\_state}. This structure contains a representation of the closed cells constructed so far, a representation of all the open cells in contact with the current position of the sweeping line, and some cached information: @@ -303,7 +303,7 @@ \section{The scan state} last open cell. The open cells are arranged in a vertically sorted sequence, -decomposed in three parts. The middle part is a cell that is singled +decomposed into three parts. The middle part is a cell that is singled out because it is the highest of the last created cells (in this paper, we shall call this the {\em last open cell}. The other two parts are the prefix of the vertical sorted sequence before the last @@ -331,9 +331,9 @@ \section{The phases of the algorithm} events constructed in the algorithm are guaranteed to respect it. To create the sequence of events, -We use a bespoke insertion-sort algorithm, where the insertion +we use a bespoke insertion-sort algorithm, where the insertion procedure is designed to create new events only when no event with the -same point already exist in the sequence. When adding edges to an +same point already exists in the sequence. When adding edges to an event, we do not produce a sorted sequence of edges. Such a sorting operation of the outgoing sequence of edges is performed later in the algorithm. @@ -352,15 +352,15 @@ \section{The phases of the algorithm} To obtain the initial scan state, we need to have already one closed cell, which is only constructed after the first event is processed. -This first closed cell has the left side of the bounding box as left +This first closed cell has the left side of the bounding box as its left side, and its right side contains exactly three points: the first -event, its projection on the high boundary of the bounding-box, and its -projection on the low boundary of the bounding-box. The first +event, its projection on the high boundary of the bounding box, and its +projection on the low boundary of the bounding box. The first sequence of open cells is obtained by constructing new open cells using the sorted sequence of outgoing edges from the first event. When the first event has at least one outgoing edge, the initial last open cell is a cell whose low edge -is the highest outgoing edge and whose high edge is the bounding box +is the highest outgoing edge and whose high edge is the bounding box's high boundary, with only two points in the left point sequence: the projection of the event on the high boundary and the event itself (see Figure~\ref{figure:initial}). When the first event has no outgoing edge, the initial last open cell @@ -376,11 +376,11 @@ \subsection{Work performed in the first case} When the next event to be processed is not vertically aligned with the previous one, we need to scan the current sequence of open cells to know which of these cells will be affected by the current event. -These cell simply are the cells for which the current event is below +These cells simply are the cells for which the current event is below the high edge and above the low edge. We call these cells the {\em contact cells}. These cells are a sub-sequence of the current sequence of open cells. The function that computes -this sequence actually returns several meaninful pieces of data: +this sequence actually returns several meaningful pieces of data: \begin{enumerate} \item the prefix of unaffected cells, \item the sequence of contact cells without the last one, @@ -389,7 +389,7 @@ \subsection{Work performed in the first case} \item the low edge of the first contact cell, \item the high edge of the last contact cell \end{enumerate} -The function that computes that decomposition is called +The function that computes this decomposition is called {\tt open\_cells\_decomposition}. It takes as input a point and a sequence of cells. We proved that under some assumptions, the sequence of cells given as input is the concatenation of the prefix, @@ -397,17 +397,17 @@ \subsection{Work performed in the first case} output are indeed boundary edges of the first and last contact cells. All contact cells are transformed into closed cells, by adding a -right-side. When there is more that one contact cell, the first one -has as low edge an edge that is not in contact with the current event -and as high edge an edge whose right point is the current event. -Similarly, the last contact cell has as high edge an edge that is not -in contact with the current event as low edge an edge whose right +right-side. When there is more than one contact cell, the first one +has as its low edge an edge that is not in contact with the current event +and as its high edge an edge whose right point is the current event. +Similarly, the last contact cell has as its high edge an edge that is not +in contact with the current event as its low edge an edge whose right point is the current event. When there is only one contact cell, this is because the processed event is below that cell's high edge and above that cell's low edge. The sequence of the right points for the new cell only contains three -points, the event and its projections to the cells two edges. +points, the event and its projections to the cell's two edges. All contact cells are removed from the list of open cells, but new open cells, whose left side contains the currently processed event are @@ -426,7 +426,7 @@ \subsection{Work performed for the second case} \subsection{Work performed for the third case} In the third case, the event is below the high edge of the last open -cell, and this even cannot be the right extremity of +cell, and this event cannot be the right extremity of an active edge, because there is no edge between the low and the high edge of the last open cell. For this reason, it is not necessary to re-run the {\tt open\_cells\_decomposition} function, as it would @@ -502,7 +502,7 @@ \subsection{Specifying the safety property} \begin{itemize} \item The type of numbers provided to describe the point coordinates, the edges, alignment of points, and so on, with its operation and - comparison predicates forms an ordered field structure. It means, the + comparison predicates forms an ordered field structure. It means that the algorithm only uses addition, multiplication, and their inverses. \item The only allowed intersections between obstacles are at their extremities. @@ -517,15 +517,15 @@ \subsection{Specifying the safety property} \begin{enumerate} \item The union of all outgoing edges of all events in the sorted sequence of events contains the initial obstacles. -\item For evey event, all outgoing edges have the same left +\item For every event, all outgoing edges have the same left extremity, located at this event. -\item For every event, The sequence of outgoing edges has no duplication. +\item For every event, the sequence of outgoing edges has no duplicates. \item The sequence of events is strictly sorted lexicographically. \item No event in the sequence appears in the middle of one of the obstacles. \item The right extremity of every outgoing edge is also located at an event existing in the sequence of events. -\item There are no intersection between pairs of edges except at their +\item There are no intersections between pairs of edges except at their extremities. \item All events are inside the bounding box. \end{enumerate} @@ -539,7 +539,7 @@ \subsection{Specifying the safety property} A property that does not appear immediately as a safety property is that the middle of every cell is strictly included in the cell. This property is useful for users of this algorithm who wish to use a cell -as maneuvering space to move from one door of the cell to another door of +as a maneuvering space to move from one door of the cell to another door of the same cell, when both doors are on the same side. This property is the main reason for having a specific treatment for degenerate cases. This specific treatment actually guarantees that every closed cell has @@ -551,15 +551,15 @@ \subsection{Specifying the safety property} edges without duplications. Our code to generate the sequence of events does not include steps to guarantee this, but we guarantee that it operates correctly if the input -list of obstacles has no duplications +list of obstacles has no duplicates. Finally, the statement we prove for the second phase is the following one, as written in the input language of the Rocq prover (by taste, we prefer to avoid special characters). In this statement, the function -{\tt complete\_process} represents the algorithm that process the sequence of +{\tt complete\_process} represents the algorithm that processes the sequence of events: it combines together the operation of constructing the first cells from the first event, and processing the last open cell to create the rightmost -close cell. The function {\tt events\_to\_edges} collects all the edges +closed cell. The function {\tt events\_to\_edges} collects all the edges from a sequence of events. \begin{verbatim} Lemma second_phase_safety (bottom top : edge) (evs : seq event) : @@ -581,7 +581,7 @@ \subsection{Specifying the safety property} sequence of events. A more compact statement can be used if we consider the combination of the -two phases, because the first phase guarantees the prerequisites on +two phases, because the first phase guarantees the prerequisites on the sequence of events. The combination of the two phases is called {\tt edges\_to\_cells} in this statement. While the concision of this statement is pleasant, it @@ -597,15 +597,15 @@ \subsection{Specifying the safety property} forall p, cell_safe_part c p -> {in edges, forall g, ~ p === g}}. \end{verbatim} This lemma only has 4 prerequisites: the bounding box given by the -bottom and top edge must define a workable area of the plane, the sequence +bottom and top edges must define a workable area of the plane, the sequence of input edges must have no duplications, all considered edges must have no duplications, and all edges must be inside the bounding box. With these four prerequisites, the algorithms of the first phase are able to produce -a sequence events satisfying the eight prerequisites of the second phase. +a sequence of events satisfying the eight prerequisites of the second phase. As a result, the algorithm produces a sequence of cells that satisfy four properties: each contains at least one point, they are well formed (the -sequence of points on the side are vetical and ordered, the extremities of +sequence of points on the side are vertical and ordered, the extremities of these sequences are on the low and high edges of the cell) and the safe part has an empty intersection with the union of the obstacles. @@ -627,13 +627,13 @@ \subsection{Mirroring contexts} these proof files, we actually instantiate the type of numbers with a mathematical structure from the {\sc Mathematical Components} library. Following the library's idiom, we do not choose a specific field structure, -we assume we are using one that exists. So the proofs we make are assuming +we assume we are using one that exists. So, the proofs we make are assuming that the user of the code also respects that part of the specification and actually instantiates the software with a number structure that respects the properties specified by the real field structure. We do provide a running implementation by instantiating the -type of numbers with rational numbers, implemented as pair of a numerator +type of numbers with rational numbers, implemented as a pair of a numerator (an integer) and a denominator (a positive integer). Every function imported from {\tt generic\_trajectories} is a function @@ -641,8 +641,8 @@ \subsection{Mirroring contexts} header of notation definition is provided to instantiate the function to the type and operations provided by the field structure. This header of notations needs to be repeated in each working file, because the field -structure named {\tt R} in each file is a conceptually a different structure -for each file. However, theorems proved in one file can be re-used in another +structure named {\tt R} in each file is conceptually a different structure +for each file. However, theorems proved in one file can be reused in another simply because they are generalized at the end of each section and can be re-instantiated at each usage. @@ -655,7 +655,7 @@ \subsection{Main organization of the proof} required by Lemma~{\tt second\_phase\_safety} is comparatively easy. However, this lemma only expresses safety with respect to the obstacles and points found in the list of events. Therefore, an extra property that is -important is that the edges present in resulting +important is that the edges present in the resulting list of events are the input edges. We will now concentrate on the second phase. @@ -666,19 +666,19 @@ \subsection{Main organization of the proof} events. \item In the second level, we add properties that fall in three categories \begin{enumerate} - \item the cache consistency properties of + \item The cache consistency properties of the scan state: the scan state contains a last open cell, a last high edge, and a last {\tt x} coordinate. It is assumed that the last high edge is the high edge of the last open cell, and that the last {\tt x} coordinate is the left limit of the last open cell. -\item the expected properties of the remaining sequence of events: these +\item The expected properties of the remaining sequence of events: these events are ordered lexicographically, all the right extremities of their edges are also covered by events in the sequence, the field {\tt outgoing} of each event is a list that only contains edges whose left-hand extremity is on this event, and this list has no duplicates. \item There is no intersection between the high edges of all open cells and the outgoing of events in the sequence of events. -\item the bottom left corner of the last open cell is lexicographically +\item The bottom left corner of the last open cell is lexicographically smaller than any event in the sequence. \item If the sequence of events is not empty, the next event is lexicographically larger than the left extremity of all edges of @@ -709,7 +709,7 @@ \subsection{Main organization of the proof} We performed two proofs of the main result. The first proof takes stronger assumptions on the inputs: it assumes that two events are -never vertically aligned. So there is only one case in the treatement +never vertically aligned. So, there is only one case in the treatment of events that is ever handled in this case. This proof is simpler and makes it possible to understand the main structure of the proof. @@ -725,7 +725,7 @@ \subsection{The area function and the {\tt edge\_below} relation} ever mentioning the projection of the given point on the given straight line. -For proofs, however it is useful to have an alternative point of view, +For proofs, however, it is useful to have an alternative point of view, where one expresses the property of being above using a comparison of the second coordinates of the given point with the projected point on the given line. @@ -733,12 +733,12 @@ \subsection{The area function and the {\tt edge\_below} relation} The edge comparison relation, called {\tt edge\_below} and noted {\tt <|} is directly related with the area function. To detect whether an edge is below another, we simply -verify whether the two extremities of one are in the same half plane +verify whether the two extremities of one are in the same half-plane with respect to the other. It turns out that this relation is reflexive, not transitive, and not antisymmetric. We spent quite some time trying to show that it is transitive -on some well chosen subsets, but this turned out to be improductive. For +on some well-chosen subsets, but this turned out to be unproductive. For this reason, it is not very useful (although it is true) to show that the sequence of high edges of all open cells is sorted for the {\tt edge\_below} relation. We @@ -753,7 +753,7 @@ \subsection{The area function and the {\tt edge\_below} relation} express but one must be careful to only consider points that are in the intersection of vertical cylinders above the two edges. The lemmas have names like {\tt order\_edges\_viz\_point} or {\tt under\_pvert\_y}, -sometimes with a {\tt strict} qualifer added. +sometimes with a {\tt strict} qualifier added. \subsection{Building up invariants} \subsection{The key property of disjoint cells} @@ -771,19 +771,19 @@ \subsection{The key property of disjoint cells} \end{itemize} The main key property that we want to guarantee is that every point strictly inside a cell does not belong to any obstacle. To establish -this, we decompose the problem in three parts: first we show +this, we decompose the problem into three parts: first, we show that points can only be owned by one cell. -prove that every obstacle is included the union of high boundaries of -all cells. As an immediate consequence, the interior of cell has no -intersection with the obstacles. The third property focusses only on the +Then, we prove that every obstacle is included in the union of high boundaries of +all cells. As an immediate consequence, the interior of a cell doesn't intersect +with the obstacles. The third property focuses only on the lateral sides of cells. To prove that closed cells are disjoint, we need to prove that new cells added at each iteration are disjoint with the existing ones. -The new closed closed cell actually come from +The new closed cells actually come from existing open cells. Thus, we need to prove that closed cells are kept disjoint from open cells, and in turn, we need to -show that open cell are disjoint. +show that open cells are disjoint. The position of the sweeping line plays an important role when proving that existing closed cells and open cells are disjoint. At any @@ -803,7 +803,7 @@ \subsection{The key property of disjoint cells} the modification does not interfere with the disjointness property with respect to the other cells. We use the fact that points attached to the last closed are the same before and after the -modification (which consists only in adding the second event to +modification (which consists only in adding the second event to the sequence of right points in the cell, in second position). \subsection{Obstacle covering} The obstacles whose left extremity is at an event that has already been @@ -837,24 +837,24 @@ \subsection{Obstacle covering} a sequence contact cell together with a last contact cell. Its high edge is the same obstacle as the high edge of the future last open cell. If we are in general position (the current event is not vertically aligned -with the previous one) This high +with the previous one), this high edge was covered by the combination of a sequence of closed cells and an open cell (the last contact cell) before this iteration, and after this iteration, the coverage is ensured by a new sequence -of closed cell which is the same as previously with a new closed cell added, +of closed cells which is the same as previously with a new closed cell added, obtained by closing the last open cell, and the last of newly created open cells covers the rest of that obstacle. For the high edges of all the other contact cells, they are -necessarily ending in the current event. So these obstacles move from +necessarily ending in the current event. So, these obstacles move from the category of obstacles that are partially covered by open cells to -the category of obstacles that completely covered by closed cells. +the category of obstacles that are completely covered by closed cells. If we are in the degenerate position where the current event is -vertically aligned with the previous event and below the high edge of +vertically aligned with the previous event and below the high edge of the last closed cell, then the sequence of closed cells that participate in covering this edge keeps the same number of elements: the previous last -closed cell is removed and replaced by the the modified closed cell +closed cell is removed and replaced by the modified closed cell where the event is added among its right points. The portion of the obstacle that is covered by the previous last closed cell and the modified cell is the same. Concerning coverage by an open cell, the @@ -877,10 +877,10 @@ \subsection{Safety for points strictly inside cells} \subsection{Safety for points on the lateral boundaries} For points on the lateral sides, we first concentrate on the left side. When an event is processed, closed cells have a left limit that is -stricly lower the event's first coordinate, so that this event cannot appear +strictly lower than the event's first coordinate, so that this event cannot appear in the safe left side of a closed cell. For the open cells, we show -that all those cells that are not in contact have their left side preserved. -So in the end we only need to show that the created open cells do contain +that all the cells that are not in contact have their left side preserved. +So in the end, we only need to show that the created open cells do contain the current event in the left points, so that this event is not considered safe by these cells. @@ -894,7 +894,7 @@ \subsection{Safety for points on the lateral boundaries} Apart from the last closed cell, we know that no closed cell is in contact with the currently processed event, either because the closed cell is further to the left of the sweeping line, or because the closed cell has -a top left corner that is strictly lower than the current event. +a top-left corner that is strictly lower than the current event. When creating new closed cells (in the first two cases and the fourth one), the proof proceeds by checking that the sequence of the right points @@ -919,7 +919,7 @@ \subsection{Safety for points on the lateral boundaries} \section{Conclusion} \subsection{A basis for trajectory computation} -As a way to assess usability, we integrated this program in a larger +As a way to assess usability, we integrated this program into a larger application that produces trajectories without intersections with the obstacles between points inside the bounding box, when possible. To work properly, this larger application relies @@ -934,7 +934,7 @@ \subsection{A basis for trajectory computation} According to our tests, these properties hold for our algorithm, but they have not been proved formally. If these properties were not satisfied, the program would not compute trajectories between some points that can -actually be connected by a such trajectory. +actually be connected by such a trajectory. This may actually correspond to a real life situation, where one might want to provide formal proofs for safety properties, but accept that some @@ -951,7 +951,7 @@ \subsection{Vertical obstacles in trajectory computation} \item The algorithm will naturally produce cells where the two events appear as the extremities of a door on the lateral sides of two cells, -\item When buiding trajectories, make sure to invalidate doors corresponding +\item When building trajectories, make sure to invalidate doors corresponding to vertical obstacles. \end{itemize} A slight modification of the data used in the algorithm can help achieving @@ -966,7 +966,7 @@ \subsection{Concerning numerical computation} envisioned in the formal model. It should be noted that the computation performed in the area function -is just second-degree multivariate polynomial. These computations can +is simply a second-degree multivariate polynomial. These computations can be made exact at a little cost, taking into account the discretization that necessarily happens when perceiving the environment. A robot may be designed to work with sensors that yield coordinates in 16 bits. @@ -978,10 +978,10 @@ \subsection{Concerning numerical computation} this is when computing the projection of a point on an edge. This point is stored in the result of the cell decomposition as an extremal point in the sequence of left points or the sequence of right points -of closed cell. It is later used when computing trajectories. One +of a closed cell. It is later used when computing trajectories. One important feature of this computation is that {\em it is not used to take decisions during the vertical cell decomposition}. It is just -data that is stored for later usage. +data that is stored for later use. Since this value is not needed right away, we could decide not to compute it, but to store it as the intersection between a vertical @@ -991,18 +991,18 @@ \subsection{Concerning numerical computation} whether the exact value is required, or whether an approximation suffices. To compute trajectories, these intersection points appear higher or lower extremities of safe doors, and they can safely be -replace by points with a lower approximation or a higher approximation +replaced by points with a lower approximation or a higher approximation of the second coordinate, respectively. As future work, we wish to refine the algorithm so that it produces cells where the sequences of left points and right points are not in the datatype of pairs of coordinates, but rather in a sum type, where -a point is given either as a pair of coordinate or the pair of a first -coordinate and a obstacle in which we take the point with that first -coordinate, so that the information is processed in the right away by +a point is given either as a pair of coordinates or the pair of a first +coordinate and an obstacle in which we take the point with that first +coordinate, so that the information is processed in the right way by the following algorithms. \subsection{Concerning the neighboring relation} -In our use case to compute trajectories, we need to know what are the +In our use case to compute trajectories, we need to know which are the neighbors of each closed cell. It seems obvious that this information is already known at the time an open cell is created and could be propagated along as the cells are added in the final cell of closed @@ -1047,10 +1047,10 @@ \subsection{Concerning obstacle crossing} treatment of crossing obstacles directly in the vertical cell decomposition algorithm. In fact, after each iteration, it is only necessary to check whether two neighboring high edges of open cells -intersect, peform the needed replacement and add the intersection as a +intersect, perform the needed replacement and add the intersection as a new event to be treated later. It is interesting to understand whether the current research concerning algorithm refinement could -help proving this improved algorithm with optimal reuse of the proofs +help to prove this improved algorithm with optimal reuse of the proofs that were already performed for the naive algorithm. We plan to study such a refinement as future work. @@ -1063,13 +1063,13 @@ \subsection{Concerning obstacle crossing} rounding errors in this division process will affect the operation of the algorithm. We may choose to replace the exact point with an approximation, assuming that the obstacles defined with this -approximation as extremity as close enough to the original obstacles +approximation as extremity are close enough to the original obstacles for the results to be safe. We may even be able to quantify the risk of collision induced by this kind of replacement. In practice, it may be perfectly acceptable to live with the constraint that obstacles do not cross. It depends on the source of -the scene description. If the scene description was drawned by a +the scene description. If the scene description was drawn by a human being using a computer aided design tool, then intersections are likely. If the scene is the result of a process involving sensors and post-processing, it is possible that the post-processor already From 78b823072bb367bba55632ddbdc85ea301f48958 Mon Sep 17 00:00:00 2001 From: Thomas Portet Date: Mon, 17 Mar 2025 13:22:14 +0100 Subject: [PATCH 2/3] removing unused libraries and updating coqproject --- _CoqProject | 37 +- theories/axiomsKnuth.v | 35 - theories/bern.v | 404 ------- theories/bern5.v | 136 --- theories/casteljau.v | 1846 ------------------------------ theories/civt.v | 449 -------- theories/conv.v | 364 ------ theories/convex.v | 545 --------- theories/counterclockwise.v | 380 ------ theories/desc.v | 1260 -------------------- theories/desc1.v | 697 ----------- theories/desc2.v | 601 ---------- theories/door_crossing.v | 1133 ------------------ theories/encompass.v | 224 ---- theories/generic_trajectories.v | 1139 ------------------ theories/hulls.v | 327 ------ theories/intersection.v | 371 ------ theories/isolate.v | 689 ----------- theories/math_comp_complements.v | 346 ------ theories/pol.v | 1158 ------------------- theories/poly_normal.v | 1832 ----------------------------- theories/preliminaries.v | 241 ---- theories/preliminaries_hull.v | 280 ----- theories/shortest_path.v | 71 -- theories/shortest_path_proofs.v | 105 -- theories/square_free.v | 119 -- theories/three_circles.v | 756 ------------ theories/xssralg.v | 1166 ------------------- 28 files changed, 5 insertions(+), 16706 deletions(-) delete mode 100644 theories/axiomsKnuth.v delete mode 100644 theories/bern.v delete mode 100644 theories/bern5.v delete mode 100644 theories/casteljau.v delete mode 100644 theories/civt.v delete mode 100644 theories/conv.v delete mode 100644 theories/convex.v delete mode 100644 theories/counterclockwise.v delete mode 100644 theories/desc.v delete mode 100644 theories/desc1.v delete mode 100644 theories/desc2.v delete mode 100644 theories/door_crossing.v delete mode 100644 theories/encompass.v delete mode 100644 theories/generic_trajectories.v delete mode 100644 theories/hulls.v delete mode 100644 theories/intersection.v delete mode 100644 theories/isolate.v delete mode 100644 theories/math_comp_complements.v delete mode 100644 theories/pol.v delete mode 100644 theories/poly_normal.v delete mode 100644 theories/preliminaries.v delete mode 100644 theories/preliminaries_hull.v delete mode 100644 theories/shortest_path.v delete mode 100644 theories/shortest_path_proofs.v delete mode 100644 theories/square_free.v delete mode 100644 theories/three_circles.v delete mode 100644 theories/xssralg.v diff --git a/_CoqProject b/_CoqProject index 711b00d..43a581c 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,42 +1,15 @@ -theories/shortest_path.v -theories/generic_trajectories.v -theories/smooth_trajectories.v -theories/convex.v -theories/preliminaries.v -theories/poly_normal.v -theories/pol.v -theories/civt.v -theories/desc.v -theories/desc1.v -theories/desc2.v -theories/bern.v -theories/bern5.v -theories/casteljau.v -theories/isolate.v -theories/square_free.v -theories/three_circles.v -theories/hulls.v -theories/intersection.v -theories/conv.v -theories/encompass.v -theories/counterclockwise.v -theories/axiomsKnuth.v -theories/preliminaries_hull.v theories/cells.v theories/cells_alg.v -theories/door_crossing.v theories/events.v -theories/extraction_command.v -theories/math_comp_complements.v -theories/no_crossing.v +theories/first_degenerate_position.v +theories/general_position.v +theories/initial_cell.v theories/opening_cells.v theories/points_and_edges.v theories/safe_cells.v -theories/general_position.v -theories/simple_step.v -theories/initial_cell.v -theories/first_degenerate_position.v theories/second_degenerate_position.v +theories/simple_step.v +theories/smooth_trajectories.v theories/step_correct.v -R theories trajectories diff --git a/theories/axiomsKnuth.v b/theories/axiomsKnuth.v deleted file mode 100644 index 6812757..0000000 --- a/theories/axiomsKnuth.v +++ /dev/null @@ -1,35 +0,0 @@ -From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals order. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. -Module Type KnuthAxioms. -Section Dummy. - -Variable R : realType. -Definition Plane : vectType _ := (R^o * R^o)%type. -Parameter OT : Plane -> Plane -> Plane -> bool. - -(*Knuth's axioms are given by the following variables. But axiom 4 is not used in Jarvis' algorithm and axiom 3 is a property of the data, not of the - plane. *) -Axiom Axiom1 : forall p q r, OT p q r -> OT q r p. - -Axiom Axiom2 : forall p q r, OT p q r -> ~ OT p r q. - -Axiom Axiom4 : forall p q r t, OT t q r -> OT p t r -> OT p q t -> OT p q r. - -Axiom Axiom5 : - forall t s p q r, OT t s p -> OT t s q -> OT t s r -> - OT t p q -> OT t q r -> OT t p r. - -Local Open Scope order_scope. -Axiom Axiom5' : forall (pivot p q r : Plane), - (pivot : R *l R) < p -> - (pivot : R *l R) < q -> - (pivot : R *l R) < r -> - OT pivot p q -> - OT pivot q r -> - OT pivot p r. - -End Dummy. -End KnuthAxioms. diff --git a/theories/bern.v b/theories/bern.v deleted file mode 100644 index 4e0d1bc..0000000 --- a/theories/bern.v +++ /dev/null @@ -1,404 +0,0 @@ -From mathcomp Require Import all_ssreflect all_algebra archimedean. -(*Require Import QArith ZArith Zwf Omega. -From mathcomp Require Import ssreflect eqtype ssrbool ssrnat div fintype seq ssrfun order. -From mathcomp Require Import bigop fingroup choice binomial poly. -From mathcomp Require Export ssralg rat ssrnum. *) -Require Import pol desc. -(* Require Import infra pol civt desc. *) - -(* Import GroupScope . *) -Import Order.TTheory GRing.Theory Num.Theory. -Local Open Scope ring_scope . - -(* Set Printing Width 50. *) - -(******************************************************************************) -(* Two predicates to describe that a polynomial has only one root: *) -(* one_root1 l a b == there exists c, d, k, s.t. a, c, d, b are ordered, *) -(* k is positive, the polynomial value is positive *) -(* between a and c, negative between d and b, the slope *) -(* is less than -k between c and d; *) -(* This statement is specifically suited to speak about *) -(* roots inside the interval a b. *) -(* one_root2 l a == there exists c, d, k, s.t. a is smaller than c, *) -(* k is positive, the polynomial value is negative *) -(* between a and c, and the slope is larger than k above *) -(* c; *) -(* A consequence of one_root2 is that there can be only *) -(* one root above c, hence only one root above a. *) -(******************************************************************************) - -Local Open Scope order_scope . - -Definition one_root1 {R : archiFieldType} (p : {poly R}) (a b : R) := - exists c d k : R, [/\ [/\ a < c, c < d, d < b & 0 < k], - (forall x, a < x -> x <= c -> 0 < p.[x]), - (forall x, d < x -> x < b -> p.[x] < 0) & - (forall x y, c < x -> x <= y -> y < d -> k * (y - x) <= p.[x] - p.[y])]%R. - -Definition one_root2 {R : archiFieldType} (p : {poly R}) (a : R) := - exists c k : R, [/\ a < c, 0 < k, - (forall x, a < x -> x <= c -> p.[x] < 0) & - (forall x y, c <= x -> x < y -> k * (y - x) <= p.[y] - p.[x])]%R. - -Lemma alt_one_root2 (R : archiFieldType) (l : {poly R}) : alternate l -> - one_root2 l 0. -Proof. -move/desc => [[x1 k] /= [/andP[x1p kp] neg] sl]; exists x1, k; split => //. -- by move=> x xgt0 xlex1; apply: neg; rewrite xgt0 xlex1. -- by move=> x y xlex1 xlty; apply: sl; rewrite xlex1 (ltW xlty). -Qed. - -Definition translate_pol {R : ringType} (l : {poly R}) (a : R) : {poly R} := - l \Po ('X + a%:P). - -Lemma size_translate_pol {R : idomainType} (l : {poly R}) a : - size (translate_pol l a) = size l. -Proof. by rewrite size_comp_poly2// size_XaddC. Qed. - -Lemma translate_polq {R : comRingType} (l : {poly R}) a x : - (translate_pol l a).[x] = l.[x + a]. -Proof. by rewrite /translate_pol horner_comp 3!hornerE. Qed. - -Lemma one_root2_translate {R : archiFieldType} (l : {poly R}) a b : - one_root2 (translate_pol l a) b -> one_root2 l (a + b). -Proof. -move=> [x1 [k [x1a kp neg sl]]]; exists (a + x1), k; split => //. -- by rewrite ltrD2l. -- move=> x abx xax1; rewrite (_ : x = x - a + a); last by rewrite addrNK. - by rewrite -translate_polq; apply: neg; rewrite ?ltrBrDl ?lerBlDl. -- move=> x y ax1x xy. - have t z : z = (z - a) + a by rewrite addrNK. - rewrite {2}(t y) {2}(t x). - rewrite -!(translate_polq l) (_ : y - x = y - a - (x - a)); last first. - by rewrite [x + _]addrC opprD opprK addrA addrNK. - by apply: sl; rewrite ?lerBrDl ?ltr_leD. -Qed. - -Lemma one_root1_translate {R : archiFieldType} (l : {poly R}) a b c : - one_root1 (translate_pol l c) a b -> one_root1 l (c + a) (c + b). -Proof. -move=> [x1 [x2 [k [[ax1 x1x2 x2b kp] pos neg sl]]]]. -exists (c + x1), (c + x2), k; split. -- by rewrite !ltrD2l. -- move=> x cax xcx1; rewrite (_ : x = x - c + c); last by rewrite addrNK. - by rewrite -translate_polq; apply pos; rewrite ?ltrBrDl ?lerBlDl. -- move=> x cx2x xcb; rewrite (_ : x = x - c + c); last by rewrite addrNK. - rewrite -translate_polq; apply: neg; rewrite -?ler_addlA //. - by rewrite ltrBrDl. - by rewrite ltrBlDl. -- move=> x y cx1x xy ycx2. - have t z : z = (z - c) + c by rewrite addrNK. - rewrite {2}(t x) {2}(t y) (_ : y - x = y - c - (x - c)); last first. - by rewrite [x + _]addrC opprD opprK addrA addrNK. - rewrite -!(translate_polq l); apply: sl; rewrite ?lerD2l. - + by rewrite ltrBrDl. - + by rewrite lerB. - + by rewrite ltrBlDl. -Qed. - -Lemma diff_xn_ub {R : archiFieldType} (n : nat) : - forall z, (0 < z)%R -> exists2 k, (0 <= k)%R & - forall x y : R, (0 < x)%R -> x <= y -> (y <= z) -> - y ^+ n - x ^+ n <= k * (y - x). -Proof. -elim: n => [z z0| n IHn z z0]. - by exists 0%R => // x y x0 xy yz; rewrite !expr0 subrr mul0r. -have [k k0 kp] := IHn z z0. -exists (z * k + z ^+ n) => [| x y x0 xy yz]. - by rewrite addr_ge0// ?exprn_ge0// ?mulr_ge0// ltW. -rewrite !exprS. -rewrite (_: _ * _ - _ = y * (y ^+ n - x ^+ n) + (y - x) * x ^+ n); last first. - by rewrite mulrDr mulrDl addrA mulrN mulNr addrNK. -rewrite [_ * (y-x)]mulrDl lerD //=. - rewrite -mulrA (@le_trans _ _ (y * (k * (y - x))))//. - rewrite (ler_wpM2l (le_trans (ltW x0) xy))//. - exact: kp. - by rewrite !(mulrCA _ k) ler_wpM2l// ler_wpM2r// subr_ge0. -rewrite (mulrC (_ - _)) ler_wpM2r ?subr_ge0// lerXn2r//. -- by rewrite nnegrE ltW. -- by rewrite nnegrE ltW. -- exact: le_trans yz. -Qed. - -Definition reciprocate_pol (l : seq rat) := rev l. - -Lemma reciprocate_size l : size (reciprocate_pol l) = size l. -Proof. by rewrite /reciprocate_pol size_rev. Qed. - -Lemma cut_epsilon {R : archiFieldType} (eps : R) : (0 < eps)%R -> - exists eps1 eps2 : R, [/\ (0 < eps1)%R, (0 < eps2)%R, (eps1 + eps2 <= eps)%R, - eps1 < eps & eps2 < eps]. -Proof. -move=> p; exists (eps / 2%:R), (eps / 2%:R). -have p1 : (0 < eps / 2%:R)%R by rewrite divr_gt0// ltr0n. -have cmp : eps / 2%:R < eps. - by rewrite ltr_pdivrMr// ?ltr0n// ltr_pMr// ltr1n. -split => //. -by rewrite -splitr. -Qed. - -Lemma ler_horner_norm_pol {R : realFieldType} (l : {poly R}) x : - (0 <= x)%R -> `|l.[x]| <= \sum_(i < size l) (`|l`_i| * x ^+ i). -Proof. -move=> xge0; elim/poly_ind: l => [ | l a Ih]. - by rewrite !hornerE normr0 size_poly0 big_ord0. -rewrite hornerE. -have [->|ln0] := eqVneq l 0%R. - rewrite mul0r !hornerE size_polyC. - have [->|an0] := eqVneq a 0%R; first by rewrite normr0 big_ord0. - by rewrite big_ord1 /= expr0 mulr1 coefC eqxx. -rewrite size_MXaddC (negbTE ln0) /= big_ord_recl expr0 mulr1. -rewrite (le_trans (ler_normD _ _))//. -rewrite coefD coefMX eqxx add0r coefC eqxx hornerE [X in X <= _]addrC. -rewrite lerD// !hornerE. -have exteq (i : 'I_(size l)) : true -> - `|(l * 'X + a%:P)`_(lift ord0 i)| * x ^+ lift ord0 i = - (`|l`_i| * x ^+ i) * x. - move=> _; rewrite lift0 coefD coefC /= addr0 coefMX /=. - by rewrite exprS (mulrC x) mulrA. -rewrite normrM (ger0_norm xge0). -by rewrite (eq_bigr _ exteq) -mulr_suml ler_wpM2r. -Qed. - -Lemma cm3 {R : realFieldType} (b : R) : - (0 < b)%R -> forall l : {poly R}, {c | forall x y : R, - (0 <= x)%R -> (x <= y)%R -> (y <= b)%R -> `|l.[y] - l.[x]| <= c * (y - x)}. -Proof. -move=> pb; elim/poly_ind=> [ | l u [c cp]]. - by exists 0%R => x y; rewrite !hornerE oppr0 normr0 lexx. -exists ((\sum_(i < size l) `|nth 0 l i| * b ^+ i) + c * b). -move=> x y xge0 xy yb. -rewrite !hornerE addrAC opprD addrA addrNK. -rewrite [A in `|A|](_ : _ = l.[y] * y - l.[y] * x + l.[y] * x - l.[x] * x); - last by rewrite -[_ - _ + _]addrA addNr addr0. -have py : (0 <= y)%R by rewrite (le_trans xge0). -have psyx : (0 <= y - x)%R by rewrite subr_ge0. -rewrite -addrA (le_trans (ler_normD _ _)) //. -rewrite -mulrBr -mulrBl !normrM (ger0_norm xge0) (ger0_norm psyx). -rewrite [X in _ <= X]mulrDl lerD//. - rewrite ler_wpM2r// (le_trans (ler_horner_norm_pol l y py))//. - apply: ler_sum => i _. - rewrite ler_wpM2l ?normr_ge0//. - by rewrite lerXn2r// nnegrE (le_trans _ yb). -rewrite mulrAC ler_pM//; first exact: cp. -by rewrite (le_trans xy). -Qed. - -Lemma one_root_reciprocate {R : archiFieldType} (l : {poly R}) : - one_root2 (reciprocal_pol l) 1 -> one_root1 l 0 1. -Proof. -move=> [x1 [k [x1gt1 kp neg sl]]]. -have x10 : (0 < x1)%R by rewrite (lt_trans _ x1gt1)// ltr01. -set y' := x1 - (reciprocal_pol l).[x1] / k. -have y'1 : x1 < y'. - rewrite /y' -(ltrD2l (-x1)) addNr addrA addNr add0r -mulNr. - by rewrite divr_gt0 // oppr_gt0; exact: neg. -have nx1 : (reciprocal_pol l).[x1] < 0%R by apply: neg; rewrite // ltxx. -have y'pos : (0 <= (reciprocal_pol l).[y'])%R. - rewrite -[_ _ y']addr0 -{2}(addNr (reciprocal_pol l).[x1]) addrA - -{2}(opprK (_ _ x1)) subr_gte0 /=. - apply: le_trans (_ : k * (y' - x1) <= _)=> /=. - by rewrite /y' (addrC x1) addrK mulrN mulrC mulrVK // unitfE gt_eqF. - exact: sl. -have [u u0 up] := diff_xn_ub (size l - 1) _ (@ltr01 R). -have [u' u1 u'u] : exists2 u', (1 <= u')%R & (u <= u')%R. - case cmp: (1 <= u)%R; first by exists u => //; rewrite lexx cmp. - by exists 1%R; rewrite ?lexx // ltW // ltNge cmp. -have u'0 : (0 < u')%R by apply: lt_le_trans u1. -have divu_ltr (x : R) : (0 <= x)%R -> (x / u' <= x)%R. - by move=> x0; rewrite ler_pdivrMr// ler_peMr. -have y'0 : (0 < y')%R by apply: lt_trans y'1. -pose y := y' + 1. -have y'y : y' < y by rewrite /y ltrDl ltr01. -have y1 : x1 < y by apply: lt_trans y'1 _. -have ypos : (0 < (reciprocal_pol l).[y])%R. - apply: le_lt_trans y'pos _=> /=. - rewrite -subr_gte0 /=; apply: lt_le_trans (_ : k * (y - y') <= _)=> /=. - by rewrite mulr_gt0// subr_gt0. - by apply: sl=> //; apply: ltW. -have y0 : (0 < y)%R by apply: lt_trans y'y. -pose k' := ((k * x1 ^+ 2 * y ^- 1 ^+ (size l - 1))/(1+1)). -have k'p : (0 < k')%R. - rewrite /k' !mulr_gt0// ?invr_gt0 ?addr_gt0 ?ltr01//. - by rewrite exprn_gt0// invr_gt0. -pose e : R := k' / u'. -have ep: (0 < e)%R by rewrite divr_gt0. -have [e1 [e2 [e1p e2p e1e2e e1e e2e]]] := cut_epsilon _ ep. -have [[a b']] := @constructive_ivt _ (@reciprocal_pol _ l) _ _ _ y'1 nx1 y'pos e1p. -rewrite {1}/pair_in_interval. -move=> /and5P[/and3P[cla ? clb']]. -rewrite /pair_in_interval. -move=> /and3P[x1a ab b'y' nega posb' bma]. -have [c cp] := cm3 y y0 (reciprocal_pol l). -have a0 : (0 < a)%R by apply: lt_le_trans x1a. -have c0 : (0 < c)%R. - rewrite -(@pmulr_lgt0 _ (b' - a)) ?subr_gt0//. - rewrite (@lt_le_trans _ _ (`|(reciprocal_pol l).[b'] - - (reciprocal_pol l).[a] |))//; last first. - apply: cp. - - exact: ltW. - - exact: ltW. - - by rewrite (le_trans b'y')// ltW. - by rewrite normr_gt0// gt_eqF// subr_gt0. -have [b [b'b clb blty]] : exists b, [/\ b' < b, c * (b - b') < e2 & b <= y]. - have [e3 [e4 [e3p e4p e3e4e2 e3e2 e4e2]]] := cut_epsilon _ e2p. - case cmp : (b' + e2 / c <= y). - exists (b' + e3 / c); split. - - by rewrite ltrDl// divr_gt0. - - by rewrite (addrC b') addrK mulrA (mulrC c) mulfK // gt_eqF. - - apply: le_trans cmp; rewrite lerD2l//. - by rewrite ler_pM// ltW// invr_gt0. - exists y; split => //. - - by rewrite (le_lt_trans b'y'). - - by rewrite mulrC -ltr_pdivlMr// ltrBlDl ltNge cmp. -pose n := ((size l))%:R - 1. -have b'0 : (0 < b')%R by apply: lt_trans ab. -have b0 : (0 < b)%R by apply: lt_trans b'b. -have b'v0 : (0 < b'^-1)%R by rewrite invr_gte0. -have bv0 : (0 < b^-1)%R by rewrite invr_gte0. -have bb'v : b^-1 < b'^-1 by rewrite ltf_pV2. -exists b^-1, a^-1, k'; split => //. -- split => //. - + by rewrite (lt_le_trans bb'v)// lef_pV2// ltW. - + by rewrite invf_lt1// (lt_le_trans _ x1a). -- move => x x0 xb. - have xv0 : (0 < x^-1)%R by rewrite invr_gt0. - have xexp0 : (0 < x^-1 ^+ (size l - 1))%R by rewrite exprn_gt0. - have b'x : b' < x^-1. - by rewrite -(invrK b')// ltf_pV2// (le_lt_trans _ bb'v). - rewrite -(pmulr_rgt0 _ xexp0) -{2}[x]invrK -horner_reciprocal; last first. - by rewrite unitfE gt_eqF. - apply: (le_lt_trans posb'); rewrite -subr_gte0 /=. - apply: lt_le_trans (_ : k * (x^-1 - b') <= _)=> /=. - by rewrite mulr_gt0// subr_gt0. - by apply: sl => //; rewrite (le_trans x1a)// ltW. -- move => x a1x xlt1. - have x0 : (0 < x)%R by apply: lt_trans a1x; rewrite invr_gt0. - have xv0 : (0 < x^-1)%R by rewrite invr_gt0. - have x1a0 : (x^-1 < a)%R by rewrite -[a]invrK ltf_pV2// posrE// invr_gt0. - have xexp0 : (0 < x^-1 ^+ (size l - 1))%R by apply: exprn_gt0. - rewrite -(pmulr_rlt0 _ xexp0) -{2}[x]invrK -horner_reciprocal//; last first. - by rewrite unitfE gt_eqF. - case cmp: (x^-1 <= x1); last (move/negbT:cmp => cmp). - by apply: neg => //; rewrite -invr1 ltf_pV2// ?posrE ltr01//. - apply: lt_trans nega; rewrite -subr_gte0. - apply: lt_le_trans (_ : k * (a - x^-1) <= _). - by rewrite mulr_gt0// subr_gt0. - apply: sl => //. - rewrite -ltNge in cmp. - exact: ltW. -- move=> x z bvx + zav; rewrite le_eqVlt => /predU1P[->|xz]. - by rewrite !addrN mulr0 lexx. - have x0 : (0 < x)%R by apply: lt_trans bvx. - have z0 : (0 < z)%R by apply: (lt_trans x0). - have := horner_reciprocal1 l (unitf_gt0 x0) => ->. - have := horner_reciprocal1 l (unitf_gt0 z0) => ->. - rewrite (_ : _ * _ - _ = (x ^+ (size l - 1) - z ^+ (size l - 1)) * - (reciprocal_pol l).[x ^-1] + - ((reciprocal_pol l).[x ^-1] - - (reciprocal_pol l).[z ^-1]) * - z ^+ (size l - 1)); last first. - by rewrite !mulrDl !mulNr ![_.[_] * _]mulrC !addrA addrNK. - set t1 := _ * _.[_]. - set t3 := (_.[_] - _). - set t2 := t3 * _. - pose k1 := -k'; pose k2 := k' + k'. - have times2 : forall a : rat, a + a = (1 + 1) * a. - by move => a'; rewrite mulrDl !mul1r. - have k2p : k2 = (k * x1 ^+ 2 * y ^-1 ^+ (size l - 1)). - rewrite /k2 /k' -mulr2n -mulr_natl. - rewrite -(mulrC (1 + 1)^-1) mulrA mulfV; first by rewrite mul1r. - have twop : (0 < (1 + 1))%Q by []. - by rewrite gt_eqF// ltr0n. - rewrite (_ : k' = k1 + k2); last by rewrite /k1 /k2 addrA addNr add0r. - have x1ltvz : x1 < z ^-1. - by rewrite (le_lt_trans x1a) // -[a]invrK ltef_pV2 ?posrE ?invr_gt0 ?ltW. - rewrite mulrDl; apply: lerD; last first. - have maj' : t3 * y^-1 ^+ (size l - 1) <= t3 * z^+ (size l - 1). - have maj : y^-1 ^+(size l - 1) <= z ^+ (size l - 1). - case: (size l - 1)%N => [ | n']; first by rewrite !expr0 lexx. - have /pow_monotone : (0 <= y ^-1 <= z)%R. - rewrite ltW /=; last by rewrite invr_gt0 (lt_trans x10). - apply: ltW (le_lt_trans _ xz); apply: ltW (le_lt_trans _ bvx). - by rewrite lef_pV2 ?posrE. - by move=> /(_ n'.+1) /andP[]. - rewrite lter_pM2l // /t3. - apply: (lt_le_trans _ (_ : k * (x ^-1 - z ^-1) <= _)); last first. - apply: sl; first by apply: ltW. - by rewrite ltf_pV2. - by rewrite mulr_gt0 // subr_gt0 ltf_pV2. - apply: le_trans maj'; rewrite /t3 k2p mulrAC. - rewrite lter_pM2r; last by apply: exprn_gt0; rewrite invr_gt0. - apply: ltW (lt_le_trans _ (_ :k * (x ^-1 - z ^-1) <= _)). - rewrite ![k * _]mulrC mulrAC lter_pM2r; last by []. - rewrite -[x ^-1](mulrK (unitf_gt0 z0)). - rewrite -[X in _ < _ - X](mulrK (unitf_gt0 x0)) -(mulrC x) -(mulrC z). - rewrite (mulrAC x) -!(mulrA _ (x^-1)) -mulrBl (mulrC (z - x)). - rewrite lter_pM2r; last by rewrite subr_gte0. - apply: lt_le_trans (_ : x1 / z <= _); first by rewrite lter_pM2l. - rewrite lter_pM2r; last by rewrite invr_gte0. - by apply: ltW (lt_trans x1ltvz _); rewrite ltef_pV2 ?posrE. - apply: sl; first by apply: ltW. - by rewrite ltef_pV2 ?posrE. - rewrite /t1/k1/k' {t2 t3}. - have xzexp : (x ^+ (size l - 1) <= z ^+ (size l - 1)). - case sizep : (size l - 1)%N => [ | n']. - by rewrite !expr0 ltexx. - have /pow_monotone : (0 <= x <= z)%R. - by rewrite !ltW. - by move=>/(_ n'.+1)=> /andP[]. - case: (lerP 0 ((reciprocal_pol l).[x^-1])) => sign; last first. - apply: le_trans (_ : 0 <= _)%R. - rewrite mulNr lterNl oppr0; apply: mulr_ge0; last first. - by rewrite subr_gte0 ltW. - exact (ltW k'p). - by rewrite nmulr_lge0 // subr_lte0. - rewrite mulNr lterNl -mulNr opprB. - have rpxe : (reciprocal_pol l).[x^-1] <= e. - apply:le_trans (_ : (reciprocal_pol l).[b] <= _) => /=. - rewrite -subr_gte0 /= ; apply: le_trans (_ : k * (b - x^-1) <= _). - rewrite mulr_ge0 //. - exact: ltW. - by rewrite subr_ge0 ltW // -(invrK b) ltef_pV2 ?posrE. - apply: sl. - by apply: (ltW (lt_trans x1ltvz _)); rewrite ltef_pV2 ?posrE. - by rewrite -(invrK b) ltef_pV2 ?posrE. - rewrite -[_ _ b]addr0 -(addrN ((reciprocal_pol l).[b'])) addrA. - rewrite (addrC (_.[b])) -addrA; apply: le_trans e1e2e. - apply: lerD; first by []. - apply: (le_trans (ler_norm _)). - by apply/ltW/(le_lt_trans _ clb)/cp=> //; apply/ltW. - apply: le_trans (_ : (z^+ (size l - 1) - x ^+ (size l - 1)) * e <= _). - move: xzexp; rewrite -subr_gte0 le_eqVlt => /predU1P[<-|xzexp] /=. - by rewrite !mul0r. - by rewrite lter_pM2l. -rewrite [_ * e]mulrC; apply: le_trans (_ : e * (u' * (z - x)) <= _)=> /=. - rewrite ler_pM2l//. - apply: le_trans (_ : u * (z - x) <= _). - apply: up => //. - by apply: ltW. - apply: ltW (lt_trans zav _). - by rewrite invf_lt1 //; by apply: lt_le_trans x1a. - by rewrite ler_pM2r// subr_gt0. -rewrite mulrA. -rewrite ler_pM2r// ?subr_gt0//. -by rewrite /e divrK// unitfE gt_eqF. -Qed. - -(* TODO(rei) -Lemma Bernstein_isolate : forall a b l, a < b -> - alternate (Mobius l a b) -> one_root1 l a b. -Proof. -rewrite /Mobius => a b l altb alt. -rewrite (_ : a = a + (a - a)); last by rewrite addrN addr0. -rewrite (_ : b = a + (b - a)); last by rewrite (addrC b) addrA addrN add0r. -apply one_root1_translate. -rewrite addrN (_ : (b-a) = (b-a) * 1); last by rewrite mulr1. -rewrite (_ : 0 = (b-a) * 0); last by rewrite mulr0. -apply one_root1_expand; first by rewrite -(addrN a) lter_add2l. -apply one_root_reciprocate. -rewrite -[1]addr0; apply one_root2_translate. -by apply: alt_one_root2. -Qed. -*) diff --git a/theories/bern5.v b/theories/bern5.v deleted file mode 100644 index d905fb0..0000000 --- a/theories/bern5.v +++ /dev/null @@ -1,136 +0,0 @@ -Require Import ZArith List. -Open Scope Z_scope. - -(* Just a few programs to test the ideas. In particular, this shows - that the composition translate then expand, reciprocate, and again translate - does not yield directly the binomial coefficients, in the sens that - they do not give the coefficients in the Bernstein polynomial basis. - The discrepancy is simply a binomial coefficient. Fortunately this does - not the result on signs. -*) - -(* binomial coefficients *) - -Fixpoint bin (a b : nat) : Z := - match a, b with - O, O => 1 - | O, S q => 0 - | S p, O => 1 - | S p, S q => bin p (S q) + bin p q - end. - -(* Now, a re-definition of the arithmetic on polynomials. *) -(* Fixpoint expandr (l : list Z) (ratio : Z) : list Z := - match l with a::tl => a * ratio :: expandr tl ratio | nil => nil end. *) - -Fixpoint mysum (f : nat -> Z) (n:nat) := - match n with S p => f p + mysum f p | _ => 0 end. - -Fixpoint add_list (s1 s2 : list Z) := - match s1 with a::s1' => - match s2 with b::s2' => (a+b) :: add_list s1' s2' | _ => s1 end - | _ => s2 end. - -Fixpoint scal_mul (x : Z) (s : list Z) := - match s with a::s' => (x * a) :: scal_mul x s' | _ => nil end. - -Fixpoint mul_list (s1 s2 : list Z) := - match s1 with a::s1' => add_list (scal_mul a s2) (0::mul_list s1' s2) - | _ => nil end. - -Fixpoint power_list (s1 : list Z) (n : nat) := - match n with S p => mul_list s1 (power_list s1 p) | _ => 1::nil end. - -Fixpoint compose_list (s1 s2 : list Z) := - match s1 with - a::nil => a::nil - | a::s1' => add_list (a::nil) (mul_list s2 (compose_list s1' s2)) - | _ => nil end. - -Definition expandr (s1 : list Z) (ratio : Z) := - compose_list s1 (0::ratio::nil). - -Definition transr (s : list Z) (offset : Z) : list Z := - compose_list s (offset :: 1 :: nil). - -Fixpoint recipr n (s : list Z) := - match n with S p => - match s with a::tl => (recipr p tl)++(a::nil) - | nil => (recipr p nil)++(0::nil) end - | 0%nat => nil - end. - -Definition bc n s l r := transr (recipr n (expandr (transr s l) (r - l))) 1. - -(* Bernstein basis of degree 5 for the interval (0,1) - is : bin 5 i * (1 - X)^(5-i) * x ^i *) - -Definition B5_ (i:nat) := - fun x : Z => (bin 5 i) * Zpower_nat x (5 - i) * Zpower_nat (1 - x) i. - -Definition B5'_(i : nat) (l r : Z) := - fun x : Z => - bin 5 i * Zpower_nat (x - l) (5 - i) * Zpower_nat (r - x) i. - -Definition pol_from_B (a b c d e f x : Z) := - a * B5_(0) x + b * B5_(1) x + c * B5_(2) x + d * B5_(3) x + - e * B5_(4) x + f * B5_(5) x. - -(* Working on integers brings a stupid constraint, because of division - by the size of interval at power 5. *) - -Definition pol_from_B' (l r a b c d e f x : Z) := - a * B5'_(0) l r x + b * B5'_(1)l r x + c * B5'_(2)l r x + d * B5'_(3)l r x + - e * B5'_(4)l r x + f * B5'_(5)l r x. - -(* NB(rei): couldn't figure out how to make the code below go through -Require Import FunInd. -Functional Scheme iter_nat_ind := Induction for iter_nat Sort Prop. - -(* Using Coq as a symbolic engine to compute some polynomials from - their Bernstein coefficients. *) - -Ltac expand_bernstein := - intros; unfold pol_from_B, B5_, pol_from_B', B5'_; simpl minus; simpl bin; - unfold Zpower_nat; repeat rewrite iter_nat_equation; ring_simplify. - -Lemma example1 : - forall x, pol_from_B 1 4 1 (-5) 3 1 x = - (55*x^5 - 205 * x^4 + 240*x^3 - 100 * x^ 2 + 10 * x + 1). -intros x; expand_bernstein. -trivial. -Qed. - -Lemma example2 : - forall x, pol_from_B' 2 4 1 4 1 (-5) 3 1 x = 55 * x^5 - 960 * x ^ 4 - + 6440 * x ^ 3 - 20800 * x ^ 2 + 32400 * x - 19488. -intros x; expand_bernstein. -reflexivity. -Qed. - -(* This list of coefficients is taken from the expanded formula exhibited - in the lemma example1. *) -Definition ex1 : list Z := 1::10::(-100)::240::(-205)::55::nil. - -Definition ex2 : list Z := (-19488)::32400::(-20800)::6440::-960::55::nil. - -Fixpoint zip (f : Z -> Z -> Z) (l1 l2 : list Z) := - match l1, l2 with a::l1', b::l2' => f a b::zip f l1' l2' | _, _ => nil end. - -Lemma bc_right1 : bc 6 ex1 (0) (1) = - zip Zmult (1::4::1::(-5)::3::1::nil) - (map (fun x => bin 5 x) (seq 0 6)). -unfold bc, ex1, seq. -simpl zip. -unfold expandr; simpl compose_list. -simpl recipr. -compute. -reflexivity. -Qed. - -Lemma bc_right2 : bc 6 ex2 2 4 = - zip Zmult (1::4::1::(-5)::3::1::nil) - (map (fun x => (4 - 2) ^ 5 * bin 5 x) (seq 0 6)). -reflexivity. -Qed. -*) diff --git a/theories/casteljau.v b/theories/casteljau.v deleted file mode 100644 index 6f1c6bb..0000000 --- a/theories/casteljau.v +++ /dev/null @@ -1,1846 +0,0 @@ -From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat binomial seq choice order. -From mathcomp Require Import fintype bigop ssralg poly ssrnum ssrint rat ssrnum archimedean. -From mathcomp Require Import polyrcf qe_rcf_th realalg. -Require Import pol poly_normal desc. - -(******************************************************************************) -(* de_casteljau == De Casteljau's algorithm *) -(* dicho' b i := de_casteljau b i 0 *) -(* dicho p b i := de_casteljau b (p - i) i *) -(* bernp a b p i == Bernstein polynomial of degree p for a, b for 0 <= i <= p *) -(******************************************************************************) - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Import Order.Theory. -Import GRing.Theory. -Import Num.Theory Num.Def. -Local Open Scope ring_scope. - -(* A technical binomial identity for the proof of de Casteljau *) -Lemma util_C : forall n i j : nat, (i <= j)%nat -> (j <= n)%nat -> - ('C(n, i) * 'C(n-i, j-i) = 'C(j, i) * 'C(n, j))%nat. -Proof. -move => n i j ij jn. -apply/eqP; rewrite -(@eqn_pmul2r ( i`! * (n - i) `!)); - last by rewrite muln_gt0; apply/andP; split; apply: fact_gt0. -rewrite -(@eqn_pmul2r ((j - i)`! * ((n - i)-(j - i))`!)); last first. - by rewrite muln_gt0; apply/andP; split; apply: fact_gt0. -have ilen : (i <= n)%nat by apply: leq_trans jn. -rewrite (mulnAC 'C(n, i)) -mulnA !bin_fact //; last by apply: leq_sub2r. -rewrite !mulnA (mulnAC _ _ (i`!)) 2!(mulnAC _ _ ((j-i)`!)) -(mulnA 'C(j, i)). -rewrite bin_fact // -subnDA subnKC // mulnAC (mulnC j`!) -(mulnA _ j`!). -by rewrite bin_fact. -Qed. - -Section ToBeAddedInOrderedAlg. - -Variable F : numFieldType. - -Lemma normr_sum : forall m (G : nat -> F), - `|\sum_(i < m) G i| <= \sum_(i < m) `|G i|. -Proof. -elim=> [|m ihm] G; first by rewrite !big_ord0 normr0. -rewrite !big_ord_recr /=; apply: le_trans (ler_normD _ _) _=> /=. -by rewrite lerD2r; exact: ihm. -Qed. - -Lemma expf_gt1 : forall m (x : F), x > 1 -> x^+m.+1 > 1. -Proof. -elim => [|m ihm] x hx; first by rewrite expr1. -apply: lt_trans (hx) _ => /=; rewrite exprS -{1}(mulr1 x). -rewrite ltr_pM2l; first exact: ihm. -apply: lt_trans hx; exact: ltr01. -Qed. - -Lemma expf_ge1 : forall m (x : F), x >= 1 -> x^+m >= 1. -Proof. -elim => [|m ihm] x hx; first by rewrite expr0 lexx. -apply: le_trans (hx) _ => /=; rewrite exprS. (* -{1}(mulr1 x). *) -rewrite ler_pMr; first exact: ihm. -apply: lt_le_trans hx; exact: ltr01. -Qed. - -End ToBeAddedInOrderedAlg. - -Section ToBeAddedInPoly. - -Variable R : idomainType. - -(* A remark, lemma size_Xma should be with addition *) -Lemma size_factor_expr : forall (t : R)(n : nat), - size (('X + t%:P)^+n) = n.+1. -Proof. -move=> t; elim=> [|n ihn]; first by rewrite expr0 size_polyC oner_eq0. -rewrite exprS size_monicM //; last first. - by rewrite -size_poly_eq0 ihn; apply/negP; move/eqP. - by rewrite -(opprK t%:P) -polyCN monicXsubC. -by rewrite ihn -(opprK t%:P) -polyCN size_XsubC. -Qed. - -Lemma size_amul_expr : forall (t c : R)(i : nat), - c != 0 -> size (('X * c%:P + t%:P) ^+ i) = i.+1. -Proof. -move=> t c; elim=> [| i ih] cn0; first by rewrite expr0 size_poly1. -have hn0 : size ('X * c%:P + t%:P) = 2%N. - rewrite mulrC size_MXaddC polyC_eq0. - move: cn0; rewrite -eqbF_neg=> /eqP => cn0. - by rewrite size_polyC cn0 andFb. -by rewrite exprS size_mul // ?expf_eq0 -?size_poly_eq0 hn0 ?andbF // ih. -Qed. - -Lemma size_factor (x : R) : size ('X + x%:P) = 2%N. -Proof. -by rewrite size_addl ?size_polyX // size_polyC /=; case: (x == 0). -Qed. - -Lemma size_polyX_mul (p : {poly R}) : - size ('X * p) = if p == 0 then 0%nat else (size p).+1. -Proof. -rewrite (_ : 'X * p = p * 'X + 0%:P); last by rewrite mulrC addr0. - by rewrite size_MXaddC eqxx andbT. -Qed. - -Lemma coef_poly0 (p q : {poly R}) : (p * q)`_0 = p`_0 * q`_0. -Proof. -by rewrite coef_mul_poly big_ord_recl big_ord0 sub0n addr0. -Qed. - -End ToBeAddedInPoly. -(* We prove the Cauchy bound in any ordered field *) - -Section CauchyBound. - -Variable F : realFieldType. - -Variables (n : nat)(E : nat -> F). - -Hypothesis pnz : E n != 0. - -Lemma CauchyBound x: (\poly_(i < n.+1) E i).[x] = 0 -> - `| x | <= `|E n|^-1 * \sum_(i < n.+1) `|E i|. -Proof. -move=> px0; case: (lerP `|x| 1)=> cx1. - set C := _ * _; suff leC1 : 1 <= C by apply: le_trans leC1. - have h1 : `|E n| > 0 by rewrite normr_gt0. - rewrite -(ler_pM2l h1) /= mulr1 /C mulrA mulfV ?normr_eq0 // mul1r. - by rewrite big_ord_recr /= -{1}(add0r `|E n|) lerD2r sumr_ge0. -case e: n=> [| m]. - move: pnz; rewrite -px0 e horner_poly big_ord_recl big_ord0 /=. - by rewrite addr0 expr0 mulr1 /= eqxx. -have h1 : E m.+1 * x^+m.+1 = - \sum_(i < m.+1) E i * x^+ i. - apply/eqP; rewrite -subr_eq0 opprK -{2}px0 horner_poly (big_ord_recr n). - by rewrite e //= addrC. -case x0 : (x == 0). - by rewrite (eqP x0) normr0 mulr_ge0 ?sumr_ge0// invr_gte0. -have {h1} h2 : E m.+1 * x = - \sum_(i < m.+1) E i * x^-(m - i). -have xmn0 : ~~ (x^+m == 0) by rewrite expf_eq0 x0 andbF. - apply: (mulIf xmn0); rewrite mulNr big_distrl /= -mulrA -exprS h1. - congr (- _); apply: congr_big; [by [] | by [] |] => [[i hi]] _ /=. - have mi : m = (m - i + i)%N by rewrite subnK. - rewrite {2}mi exprD -!mulrA; congr (_ * _); rewrite mulrA mulVf ?mul1r //. - by rewrite expf_eq0 x0 andbF. -have h3 : `|\sum_(i < m.+1) E i / x ^+ (m - i) | <= \sum_(i < m.+2) `|E i|. - apply: le_trans (normr_sum m.+1 (fun i => E i / x ^+ (m - i))) _. - apply: (@le_trans _ _ (\sum_(i < m.+1) `|E i|)); last first. - by rewrite (big_ord_recr m.+1) /= lerDl /= normr_ge0. - suff h: forall i, (i < m.+1)%N -> `|E i/x^+(m-i)| <= `|E i|. - by apply: ler_sum => //= i _; exact: h. - move=> i lti; rewrite normrM -{2}(mulr1 (`|E i|)) ler_wpM2l ?normr_ge0 //. - rewrite normfV normrX invf_le1; first by rewrite exprn_cp1 // ltW. - by rewrite exprn_gt0 // (lt_trans ltr01). -rewrite lter_pdivlMl; last by rewrite normr_gt0 -e. -by apply: le_trans h3=> /=; rewrite -normrM h2 normrN lexx. -Qed. - -End CauchyBound. - -(* -Section TranslateProps. - -(* First linearity lemma : translate complies with scalar product for *) -(* elements of the basis *) - -(* -(* Second linearity lemma : translate complies with addition *) -Lemma translate_add : forall l1 l2 c, - size l1 = size l2 -> - shift_poly (map (fun x : Qcb * Qcb => x.1 + x.2) (zip l1 l2)) c = - map (fun x => x.1 + x.2) (zip (shift_poly l1 c) (shift_poly l2 c)). -Proof. -move=> l1 l2 c e; apply: (@eq_from_nth _ 0); rewrite size_shift_poly !size_map. - by rewrite !size1_zip ?size_shift_poly // e. -move=> i; rewrite size1_zip ?e // => his; rewrite translate_nth; last first. - by rewrite size_map size2_zip // e. -rewrite size_map size1_zip ?e //= (nth_map (0, 0)); last first. - by rewrite size2_zip ?size_shift_poly // e /=. -rewrite nth_zip ?size_shift_poly // !translate_nth // ?e //=. -rewrite -big_split /=; apply: congr_big=> // [[k hk]] _ /=. -rewrite (nth_map (0, 0)) ?size2_zip // ?e // nth_zip //= mulr_addl. -by rewrite mulrn_addl. -Qed. - -Lemma translate_mulX : forall (q1 q2 : {poly Qcb}) c, - q2 != 0 -> q1 != 0 -> - shift_poly q2 c = q1 -> shift_poly ('X * q2) c = ('X + c%:P) * q1. -Proof. - move=> q1 q2 c q2n0 q1n0 e. - have sp1 : size (shift_poly ('X * q2) c) = (size q2).+1. - by rewrite size_shift_poly size_mul_id // -?size_poly_eq0 ?size_polyX. - have sp2 : size ('X * q2) = (size q2).+1. - by rewrite mulrC size_mul_monic ?monicX // size_polyX !addnS addn0. - apply: (@eq_from_nth _ 0). - by rewrite sp1 size_mul_id // -?size_poly_eq0 ?size_factor // -e size_shift_poly. - rewrite sp1 => [[_|j hj]]. - rewrite translate_nth ?size_polyX_mul ?(negPf q2n0) //. - rewrite coef_poly0 coef_add coefC eqxx coefX add0r -e /shift_poly. - rewrite !nth_mkseq ?lt0n ?size_poly_eq0 // -?size_poly_eq0 ?sp2 //. - rewrite big_distrr big_ord_recl coef_Xmul eqxx mul0r mul0rn add0r. - apply: congr_big=> // [[k hk]] _. - rewrite !bin0 !subn0 !mulr1n -[('X * q2)`__]/(('X * q2)`_k.+1). - rewrite [GRing.muloid _ _]/= [c * _]mulrC. - rewrite -mulrA [_ * c]mulrC -exprS; congr (_ * _). - (* we should really put a nosimpl on `_ *) - by rewrite coef_Xmul /=. - rewrite /shift_poly nth_mkseq ?sp2 //. - rewrite coef_mul; apply: sym_eq; rewrite 2!big_ord_recl big1; last first. - case=> k hk _; rewrite -[('X + c%:P)`_ _]/(('X + c%:P)`_ k.+2). - by rewrite coef_add coefC coefX /= addr0 mul0r. - rewrite [nat_of_ord _]/= !subn0 addr0 -[nat_of_ord _]/1%N. - rewrite !coef_add !coefX !coefC !eqxx -![_ == _]/false add0r addr0 mul1r. - rewrite -e /shift_poly. - rewrite big_ord_recl coef_Xmul eqxx mul0r mul0rn add0r subSS subn0. - move: hj; rewrite ltnS leq_eqVlt; case/orP. - move/eqP=> ej; rewrite ej nth_default ?size_mkseq ?leqnn // mulr0 add0r. - rewrite nth_mkseq -?ej //; apply: congr_big => // [[k hk]] _. - rewrite -[('X * q2)`_ _]/(('X * q2)`_k.+1) subSS coef_Xmul -[_ == 0%N]/false /=. - move: hk; rewrite ltnS leq_eqVlt; case/orP; first by move/eqP->; rewrite !binn. - move=> hkj; rewrite !bin_small //. - move=> hjs. rewrite !nth_mkseq //; last by apply: ltn_trans hjs. - rewrite big_distrr -big_split; apply: congr_big=> // [[k hk]] _. - rewrite -[('X * q2)`_ _]/(('X * q2)`_k.+1) coef_Xmul /= subSS. - rewrite -mulrnAl mulrC -mulrA [_ * c]mulrC -exprS {hjs hk}. - case: (ltngtP k j) => ekj. - - by rewrite !bin_small //; apply: ltn_trans ekj _. - - by rewrite -ltn_subS // mulrnAl -mulrn_addr -binS. - - rewrite ekj !binn subnn bin_small // (_ : j - j.+1 = 0)%N; last first. - by apply/eqP; rewrite subn_eq0. - by rewrite !mulr0n mul0r add0r expr0. -Qed. - -Lemma shift_polyXn : forall (c : Qcb) i, - (shift_poly 'X^i c) = ('X + c%:P)^+i. -Proof. -move=> c i; rewrite -(mulr1 'X^i); elim: i => [| i ihi]. - rewrite !expr0 mulr1 /shift_poly size_polyC oner_eq0 /=. - rewrite /mkseq /= big_ord_recl big_ord0 subn0 bin0 addr0 expr0 mulr1 mulr1n. - by rewrite -polyC1 coefC eqxx polyseqC oner_eq0. -rewrite exprS -mulrA. -rewrite (translate_mulX _ _ _ _ _ ihi) ?exprS // ?mulr1 -size_poly_eq0. - by rewrite size_polyXn. -by rewrite size_factor_expr. -Qed. - -Lemma translate_mulXn : forall n (q1 q2 : {poly Qcb}) c, q2 != 0 -> q1 != 0 -> - q2 \shift c = q1 -> - ('X^n * q2) \shift c = ('X + c%:P)^+n * q1. -Proof. -elim=> [|n ihn] q1 q2 c nq20 nq10 e; first by rewrite expr0 !mul1r. -rewrite exprS -mulrA. -have h : shift_poly ('X^n * q2) c = ('X + c%:P) ^+ n * q1. - by rewrite (ihn q1 q2). -rewrite (translate_mulX _ _ _ _ _ h); first by rewrite mulrA -exprS. - rewrite -size_poly_eq0 mulrC size_mul_monic ?monicXn // size_polyXn !addnS /=. - by rewrite addn_eq0 negb_and size_poly_eq0 nq20. -rewrite -size_poly_eq0 size_mul_id // -?size_poly_eq0 ?size_polyXn size_factor_expr //=. -by rewrite addn_eq0 negb_and size_poly_eq0 nq10 orbT. -Qed. - -(* to be cleaned: a simple induction is probably enough *) -Lemma translate_padded_l : forall (i : nat) (q : seq Qcb)(c : Qcb) , - shift_poly (q ++ (nseq i 0)) c = (shift_poly q c) ++ (nseq i 0). -Proof. -move=> n; elim: n {-2}n (leqnn n) => [| i hi] n hn q c. - by move: hn; rewrite leqn0; move/eqP->; rewrite !cats0. -move: hn; rewrite leq_eqVlt; case/orP; last by move=> hn; rewrite hi //. -move/eqP->; rewrite -[q ++ _]/(q ++ nseq 1 0 ++ nseq i 0) catA hi //. -rewrite /shift_poly size_cat size_nseq addnS addn0. -rewrite -[nseq i.+1 0]/([:: 0] ++ nseq i 0) catA; congr (_ ++ _). -apply: (@eq_from_nth _ 0). - by rewrite size_cat /= !size_mkseq size_map size_iota addn1. -rewrite size_mkseq => j; rewrite ltnS leq_eqVlt; case/orP=> hj. - rewrite (eqP hj) nth_mkseq // nth_cat size_mkseq ltnn subnn /= big1 //. - case=> k /=; rewrite ltnS leq_eqVlt; case/orP=> hk _. - rewrite (eqP hk) nth_cat ltnn subnn /= mul0r mul0rn //. - by rewrite nth_cat hk bin_small // mulrn0. -rewrite nth_cat size_mkseq hj !nth_mkseq //; last by apply: ltn_trans hj _. -rewrite big_ord_recr /= nth_cat ltnn subnn mul0r mul0rn addr0. -by apply: congr_big; [by [] | by [] |] => [[k hk]] _ /=; rewrite nth_cat hk. -Qed. - -Lemma translateXn_addr : forall c1 c2 n, - shift_poly (shift_poly 'X^n c1) c2 = shift_poly 'X^n (c1 + c2). -Proof. -move=> c1 c2 n. -apply: (@eq_from_nth _ 0); rewrite ?size_shift_poly //. -rewrite size_polyXn => i hi. -rewrite /shift_poly nth_mkseq ?size_mkseq ?size_polyXn // nth_mkseq //. -apply: trans_equal (_ : - \sum_(k < n.+1) (\sum_(k0 < n.+1)'X^n`_k0 * c1 ^+ (k0 - k) *+ - 'C(k0, k) * c2 ^+ (k - i) *+ 'C(k, i)) = _). - apply: congr_big => // [[k hk]] _ /=; rewrite nth_mkseq //. - by rewrite big_distrl /= -sumr_muln. -rewrite exchange_big /=. -apply: trans_equal (_ : -\sum_(j < n.+1) -\sum_(i0 < n.+1) 'X^n`_j * (c1 ^+ (j - i0) *+ 'C(j, i0) * c2 ^+ (i0 - i) *+ 'C(i0, i)) = _). - apply: congr_big=> // [[k hk]] _ /=; apply: congr_big=> // [[j hj]] _ /=. - by rewrite !mulrnAr !mulrA mulrnAr. -apply: congr_big=> // [[k hk]] _ /=; rewrite -big_distrr /=. -rewrite -mulrnAr; congr (_ * _). -rewrite -(subnKC hk) big_split_ord /= addrC big1; last first. - case=> j hj _ /=; rewrite bin_small; last by apply: ltn_addr. - by rewrite mulr0n mul0r mul0rn. -rewrite add0r; case: (ltngtP k.+1 i) => hki. - -rewrite bin_small //; last by apply: ltn_trans hki. - rewrite mulr0n big1 // => [[j hj]] _ /=; rewrite (@bin_small j); last first. - by apply: ltn_trans hj _. - by rewrite mulr0n. - - rewrite ltnS in hki. rewrite -{- 7 11 12}(subnKC hki) -addnS big_split_ord /= big1; last first. - by case=> j hj _ /=; rewrite (@bin_small j). - rewrite add0r exprn_addl -sumr_muln; apply: congr_big => // [[j hj]] _ /=. - rewrite subnKC // -subnDA [(i + _)%N]addnC -addn_subA // subnn addn0. - rewrite mulrnAl -!mulrnA; congr (_ *+ _). - rewrite [(_ * 'C(k, i))%N]mulnC {3}(_ : j = j + i - i)%N; last first. - by rewrite -addn_subA // subnn addn0. - by rewrite util_C 1?mulnC // ?leq_addl // -(subnK hki) leq_add2r. - - rewrite -hki bin_small // mulr0n big1 // => [[j hj]] /= _. - by rewrite (@bin_small j). -Qed. -*) -End TranslateProps. -*) - -(* -Section ReciprocateProps. - -Lemma reciprocate_padded : forall (i : nat) (q : seq Qcb), - reciprocate_pol (q ++ (nseq i 0)) = (nseq i 0) ++ (reciprocate_pol q). -Proof. -move=> i q; rewrite /reciprocate_pol rev_cat; congr (_ ++_). -apply: (@eq_from_nth _ 0); rewrite size_rev size_nseq // => j hij. -rewrite nth_rev ?size_nseq // !nth_ncons. -by case: i hij=> // i hij; rewrite ltnS subSS leq_subr hij. -Qed. - -End ReciprocateProps. - -*) - -(* -Section ExpandProps. - -Lemma expand_padded : forall (i : nat) (q : seq Qcb)(c : Qcb) , - expand (q ++ (nseq i 0)) c = (expand q c) ++ (nseq i 0). -Proof. -elim=> [| i ih] q c; first by rewrite !cats0. -rewrite -[q ++ _]/(q ++ [:: 0] ++ nseq i 0) catA ih. -suff {ih} -> : expand (q ++ cons 0 [::]) c = expand q c ++ [:: 0] by rewrite -catA. -apply: (@eq_from_nth _ 0); first by rewrite size_cat /expand !size_mkseq !size_cat. -rewrite /expand size_mkseq size_cat addnS addn0=> {i} i. -rewrite ltnS leq_eqVlt; case/orP. - move/eqP->; rewrite nth_cat nth_mkseq // size_mkseq ltnn subnn nth_cat ltnn. - by rewrite subnn /= mul0r. -move=> ltis; rewrite nth_mkseq; last by apply: ltn_trans ltis _. -by rewrite !nth_cat size_mkseq ltis nth_mkseq. -Qed. - -End ExpandProps. - -*) - -(* b gives the coefficients of a polynomial on some bounded interval [a, b]. -de_casteljau computest all the coefficients in the triangle for a, m, n, with -l := m - a and r := b - m. - -invariant : l + r = b - a *) - -Section DeCasteljauAlgo. - -Variable R : comRingType. - -Variables l r : R. - -Fixpoint de_casteljau (b : nat -> R) (n : nat) := - match n with - O => b - | i.+1 => fun j => - (l * de_casteljau b i j + r * de_casteljau b i j.+1)%R - end. - -(* b gives the B. coefficients of a polynomial on some bounded interval [a, b]. -computes the B. coefficients on [a, a + l] si b - a = l + r *) -Definition dicho' b i := de_casteljau b i 0. - -(* b gives the B. coefficients of a polynomial P on some bounded interval [a, b]. -computes the B. coefficients on [b-r, b] si b - a = l + r , as soon as p = deg P *) -Definition dicho p b i := de_casteljau b (p - i) i. - -(* the computation of the value at index (k, n) only uses values (i, j) - for n <= i <= n + k (a triangle, up and right) *) - -Lemma ext_dc : - forall k b b' n, (forall i, (n <= i)%nat -> (i <= n + k)%nat -> b i = b' i) -> - de_casteljau b k n = de_casteljau b' k n. -move => k b b'; elim: k => [ n q | k IHk n q] /=. - by apply: q; rewrite ?addn0 leqnn. -rewrite !IHk //; move => i ni nik; apply: q => //; first exact: ltnW. - by move: nik; rewrite addnS addSn. -by apply: leq_trans nik _; rewrite addnS leqnSn. -Qed. - -(* de_casteljau is linear with respect to coefficients *) -Lemma lin_dc : forall k a a' b b' n, - de_casteljau (fun j => (a * b j + a' * b' j)%R) k n = - (a * de_casteljau b k n + a' * de_casteljau b' k n)%R. -Proof. -elim => [ | k IHk] a a' b b' n /= ; first by []. -rewrite 2!IHk !mulrDr !mulrA !(mulrC r) !(mulrC l) !addrA. -by rewrite (addrAC _ _ (a' * l * _)%R). -Qed. - -(* in particular it is additive *) -Lemma add_dc k b b' n : - de_casteljau (fun j => b j + b' j)%R k n = - (de_casteljau b k n + de_casteljau b' k n)%R. -Proof. -have := lin_dc k 1 1 b b' n. -rewrite (@ext_dc k (fun j => 1 * b j + 1 * b' j) (fun j => b j + b' j))%R. - by rewrite !mul1r. -by move => x; rewrite /= !mul1r. -Qed. - -(* in particular it is homothetic *) -Lemma scal_dc k a b n : - de_casteljau (fun j => a * b j)%R k n = (a * de_casteljau b k n)%R. -Proof. -have := lin_dc k a 0 b (fun i => 0)%R n. -rewrite (@ext_dc _ (fun j => a * b j + 0 * 0)%R (fun j => a * b j)%R). - by rewrite mul0r addr0. -by move => x; rewrite /= mul0r addr0. -Qed. - -End DeCasteljauAlgo. - -Section DeltaSeqs. - -Variable R : rcfType. - -Definition delta (i j : nat) : R := if (i == j) then 1 else 0. - -Lemma dc_delta_head : forall j k l r, - (j < k)%nat -> dicho' l r (delta k) j = 0. -Proof. -rewrite /dicho' => j k l r hlt. -pose d0 := fun _ : nat => 0 : R. -rewrite (@ext_dc _ _ _ _ _ d0); last first. - move=> i; rewrite add0n /delta => h1 h2. - have : (i < k)%nat by apply: leq_ltn_trans hlt. - by rewrite ltn_neqAle; case/andP; rewrite eq_sym; move/negPf->. -elim: j {hlt} 0%nat=> [| j ihj n] /=; first by done. -by rewrite !ihj !mulr0 addr0. -Qed. - -(*Lemma translation_delta:*) -Lemma dc_deltaS : forall k A B i j, - de_casteljau A B (delta i.+1) k j.+1 = de_casteljau A B (delta i) k j. -Proof. -elim=> [|k ihk] A B i j /=; last by rewrite !ihk. -case e : (i == j); first by rewrite /delta (eqP e) !eqxx. -by rewrite /delta eqSS e. -Qed. - -(* algorithme applique a delta_i (colonne j > i)*) - (*Lemma coef_algo_delta_col_supi:*) -Lemma dc_delta_lt : forall k A B i j, (j > i)%nat -> de_casteljau A B (delta i) k j = 0. -Proof. -elim=> [|k ihk] A B i j hlt /=. - by move: hlt; rewrite ltn_neqAle; case/andP; move/negPf; rewrite /delta; move->. -rewrite !ihk // ?mulr0 ?addr0 //; apply: ltn_trans hlt _; exact: ltnSn. -Qed. - -(* algorithme applique a delta_i (ligne n ,colonne i)*) - -(*Lemma coef_algo_delta_col_i:*) -Lemma dcn_deltan : forall n i A B, de_casteljau A B (delta i%nat) n i = A ^+ n. -Proof. -elim=> [|n ihn] i A B /=; first by rewrite /delta eqxx expr0. -by rewrite !ihn dc_delta_lt ?ltnSn // mulr0 exprS addr0. -Qed. - -(* algorithme applique a delta_i (colonne k avec k < i - j, ligne j avec j < i)*) -(*Lemma coef_algo_delta_ligne_infi_k:*) -Lemma dc_delta_gt : forall j i A B, (j < i)%nat -> - forall k, (k < i - j)%nat -> de_casteljau A B (delta i) j k = 0. -Proof. -elim=> [| j ihj] i A B hltji k hltkd /=. - by move: hltkd; rewrite subn0 ltn_neqAle /delta eq_sym; case/andP; move/negPf->. -have ltij : (j < i)%nat by apply: ltn_trans hltji; rewrite ltnSn. -rewrite !ihj // ?mulr0 ?addr0 //; first by rewrite -subnSK. -by apply: ltn_trans hltkd _; rewrite -[(i - j)%nat]subnSK. -Qed. - -(* pourquoi on a un add_rec qui nous saute la figure??? *) - -Lemma dc_delta_tail : forall i k A B, - de_casteljau A B (delta i) (i + k)%nat 0 = A ^+ k * B ^+ i *+'C(k + i, i). -Proof. -elim=> [|i ihi] k A B /=; rewrite -?addnE. - by rewrite add0n addn0 /= expr0 mulr1 bin0 dcn_deltan mulr1n. -rewrite dc_deltaS ihi. -elim: k => [|k ihk] /=. - rewrite !add0n !expr0 !addn0 !mul1r dc_delta_gt ?mulr0 ?add0r 1?mulrC ?subSnn //. - by rewrite !binn !mulr1n exprS mulrC. -rewrite !addnS /= dc_deltaS ihi ihk !addnS !addSn !mulrnAr mulrA -exprS. -rewrite [_ * B^+ i]mulrC mulrA -exprS [B^+_ * _]mulrC -mulrnDr. -by congr (_ *+ _). -Qed. - -(* Lemma algo_reverse:*) -Lemma dc_reverse b (A B : R) p : forall i k, - (i <= p)%N -> - (k <= p - i)%N -> - de_casteljau B A (fun t => b (p - t)%N) i k = de_casteljau A B b i (p - (i + k)). -Proof. -elim=> [| i ihi] k hip hk /=; first by rewrite add0n. -rewrite addrC; congr (_ + _). - by rewrite ihi ?(ltnW hip) ?addnS ?addSn // -[(p - i)%N]subnSK. -rewrite ihi ?(leq_trans hk) // ?leq_sub2l // ?(ltnW hip) //=. -rewrite addSn -subnSK //. -by move:hk; rewrite -ltn_subRL -ltnS subnSK. -Qed. - -End DeltaSeqs. - -Section weighted_sum. - -(* TODO : I don't know what the right type is. *) -Variable R : rcfType. - -Lemma size_weighted_sum_leq (A :eqType) (r : seq A) m (f : A -> R) - (g : A -> {poly R}) : - (forall i, i \in r -> (size (g i) <= m)%N) -> - (size (\sum_(i <- r) f i *: g i)%R <= m)%N. -Proof. -elim: r => [_ | n r IH cg]; first by rewrite big_nil polyseq0. -rewrite big_cons (leq_trans (size_add _ _)) // geq_max. -have sn : (size (f n *: g n) <= m)%N. - case fn : (f n == 0); first by rewrite (eqP fn) scale0r size_poly0. - rewrite size_scale; last by rewrite fn. - by apply: (cg n); rewrite in_cons eqxx. -by rewrite sn /=; apply: IH => i ir; apply: cg; rewrite in_cons ir orbT. -Qed. - -End weighted_sum. - -(* NB(2022/07/04): MathComp PR in progress, use eq_poly *) -Lemma poly_ext (R : ringType) (n : nat) (E1 E2 : nat -> R) : - (forall i : nat, (i < n)%N -> E1 i = E2 i) -> - \poly_(i < n) E1 i = \poly_(i < n) E2 i. -Proof. -by move=> E; rewrite !poly_def; apply: eq_bigr => i _; rewrite E. -Qed. - -Section bernp. -Variables (R : rcfType) (a b : R) (deg : nat). - -(* elements of the Bernstein basis of degree p *) -Definition bernp (i : nat) : {poly R} := - ((b - a)^-deg)%:P * ('X - a%:P)^+i * (b%:P - 'X)^+(deg - i) *+ 'C(deg, i). - -Lemma size_bernp (neqab : a != b) (i : nat) : - (i <= deg)%N -> size (bernp i) = deg.+1. -Proof. -move=> id; rewrite /bernp. -rewrite -!mulrnAl -polyCMn -mulrA. -rewrite size_Cmul. - rewrite size_monicM. - rewrite size_exp_XsubC. - have <- : (-1)%:P * ('X - b%:P) = (b%:P - 'X). - by rewrite mulrBr polyCN !mulNr -polyCM mul1r opprK addrC mul1r. - rewrite exprMn_comm; last by apply: mulrC. - rewrite -polyC_exp size_Cmul; last first. - rewrite exprnP; apply: expfz_neq0. - by rewrite oppr_eq0 oner_neq0. - by rewrite size_exp_XsubC addSn /= addnS subnKC. - by apply/monic_exp/monicXsubC. - rewrite exprnP expfz_neq0 // -size_poly_eq0. - have -> : b%:P - 'X = (-1)%:P * 'X + b%:P. - by rewrite addrC polyCN mulNr mul1r. - rewrite size_MXaddC size_polyC. - by rewrite polyCN oppr_eq0 (negbTE (oner_neq0 _)) andFb. -rewrite mulrn_eq0 negb_or. -rewrite invr_neq0 ?andbT; first by rewrite -lt0n bin_gt0. -by rewrite expf_neq0 // subr_eq0 eq_sym. -Qed. - -Lemma bernp_gt0 i x : (i <= deg)%N -> a < x < b -> - 0 < (bernp i).[x]. -Proof. -move=> id /andP [ax xb]; rewrite /bernp hornerMn pmulrn_lgt0; last first. - by rewrite bin_gt0. -rewrite !hornerE. -apply mulr_gt0; first apply mulr_gt0. - by rewrite invr_gt0 exprn_gt0 // subr_gt0 (lt_trans ax). - by rewrite exprn_gt0 // subr_gt0. -by rewrite exprn_gt0 // subr_gt0. -Qed. - -End bernp. - -Section BernsteinPols. -Variables (R : rcfType) (a b : R) (deg : nat). -Hypothesis neqab : a != b. - -Definition relocate (q : {poly R}) : {poly R}:= - let s := size q in - (* 1st case : degree of q is too large for the current basis choice *) - if (deg.+1 < s)%N then 0 - else - (recip deg ((q \shift (- 1)) \scale (b - a))) \shift - a. - -Lemma recipE (q : {poly R}) : (size q <= deg.+1)%N -> - recip deg q = \poly_(i < deg.+1) q`_(deg - i). -Proof. -move=> sq. -have t : forall n m (E : nat -> R), 'X ^+ n * \poly_(i < m) E i = - \poly_(i < m + n) (E (i - n)%N *+ (n <= i)%N). - elim=> [ | n IH] m E. - rewrite expr0 mul1r addn0; rewrite !poly_def; apply: eq_bigr => i _. - by rewrite subn0 leq0n mulr1n. - rewrite exprS -mulrA IH !poly_def. - rewrite addnS big_ord_recl. - rewrite [X in _ *+ (n < X)]/nat_of_ord /= mulr0n scale0r add0r big_distrr. - apply: eq_bigr; move=> [i ci] _ /=; rewrite /bump leq0n add1n ltnS subSS. - by rewrite mulrC -scalerAl exprS mulrC. -rewrite /recip t subnKC // !poly_def; apply: eq_bigr. -move=> [i ci] _ /=; congr (_ *: _). -case h : (deg.+1 - size q <= i)%N. - rewrite mulr1n; congr (q`_ _); apply/eqP. - rewrite -(eqn_add2r (i - (deg.+1 - size q)).+1) subnK; last first. - by rewrite -(ltn_add2r (deg.+1 - size q)) subnK // addnC subnK. - rewrite -subSn // addnBA; last by apply/(leq_trans h)/leqnSn. - by rewrite addnS subnK // subKn. -move/negP: h;move/negP; rewrite -ltnNge => h. -rewrite mulr0n nth_default //. -rewrite -(leq_add2r i.+1) -subSS subnK //. -by rewrite addnC -(subnK sq) leq_add2r. -Qed. - -Lemma size_recip (q : {poly R}) : - (size q <= deg.+1 -> size (recip deg q) <= deg.+1)%N. -Proof. by move=> s; rewrite recipE // size_poly. Qed. - -Lemma poly_extend (m n : nat) (E : nat -> R) : - (m <= n)%N -> (forall i : nat, (m <= i < n)%N -> E i = 0) -> - \poly_(i < m) E i = \poly_(i < n) E i. -Proof. -move=> c e; rewrite !poly_def. -rewrite (big_ord_widen n (fun i => E i *: 'X^i) c) big_mkcond /=. -apply: eq_bigr; move=> [i ci] _ /=; case h: (i < m)%N => //. -rewrite e; first by rewrite scale0r. -by rewrite ci andbT leqNgt h. -Qed. - -Lemma recipK (q : {poly R}) : (size q <= deg.+1)%N -> - recip deg (recip deg q) = q. -Proof. -move=> s; rewrite recipE; last by rewrite size_recip. -rewrite -{2}[q]coefK (poly_extend s). - apply: poly_ext => i c; rewrite recipE // coef_poly. - rewrite subKn; last by rewrite -ltnS. - by rewrite (leq_ltn_trans _ (ltnSn deg)) // leq_subr. -by move=> i c; rewrite nth_default //; case/andP: c. -Qed. - -Lemma recipD : forall q1 q2 : {poly R}, (size q1 <= deg.+1)%N -> - (size q2 <= deg.+1)%N -> recip deg (q1 + q2) = recip deg q1 + recip deg q2. -Proof. -move=> q1 q2 s1 s2; rewrite !recipE // ?poly_def; last first. - by rewrite (leq_trans (size_add _ _)) // geq_max s1 s2. -have t : forall i : 'I_deg.+1, true -> (q1 + q2)`_(deg.+1 - i.+1) *: 'X^i = - q1`_(deg.+1 - i.+1) *: 'X^i + q2`_(deg.+1 - i.+1) *: 'X^i. - by move=> [i ci] _ /=; rewrite coef_add_poly scalerDl. -by rewrite (eq_bigr _ t) big_split. -Qed. - -Lemma recipZ (q : {poly R}) c : - (size q <= deg.+1)%N -> recip deg (c *: q) = c *: recip deg q. -Proof. -move=> s; rewrite !recipE // ?poly_def; last first. - case h : (c == 0); first by rewrite (eqP h) scale0r size_poly0. - by rewrite size_scale ?h. -rewrite -[_ *: (\sum_(_ < _) _)]mul_polyC big_distrr; apply:eq_bigr. -by move=> [i ci] _ /=; rewrite coefZ mul_polyC scalerA. -Qed. - -Lemma recipP (q : {poly R}) : size q = deg.+1 -> - recip deg q = reciprocal_pol q. -Proof. by move=> s; rewrite /recip s subnn expr0 mul1r. Qed. - -Lemma recip_scale_swap (q : {poly R}) c : c != 0 -> (size q <= deg.+1)%N -> - recip deg (q \scale c) = (c ^+ deg)%:P * recip deg q \scale c^-1. -Proof. -move=> c0 sz; rewrite !recipE //; last by rewrite size_scaleX. -rewrite !poly_def big_distrr /=. -rewrite [_ \scale c^-1]/scaleX_poly linear_sum; apply: eq_bigr. -move=> [i ci] _ /=; rewrite scaleX_polyE coef_poly. -case h: (deg - i < size q)%N; last first. - rewrite scale0r nth_default; last by rewrite leqNgt h. - by rewrite scale0r mulr0 comp_poly0. -rewrite comp_polyM comp_polyC comp_polyZ poly_comp_exp comp_polyX. -rewrite (mulrC 'X) exprMn scalerAl -!mul_polyC -!polyC_exp mulrA -!polyCM. -rewrite mulrA mulrAC [q`_ _ * _]mulrC; congr (_ %:P * _); congr (_ * _). -case h' : (i < deg)%N; first by rewrite exprVn expfB. -have -> : i = deg by apply/eqP; move: ci; rewrite ltnS leq_eqVlt h' orbF. -by rewrite subnn expr0 exprVn mulfV // expf_neq0. -Qed. - -Lemma bern_coeffs_mon : forall i, (i <= deg)%N -> - relocate 'X^i = ((b - a)^+deg * 'C(deg, i)%:R^-1)%:P * bernp a b deg (deg - i)%N. -Proof. -have nsba0 : ~~ (b - a == 0) by rewrite subr_eq0 eq_sym. -move=> i leqip. -rewrite /bernp polyCM mulrAC -mulr_natr !mulrA -polyCM mulfV; last first. - by rewrite expf_eq0 (negbTE nsba0) andbF. -rewrite mul1r -!mulrA -polyCMn -polyCM bin_sub // mulfV; last first. - by rewrite pnatr_eq0 -lt0n bin_gt0. -rewrite subKn // mulr1. -rewrite /relocate /recip size_polyXn ltnNge ltnS leqip /= shift_polyXn. -have -> // : forall c : R, c != 0 -> - (('X + (-1)%:P)^+ i) \scale c = ('X * c%:P + (-1)%:P)^+ i. - move=> c hc; rewrite scaleX_polyE size_factor_expr. - rewrite [(_ * _ + _) ^+ _]exprDn. - rewrite (reindex_inj rev_ord_inj) /=. - rewrite power_monom [LHS]poly_def; apply: eq_bigr => j _. - rewrite coef_poly subSS; have -> : (j < i.+1)%N by case j. - rewrite subKn; last by case j. - rewrite exprMn_comm; last by exact: mulrC. - rewrite -mulrA (mulrCA 'X^j) (mulrC 'X^j) -!polyC_exp !mul_polyC. - by rewrite scalerA !scalerMnl -(mulrC (c ^+ j)) mulrnAr bin_sub //; case j. -have -> // : forall c:R, c != 0 -> - reciprocal_pol (('X * c%:P + (-1)%:P) ^+ i) = (c%:P - 'X)^+i. - move=> c hc; rewrite reciprocalX reciprocal_monom // addrC. - by congr ((_ + _) ^+ _); rewrite mulrC mul_polyC scaleNr scale1r. -rewrite size_amul_expr // subSS /shift_poly comp_polyM !poly_comp_exp. -rewrite comp_polyD linearN /= !comp_polyX comp_polyC opprD -!polyCN opprK. -by rewrite polyCB addrAC !addrA addrK. -Qed. - -Lemma scaleS (p : {poly R}) (u v : R) : - (p \scale u) \scale v = p \scale (u * v). -Proof. -rewrite /scaleX_poly -comp_polyA comp_polyM !comp_polyC comp_polyX. -by rewrite -mulrA -polyCM [v * u]mulrC. -Qed. - -Lemma scaleZ (p : {poly R}) u v : (u *: p) \scale v = u *: (p \scale v). -Proof. -by rewrite /scaleX_poly linearZ. -Qed. - -Lemma scaleD (p q : {poly R}) u : (p + q) \shift u = p \shift u + (q \shift u). -Proof. -by apply: linearD. -Qed. - -(* TODO : move to another section and abstract over deg a b, maybe *) -Lemma recip0 : recip deg (0 :{poly R}) = 0. -Proof. -rewrite recipE; last by rewrite size_poly0. -by rewrite poly_def; apply: big1 => i _; rewrite polyseq0 nth_nil scale0r. -Qed. - -Lemma Mobius0 : Mobius deg a b (0 : {poly R}) = 0. -Proof. -by rewrite /Mobius /shift_poly linear0 /scaleX_poly !linear0 recip0 linear0. -Qed. - -Lemma recip_weighted_sum n (f : nat -> R) (g : nat -> {poly R}) : - (forall i : 'I_n, (size (g i) <= deg.+1)%N) -> - recip deg (\sum_(i < n) f i *: g i) = \sum_(i < n) f i *: (recip deg (g i)). -Proof. -elim: n => [ | n IH cg]; first by rewrite !big_ord0 recip0. -rewrite !big_ord_recr /=. -rewrite recipD; first last. - case fn0 : (f n == 0); first by rewrite (eqP fn0) scale0r size_poly0. - by rewrite size_scale ?fn0 // (cg ord_max). - apply: size_weighted_sum_leq. - by move=> [i ci] _; apply: (cg (Ordinal _)); rewrite ltnS ltnW. -rewrite IH ?recipZ //; first by apply: (cg ord_max). -by move=> [i ci]; apply: (cg (Ordinal _)); rewrite ltnS ltnW. -Qed. - -Lemma recip_sum n (g : nat -> {poly R}) : - (forall i : 'I_n, (size (g i) <= deg.+1)%N) -> - recip deg (\sum_(i < n) g i) = \sum_(i < n) recip deg (g i). -move=> cg; have bigc : forall i : 'I_n, true -> g i = 1 *: g i. - by move=> i _; rewrite scale1r. -rewrite (eq_bigr _ bigc). -rewrite (recip_weighted_sum (fun i => 1%R)); last by []. -by apply: eq_bigr=> i _; rewrite scale1r. -Qed. - -Lemma MobiusZ x (p : {poly R}) : -(* TODO: remove the size condition, but need to do it also for recipZ *) - (size p <= deg.+1)%N -> - Mobius deg a b (x *: p) = x *: Mobius deg a b p. -Proof. -move=> s; rewrite /Mobius /shift_poly /scaleX_poly /=. -rewrite !linearZ recipZ; last first. - rewrite /= !size_comp_poly2 //; first by rewrite size_XaddC. - by rewrite size_XmulC // subr_eq0 eq_sym. -by rewrite /= linearZ. -Qed. - -Lemma Mobius_weighted_sum n (f : nat -> R) (g : nat -> {poly R}) : - (forall i : 'I_n, (size (g i) <= deg.+1)%N) -> - Mobius deg a b (\sum_(i < n) f i *: g i) = - \sum_(i < n) f i *: Mobius deg a b (g i). -Proof. -rewrite /Mobius /shift_poly /scaleX_poly !linear_sum /= => cg. -have cbig : forall i: 'I_n, true -> - ((f i *: g i) \Po ('X + a%:P) \Po 'X * (b - a)%:P) = - f i *: ((g i \Po ('X + a%:P)) \Po 'X * (b - a)%:P). - by move=> i _; rewrite !linearZ. -rewrite (eq_bigr _ cbig). -rewrite (@recip_weighted_sum _ _ (fun i => (g i \shift a) \scale _)); - last first. - move=> i; rewrite !size_comp_poly2; first by apply: cg. - by apply: size_XaddC. - by apply: size_XmulC; rewrite subr_eq0 eq_sym. -by rewrite linear_sum; apply: eq_bigr => i _; rewrite linearZ. -Qed. - -Lemma relocate_weighted_sum n (f : nat -> R) (g : nat -> {poly R}) : - (forall i : 'I_n, (size (g i) <= deg.+1)%N) -> - relocate (\sum_(i < n) f i *: g i) = \sum_(i < n) f i *: relocate (g i). -Proof. -rewrite /relocate /shift_poly /scaleX_poly linear_sum /= => cg. -have s : (size (\sum_(i < n) (f i *: g i))%R <= deg.+1)%N. - apply: (leq_trans (size_sum _ _ _)). - by apply/bigmax_leqP => i _; apply/(leq_trans (size_scale_leq _ _))/cg. -rewrite ltnNge s linear_sum /=. -have s' : forall i : 'I_n, - (size (f i *: g i \Po ('X + (-1)%:P) \Po ('X * (b - a)%:P))%R <= deg.+1)%N. - move=> i; rewrite !size_comp_poly2. - by apply/(leq_trans (size_scale_leq _ _))/cg. - by apply: size_XaddC. - by apply: size_XmulC; rewrite subr_eq0 eq_sym. -rewrite (@recip_sum _ (fun i => (f i *: g i \shift -1) \scale (b - a)) s'). -rewrite linear_sum. -apply: eq_bigr => i _ /=. -rewrite ltnNge cg /=. -rewrite /shift_poly /scaleX_poly !linearZ recipZ ?linearZ //=. -rewrite !size_comp_poly2 //; first by apply: size_XaddC. -by apply: size_XmulC; rewrite subr_eq0 eq_sym. -Qed. - -Lemma scalep1 (p : {poly R}) : p \scale 1 = p. -Proof. -by rewrite /scaleX_poly mulr1 comp_polyXr. -Qed. - -Lemma MobiusK (q : {poly R}) : (size q <= deg.+1)%N -> - Mobius deg a b (relocate q) = (b-a) ^+deg *: q. -Proof. -move=> s; rewrite /relocate /Mobius ltnNge s /= /shift_poly. -rewrite -[X in (_ \Po (_ + _)) \Po (_ + X%:P)]opprK [(- - _)%:P]polyCN. -have ba : b - a != 0 by rewrite subr_eq0 eq_sym. -have bav : (b - a)^-1 != 0 by rewrite invr_eq0. -have s1 : (size (q \Po ('X + (-1)%:P)) <= deg.+1)%N. - by rewrite size_comp_poly2 // size_XaddC. -have rr : GRing.rreg ((b - a) ^+ deg). - by rewrite /GRing.rreg; apply: mulIf; rewrite expf_eq0 (negbTE ba) andbF. -rewrite comp_polyXaddC_K !recip_scale_swap //; last first. - by rewrite size_scaleX // mulrC rreg_size ?size_recip. - by rewrite mulrC rreg_size ?size_recip. -rewrite !mul_polyC recipZ; last first. - by apply: size_recip; rewrite size_comp_poly2 // size_XaddC. -rewrite !scalerA exprVn mulVf ?scale1r; last first. - by rewrite expf_eq0 (negbTE ba) andbF. -rewrite invrK recipK; last by rewrite size_comp_poly2 // size_XaddC. -rewrite !scaleZ scaleS mulfV // scalep1 linearZ /=. -rewrite -[X in (_ \Po _) \Po (_ + X%:P)]opprK (polyCN (-1)). -by rewrite comp_polyXaddC_K. -Qed. - -Lemma relocateK (q : {poly R}) : (size q <= deg.+1)%N -> - relocate (Mobius deg a b q) = (b-a) ^+deg *: q. -Proof. -move=> s; rewrite /relocate /Mobius. -rewrite size_comp_poly2; last by rewrite size_XaddC. -set sc := ((q \shift _) \scale _). -set sz := size _. -have dif : b - a != 0 by rewrite subr_eq0 eq_sym. -have t : (size sc <= deg.+1)%N. - by rewrite size_scaleX // size_comp_poly2 //; apply: size_XaddC. -have t' : (sz <= deg.+1)%N by apply: size_recip. -rewrite ltnNge t' /= -shift_polyD addNr. -rewrite [_ \shift 0]/shift_poly addr0 comp_polyXr. -(* TODO: we miss a scaleX_poly_linear canonical structure. - and lemma about composing scale operations. *) -rewrite recip_scale_swap // recipK // /sc mul_polyC /scaleX_poly linearZ /=. -rewrite -comp_polyA comp_polyM comp_polyX comp_polyC -mulrA -polyCM. -rewrite mulVf // mulr1 comp_polyXr. -transitivity ((b - a) ^+ deg *: ((q \shift a) \shift - a)). - exact: linearZ. -by rewrite /= shift_polyDK. -Qed. - -Lemma relocate0 (p : {poly R}) : (size p <= deg.+1)%N -> - (relocate p == 0) = (p == 0). -Proof. -move=> s; apply/idP/idP; last first. - move/eqP=> ->; rewrite /relocate /shift_poly /scaleX_poly !linear0. - by rewrite size_poly0 ltn0 recip0 linear0. -have bmax : (b - a) ^+ deg != 0 by rewrite expf_neq0 // subr_eq0 eq_sym. -move/eqP=> r0; rewrite -[p]mul1r -[1]/1%:P -(mulVf bmax) polyCM -mulrA. -rewrite !mul_polyC -MobiusK // r0 /Mobius /shift_poly /scaleX_poly !linear0. -by rewrite recip0 linear0 scaler0. -Qed. - -Lemma Mobius_bernp i : (i <= deg)%N -> - Mobius deg a b (bernp a b deg i) = ('C(deg, i))%:R *: 'X ^+ (deg - i). -Proof. -move=> ci; set u := _%:R; rewrite -(mul1r (bernp a b deg i)) -[1]/(1%:P). -have t : (b - a)^+deg/('C(deg, i))%:R != 0. - apply: mulf_neq0; first by rewrite expf_neq0 // subr_eq0 eq_sym. - by rewrite invr_neq0 // pnatr_eq0 -lt0n bin_gt0. -rewrite -(mulVf t) {t} polyCM -mulrA. -rewrite -bin_sub // -[X in bernp a b deg X](subKn ci) -bern_coeffs_mon; last first. - by rewrite leq_subr. -rewrite mul_polyC MobiusZ. - rewrite MobiusK; last first. - by rewrite size_polyXn ltnS leq_subr. - rewrite invfM scalerA mulrAC mulVf; last first. - by rewrite expf_neq0 // subr_eq0 eq_sym. - by rewrite mul1r invrK bin_sub. -(* TODO : make a seprate lemma from this goal. *) -rewrite /relocate. -rewrite ltnNge size_polyXn (leq_ltn_trans _ (ltnSn _)) ?leq_subr //=. -rewrite size_comp_poly2; last by rewrite size_XaddC. -rewrite size_recip // !size_comp_poly2 //. - by rewrite size_polyXn (leq_ltn_trans _ (ltnSn _)) // leq_subr. - by rewrite size_XaddC. -by rewrite size_XmulC // subr_eq0 eq_sym. -Qed. - -Lemma monomial_free n (l : nat -> R): - \sum_(i < n) l i *: 'X ^+i == 0 -> forall i, (i < n)%N -> l i = 0. -Proof. -elim:n => [ | n IH] /=; first by move=> _ i; rewrite ltn0. -rewrite big_ord_recr /=. -case r : (l n == 0). - rewrite (eqP r) scale0r addr0; move/IH=>{IH} II i. - rewrite ltnS leq_eqVlt => /predU1P[->|]. - exact/eqP. - exact: II. -rewrite addr_eq0 => abs. -case/negP: (negbT (ltnn n)). -rewrite [X in (X <= _)%N](_ : _ = size (l n *: 'X^n)); last first. - by rewrite -mul_polyC size_Cmul ?r // size_polyXn. -rewrite -size_opp -(eqP abs) size_weighted_sum_leq //. -by move=> [i ci]; rewrite /= size_polyXn. -Qed. - -Lemma bernp_free : forall (l : nat -> R), - \sum_(i < deg.+1) l i *: bernp a b deg i = 0 -> forall i : 'I_deg.+1, l i = 0. -Proof. -have bman0 : b - a != 0 by rewrite subr_eq0 eq_sym. -move/(expf_neq0 deg): (bman0) => bmadeg. -move=> l; rewrite -[X in X = 0]scale1r -(mulVf bmadeg) -scalerA. -rewrite -relocateK; last first. - apply (leq_trans (size_sum _ _ _)); apply/bigmax_leqP. - move=> i _; apply: (leq_trans (size_scale_leq _ _)). - by rewrite size_bernp ?leqnn //; case : i => i /=; rewrite ltnS. -move/eqP; rewrite scaler_eq0 invr_eq0 (negbTE bmadeg) orFb. -have t : forall i : 'I_deg.+1, (size (bernp a b deg i) <= deg.+1)%N. - by move=> [i ci] /=; rewrite size_bernp. -rewrite (Mobius_weighted_sum l t) {t}. -have xdi : forall i, (i < deg.+1)%N -> size (('X : {poly R}) ^+i) = i.+1. - by move=> i; rewrite -['X]subr0 size_exp_XsubC. -have t: forall i : nat, (i < deg.+1)%N -> Mobius deg a b (bernp a b deg i) = - ('C(deg, i)%:R)%:P * 'X ^+ (deg - i). - move=> i ci. - rewrite (_ : bernp a b deg i = - ('C(deg, i)%:R / (b - a)^+ deg)%:P * - (((b - a) ^+ deg / 'C(deg, deg - i)%:R)%:P * - bernp a b deg (deg - (deg - i)))); last first. - rewrite mulrA -polyCM !mulrA mulfVK //. - rewrite bin_sub // mulfV ?mul1r ?subKn // pnatr_eq0. - by rewrite -lt0n bin_gt0. - have di : (deg - i <= deg)%N by rewrite leq_subr. - rewrite -bern_coeffs_mon // !mul_polyC MobiusZ; last first. - rewrite /relocate /shift_poly /scaleX_poly xdi; last by rewrite ltnS. - rewrite ltnNge ltnS di /=. - rewrite size_comp_poly2; last by rewrite size_XaddC. - rewrite size_recip // !size_comp_poly2 ?xdi ?ltnS //. - by rewrite size_XaddC. - by rewrite size_XmulC. - by rewrite MobiusK ?xdi ?ltnS // -!mul_polyC mulrA -polyCM mulfVK. -rewrite relocate0; last first. - have T : forall i : 'I_deg.+1, - (size (Mobius deg a b (bernp a b deg i)) <= deg.+1)%N. - move=> [i ci]; rewrite t //. - rewrite size_Cmul; last by rewrite pnatr_eq0 -lt0n bin_gt0. - by rewrite xdi; rewrite ltnS leq_subr. - apply: size_weighted_sum_leq => i _; apply: T. -rewrite -(big_mkord (fun _ => true) - (fun i => l i *: Mobius deg a b (bernp a b deg i))) big_nat_rev /= add0n. -have t' : forall i, (0 <= i < deg.+1)%N -> - l (deg.+1 - i.+1)%N *: Mobius deg a b (bernp a b deg (deg.+1 - i.+1)) = - (l (deg - i)%N * ('C(deg, deg - i))%:R) *: 'X^i. - move=> i;case/andP=> _ ci. - rewrite subSS t; last by rewrite ltnS leq_subr. - by rewrite -!mul_polyC mulrA polyCM subKn. -rewrite (eq_big_nat _ _ t') big_mkord => t2. -have t3 := (@monomial_free _ - (fun i => l (deg - i)%N * ('C(deg, deg - i))%:R) t2). -move=> [i ci] /=. -have t4 : ('C(deg, i))%:R != 0 :> R. - by rewrite pnatr_eq0 -lt0n bin_gt0. -apply: (mulIf t4); rewrite mul0r. -have t5: (i <= deg)%N by rewrite -ltnS. -rewrite -(subKn t5); apply: t3. -by rewrite ltnS leq_subr. -Qed. - -End BernsteinPols. - -Section dicho_proofs. - -Variable R : rcfType. - -Lemma dicho'_delta_bern (a b m : R) k p (alpha := (b - m) * (b - a)^-1) - (beta := ((m - a) * (b - a)^-1)) : - a != b -> m != a -> (k <= p)%N -> - bernp a b p k = - \sum_(j < p.+1)((dicho' alpha beta (delta R k) j)%:P * bernp a m p j). -Proof. -move=> dab dma hlt1. -rewrite -(big_mkord -(fun _ => true) -(fun j => (dicho' alpha beta (delta R k) j)%:P * bernp a m p j)). -rewrite (big_cat_nat _ _ _ (leq0n k)) //=; last by apply: leq_trans hlt1 _; exact: leqnSn. -rewrite (_ : \sum_( _ <= i0 < _ ) _ = 0) /= ?add0r; last first. - rewrite big1_seq //= => j; rewrite mem_iota add0n subn0; case/andP=> _ h. - by rewrite dc_delta_head // polyC0 mul0r. -rewrite -{2}(add0n k) big_addn. -have h : forall i0, (0 <= i0 < p - k)%nat -> - (dicho' (m - a) (b - m) (delta R k) (i0 + k))%:P * bernp a m p (i0 + k) = - (( (m - a) ^+ i0) * (b - m) ^+ k)%:P * bernp a m p (i0 + k) *+ 'C(i0 + k, k). - by move=> j h; rewrite /dicho' addnC dc_delta_tail polyCMn -mulrnAl addnC. -have -> : bernp a b p k = - (('X - a%:P)^+k * ((b - a)^-k)%:P) * - ((b%:P - 'X )^+(p - k) * ((b - a)^-(p - k))%:P) *+'C(p, k). - rewrite /bernp -!mulrA. congr (_ *+ _). - rewrite [_ * (_)%:P]mulrC [((b - a)^-k)%:P * _]mulrA -polyCM. - by rewrite -invfM -exprD subnKC // !mulrA [_ %:P * _]mulrC. -have -> : (('X - a%:P) ^+ k * ((b - a) ^- k)%:P) = - (beta^+k)%:P * (('X - a%:P) ^+ k * ((m - a) ^- k)%:P). - rewrite /beta expr_div_n polyCM !mulrA -[_ * (_ ^+k)]mulrC !mulrA (mulrAC _ (((m - a) ^+ k)%:P)). - rewrite -!mulrA -polyCM mulfV ?polyC1 ?mulr1 ?expf_eq0 ?subr_eq0 //. - by move/negPf: dma => ->; rewrite andbF. -rewrite -(exprVn (b - a)) [(_ ^-1 ^+ _)%:P]polyC_exp. -rewrite -exprMn_comm; last by exact: mulrC. -have -> : (b%:P - 'X) * ((b - a)^-1)%:P = - ((m%:P - 'X) * (m - a)^-1%:P) + (alpha%:P * ('X - a%:P) * (m - a)^-1%:P). - (* a ring tactic would be nice here *) - rewrite [(m%:P - _) * _]mulrDl mulrDr [(alpha%:P * _ + _) * _]mulrDl. - rewrite (mulrC _ 'X) -(mulrA 'X) [_ + (- 'X * _)]addrC mulNr -mulrN. - rewrite addrAC addrA -mulrDr -mulN1r -mulrDl. - rewrite -(polyCN 1) -polyCD /alpha. - have -> : -1 = (a-b)/(b-a). - by rewrite -opprB mulNr mulfV // subr_eq0 eq_sym. - rewrite -mulrDl addrA addrNK -(opprB m a). - rewrite -polyCM !mulNr mulrAC mulfV ?mul1r; last by rewrite subr_eq0. - rewrite polyCN -addrA -mulrDl [_ * - a%:P]mulrC -[-a%:P]polyCN. - rewrite -polyCM -polyCD !mulrA. - have {2}-> : m = m * (b - a) / (b - a) by rewrite mulfK // subr_eq0 eq_sym. - rewrite -[_ + _ /(b-a)]mulrDl !mulrDr addrA addrAC [-a * -m]mulrN. - rewrite [-a * m]mulrC addrNK [_ + m * b]addrC -mulrDl -polyCM. - rewrite [_ * b]mulrC mulrAC mulfK; last by rewrite subr_eq0. - by rewrite mulrN -mulNr polyCM -mulrDl addrC. -rewrite [_^+ (p - k)]exprDn /= subSn //. -rewrite -(big_mkord (fun _ => true) (fun i => ((m%:P - 'X) * ((m - a)^-1)%:P) ^+ (p - k - i) * - (alpha%:P * ('X - a%:P) * ((m - a)^-1)%:P) ^+ i *+ 'C( - p - k, i))). -rewrite big_distrr /= (big_morph _ (mulrnDl ('C(p, k))) (mul0rn _ _)). -apply: congr_big_nat=> // i /= hi. -rewrite /dicho' [(i + k)%nat]addnC dc_delta_tail /bernp. -rewrite !mulrnAr polyCMn mulrnAl -!mulrnA; congr (_ *+ _); last first. - rewrite addnC -util_C ?leq_addr //. - by rewrite mulnC; congr (_ * _)%N; rewrite addnC addnK. - by move:hi; rewrite ltnS -(leq_add2l k) subnKC. -set Xa := ('X - a%:P); set Xb := (_ - 'X). -rewrite [alpha^+_ * _]mulrC [(beta^+_ * _)%:P]polyCM -!mulrA; congr (_ * _). -rewrite [(alpha%:P * _)]mulrC. -rewrite [(_ * alpha%:P)^+i]exprMn_comm; last by exact: mulrC. -set lhs := (alpha ^+ i)%:P * _; rewrite !mulrA. -rewrite [_ * alpha%:P ^+ i]mulrC /lhs polyC_exp; congr (_ * _)=> {lhs alpha}. -set lhs := _ * (_ * Xb ^+ (p - _)). -rewrite !exprMn_comm; try exact: mulrC. -rewrite [Xa^+i * _]mulrC !mulrA [_ * Xa^+ _]mulrC !mulrA. -rewrite -exprD /lhs [_ * (Xa^+ _ * _)]mulrA [_ * Xa^+ _]mulrC -!mulrA. -rewrite addnC; congr (_ * _)=> {lhs}. -rewrite !mulrA [_ * Xb^+ (p - k - i)]mulrC -!mulrA [Xb^+ _ * _]mulrC. -rewrite subnDA; congr (_ * _); rewrite -!polyC_exp -!polyCM; congr (_ %:P). -rewrite -!exprVn -!exprD; congr ((m -a)^-1 ^+ _). -rewrite subnK; last by []. -by rewrite addnC subnK; last by []. -Qed. - -Lemma dicho'_correct : forall (a b m : R)(alpha := (b - m) * (b - a)^-1) - (beta := ((m - a) * (b - a)^-1))(p : nat)(q : {poly R})(c : nat -> R), - a != b -> - m != a -> - q = \sum_(i < p.+1) c i *: bernp a b p i -> - q = \sum_(j < p.+1) dicho' alpha beta c j *: bernp a m p j. -Proof. -move=> a b m alpha beta p q c neqab neqma qdef. -have {neqma qdef} -> : q = - \sum_(j < p.+1) \sum_(i < p.+1) - (c i)%:P * (dicho' alpha beta (delta R i) j)%:P * bernp a m p j. - rewrite exchange_big /= qdef; apply: congr_big; [by [] | by [] |]. - case=> k hk _ /=. - have hk': (k <= p)%N by exact: hk. - rewrite (dicho'_delta_bern neqab neqma hk'). - rewrite -mul_polyC big_distrr /=; apply: congr_big; [by [] | by [] |]. - by case=> i hi _; rewrite !mulrA. -apply: congr_big; [by [] | by [] |]. -case=> i hi _ /=; rewrite -big_distrl /= -mul_polyC; congr (_ * _). -have -> : dicho' alpha beta c i = - dicho' alpha beta (fun k => \sum_(j < p.+1)(c j) * (delta R j k)) i. - apply: ext_dc=> k _; rewrite add0n => h. - have pk : (k < p.+1)%N by apply: leq_ltn_trans hi. - rewrite (bigD1 (Ordinal pk)) //= /delta eqxx mulr1 big1 ?addr0 //. - case=> j hj /=; move/negPf; case e : (j == k); last by rewrite mulr0. - suff : Ordinal hj = Ordinal pk by move/eqP->. - by apply: val_inj=> /=; apply/eqP. -elim: p i {hi} c alpha beta=> [| p ihp] i c alpha beta /=; set f := dicho' alpha beta. - rewrite big_ord_recl /= big_ord0 /dicho' /= addr0. - rewrite /f /dicho'. - have : forall k, - (0 <= k)%N -> (k <= 0 + i)%N -> - \sum_(j < 1) c j * delta R j k = (c 0%N) * (delta R 0) k. - by move=> k _ _; rewrite big_ord_recl /= big_ord0 addr0. - by move/ext_dc->; rewrite scal_dc polyCM. - rewrite (_ : f _ _ = - f - (fun k : nat => - (\sum_(j < p.+1) c j * delta R j k) + (c p.+1 * delta R p.+1 k)) i); - last first. - by apply: ext_dc=> k _; rewrite add0n=> hki; rewrite big_ord_recr. -rewrite /f /dicho' add_dc polyCD -ihp // big_ord_recr /=; congr (_ + _). -by rewrite scal_dc polyCM. -Qed. - -Lemma bern_swap p i (l r : R) : (i <= p)%N -> bernp r l p i = bernp l r p (p - i). -Proof. -move=> lip; rewrite /bernp subKn // bin_sub //; congr (_ *+ _). -rewrite -[l - r]opprB -[l%:P - 'X]opprB -['X - r%:P]opprB. -rewrite -mulN1r -[-(r%:P - 'X)]mulN1r -[- ('X - l%:P)]mulN1r. -rewrite !exprMn_comm; try exact: mulrC. -rewrite invfM polyCM [_ * ((r - l)^-p)%:P]mulrC. -rewrite -!mulrA; congr (_ * _). -rewrite -exprVn polyC_exp [(- 1)^-1]invrN invr1 polyCN. -rewrite [(r%:P - 'X)^+i * _]mulrC !mulrA polyC1 -!exprD. -by rewrite -addnA subnKC // -signr_odd oddD addbb /= expr0 mul1r. -Qed. - -Lemma bern_rev_coef : forall (p : nat)(a b : R)(c : nat -> R), - \sum_(i < p.+1) c i *: (bernp a b p i) = - \sum_(i < p.+1) c (p - i)%N *: (bernp b a p i). -Proof. -move=> p a b c. -pose t := \sum_(i < p.+1) c (p - i)%N *: bernp a b p (p - i)%N. -transitivity t. - by rewrite (reindex_inj rev_ord_inj) /=; apply: eq_bigl. -apply:eq_bigr => [[i hi]] _ /=. -by rewrite bern_swap ?subKn // leq_subr. -Qed. - -Lemma dicho_correct : forall (a b m : R)(alpha := (b - m) * (b - a)^-1) - (beta := ((m - a) * (b - a)^-1))(p : nat)(q : {poly R})(c : nat -> R), - a != b -> - m != b -> - q = \sum_(i < p.+1) c i *: bernp a b p i -> - q = \sum_(j < p.+1) dicho alpha beta p c j *: bernp m b p j. -Proof. -move=> a b m alpha beta p q c neqab neqmb qdef. -rewrite bern_rev_coef in qdef. -have neqba : b != a by rewrite eq_sym. -rewrite (@dicho'_correct _ _ _ _ _ (fun i => c (p - i)%N) neqba neqmb qdef). -rewrite -(big_mkord -(fun _ => true) (fun j => dicho' ((a - m) / (a - b)) ((m - b) / (a - b)) - (fun i : nat => c (p - i)%N) j *: bernp b m p j)). -rewrite big_nat_rev /= big_mkord; apply: congr_big; [by [] | by [] |]. -move=> [i hi] _ {qdef}; rewrite add0n subSS. -rewrite -bern_swap //; congr (_ *: _); rewrite /dicho' /dicho. -rewrite dc_reverse //= ?leq_subr // addn0 subKn //. -rewrite -opprB -[a - b]opprB -[a - m]opprB -mulN1r -[-(b - a)]mulN1r. -rewrite -[-(m - a)]mulN1r invfM [(- 1)^-1]invrN invr1 -mulrA. -rewrite [(b - m) * _]mulrC !mulrA mulNr mul1r opprK [-1 * _ ]mulrC 2!mulrN1. -by rewrite opprK -/beta mulrC mul1r. -Qed. - -End dicho_proofs. - -Section isolation_tree. - -Variable A : Type. - -Inductive root_info : Type := - | Exact (x : A) - | One_in (x y : A) - | Zero_in (x y : A) - | Unknown (x y : A). - -End isolation_tree. - -Section isolation_algorithm. - -Variable R0 : archiFieldType. - -Let R := {realclosure R0}. - -Definition head_root (f : R -> R) (l : seq (root_info R)) : Prop := - match l with - [::] => True - | Exact x::tl => True - | One_in x y::tl => f x != 0 - | Zero_in x y::tl => f x != 0 - | Unknown x y::tl => f x != 0 - end. - -Definition unique_root_for (f : R -> R) (x y : R) : Prop := - exists z, [/\ x < z < y, f z = 0 & forall u, x < u < y -> f u = 0 -> u = z ]. - -Definition no_root_for (f : R -> R) (x y : R) : Prop := - forall z, x < z < y -> f z != 0. - -Fixpoint read (f : R -> R) (l : seq (root_info R)) : Prop := - match l with - [::] => True - | Exact x::tl => f x = 0 /\ read f tl - | One_in x y::tl => unique_root_for f x y /\ head_root f tl /\ read f tl - | Zero_in x y::tl => no_root_for f x y /\ head_root f tl /\ read f tl - | Unknown x y::tl => read f tl - end. - -Fixpoint isol_rec n d a b (l : seq R) acc : seq (root_info R) := - match n with - O => Unknown a b::acc - | S p => - match changes (seqn0 l) with - | 0%nat => Zero_in a b::acc - | 1%nat => One_in a b::acc - | _ => - let c := (a + b)/2%:R in - let l2 := mkseq (dicho (2%:R^-1) (2%:R^-1) d (fun i => l`_i)) d.+1 in - isol_rec p d a c (mkseq (dicho' (2%:R^-1) (2%:R^-1) (fun i => l`_i)) d.+1) - (if l2`_0 == 0 then - Exact c::isol_rec p d c b l2 acc - else isol_rec p d c b l2 acc) - end - end. - -Lemma cons_polyK : forall p : {poly R}, - cons_poly p.[0] (\poly_(i < (size p).-1) p`_i.+1) = p. -move=> p; rewrite cons_poly_def addrC -[X in _ = X]coefK. -case sz : (size p) => [ | s]. - move/eqP: sz; rewrite size_poly_eq0 => /eqP => sz. - by rewrite sz horner0 polyC0 add0r /= polyseq0 !polyd0 mul0r. -rewrite [s.+1.-1]/= !poly_def big_ord_recl; congr (_ + _). - by rewrite expr0 alg_polyC horner_coef0. -rewrite big_distrl; apply: eq_bigr; move=> [i ci] _ /=. -by rewrite -scalerAl /bump leq0n add1n exprS mulrC. -Qed. - -Lemma poly_border (p : {poly R}) a b: - a < b -> (forall x, a < x < b -> 0 < p.[x]) -> 0 <= p.[a]. -Proof. -move=> ab cp; case p0: (p.[a] < 0); last by rewrite leNgt p0. -have := (cons_polyK (p \Po ('X + a%:P))); rewrite cons_poly_def. -have -> : (p \Po ('X + a%:P)).[0] = p.[a]. - by rewrite horner_comp hornerD hornerC hornerX add0r. -move=> qdec. -have : p = p \Po ('X + a%:P) \Po ('X - a%:P) by rewrite comp_polyXaddC_K. -rewrite -qdec comp_polyD comp_polyC comp_polyM comp_polyX. -set q := \poly_(_ < _) _; move=> pq. -have [ub pu] := (poly_itv_bound (q \Po ('X - a%:P)) a b). -have ub0 : 0 <= ub by rewrite (le_trans _ (pu a _)) // lexx andTb ltW. -set ub' := ub + 1. -have ub'0 : 0 < ub' by rewrite ltr_wpDl. -have ublt : ub < ub' by rewrite ltr_pwDr // ltr01. -pose x := minr (a - p.[a]/ub') (half (a + b)). -have xitv2 : a < x < b. - by case/andP: (mid_between ab)=> A B; rewrite lt_min ltr_pwDr ?A //= - ?gt_min ?B ?orbT // -mulNr mulr_gt0 // ?invr_gt0 // oppr_gt0. -have xitv : a <= x <= b by case/andP: xitv2 => *; rewrite !ltW //. -have := cp _ xitv2. -rewrite [X in X.[x]]pq hornerD hornerC hornerM hornerXsubC. -rewrite -[X in 0 < _ + X]opprK subr_gt0 => abs. -have : x - a <= -p.[a] / ub' by rewrite lerBlDl ge_min mulNr lexx. -rewrite -(ler_pM2r ub'0) mulfVK; last first. - by move:ub'0; rewrite lt0r=>/andP=>[[]]. -have xma :0 < x - a by rewrite subr_gt0; case/andP: xitv2. -move: (pu _ xitv); rewrite lter_norml; case/andP => _ {pu}. -rewrite -[_ <= ub](ler_pM2r xma) => pu2. -rewrite mulrC; have := (lt_le_trans abs pu2) => {pu2} {}abs ab'. -have := (le_lt_trans ab' abs); rewrite ltr_pM2r // ltNge;case/negP. -by rewrite ltW. -Qed. - -Lemma one_root1_unique : - forall q a b, one_root1 q a b -> unique_root_for (horner q) a b. -Proof. -move=> q a b [c [d [k [itv]]]]. -rewrite /pos_in_interval /neg_in_interval1 /slope_bounded2. -move=> itv1 itv2 sl. -case/andP: itv=> ac; case/andP=> cd; case/andP=> db k0. -have qd0 : q.[d] <= 0. - have : (0 <= (-q).[d]). - by apply: (poly_border db) => x xitv; rewrite hornerN lterNE itv2. - by rewrite hornerN lterNE. -have qc0 : 0 <= q.[c] by apply/ltW/itv1; rewrite ac lexx. -have qcd0 : (-q).[c] <= 0 <= (-q).[d] by rewrite !hornerN !lterNE qd0 qc0. -have [x xin] := (poly_ivt (ltW cd) qcd0). -rewrite /root hornerN oppr_eq0 =>/eqP => xr. -exists x; split. -- by case/andP: xin=> cx xd; rewrite (lt_le_trans ac cx) (le_lt_trans xd db). -- by []. -- move=> u; case/andP=> au ub qu0. - case cu : (u <= c). - have : a < u <= c by rewrite cu au. - by move/itv1; rewrite qu0 ltxx. - case ud : (d < u). - have : d < u < b by rewrite ud ub. - by move/itv2; rewrite qu0 ltxx. - have cu' : c <= u. - by apply: ltW; rewrite ltNge cu. - have ud' : u <= d. - by rewrite leNgt ud. - case/andP: xin=> cx xd. - case ux : (u <= x). - have := (sl _ _ cu' ux xd). - rewrite qu0 xr subrr -(mulr0 k) ler_pM2l // subr_le0 => xu. - by apply/eqP; rewrite eq_le ux. - have xu : x <= u. - by apply: ltW; rewrite ltNge ux. - have := (sl _ _ cx xu ud'). - rewrite qu0 xr subrr -(mulr0 k) ler_pM2l // subr_le0 => ux'. - by apply/eqP; rewrite eq_le ux'. -Qed. - -Lemma alternate_1_neq0 (p : {poly R}) : - alternate_1 p -> p != 0. -case/alternate_1P=> l1 [v [l2 [h1]]] _ _ _. -by rewrite -nil_poly h1 {h1}; case: l1 => //. -Qed. - -Lemma all_ge0_cat {R'' : realDomainType} : - {morph (@all_ge0 R'') : x y / x ++ y >-> x && y}. -Proof. by elim=> [ | a x IH y] //=; rewrite IH andbA. Qed. - -Lemma alternate_r d (p : {poly R}) a : - ( 0 < a) -> alternate p -> (size p <= d)%N -> alternate (p + a *: 'X ^+ d). -Proof. -move=> a0 /alternate_P [l1 [x [l2 [y [l3 [P1 P2 P3 P4]]]]]] ps. -apply/alternate_P; exists l1, x, l2, y. -exists (l3 ++ (mkseq (fun i => 0) (d - size p)) ++ [:: a]). -split => //; first last. - case: P4 => P4 P5 P6; split=> //. - rewrite !all_ge0_cat P6 andTb; apply/andP; split; last by rewrite /= ltW. - by apply/(all_nthP 0); move => i; rewrite size_mkseq => W; rewrite nth_mkseq. -(* With "apply/all_nthP" - The previous line introduces an existential that is uncaptured. *) -set m := mkseq _ _; set l := _ ++ _. -have reorg : l = p ++ m ++ [:: a] by rewrite P1 /m -!(catA, cat_cons). -have saxd : size (a *: 'X^d) = d.+1. - by rewrite -mul_polyC size_Cmul ?size_polyXn; last rewrite neq_lt a0 orbT. -have spax : size (p + a *: 'X^d) = d.+1. - by rewrite addrC size_addl // saxd ltnS. -have sreo : size (p ++ m) = d by rewrite size_cat /m size_mkseq addnC subnK. -apply: (@eq_from_nth _ 0). - by rewrite spax reorg catA size_cat sreo /= addn1. -move=> i; rewrite spax ltnS leq_eqVlt=> ib; rewrite coef_add_poly coefZ. -case/predU1P: ib => [->|iltd]. - rewrite [p`_d]nth_default // add0r coefXn eqxx mulr1 reorg catA. - by rewrite nth_cat sreo ltnn subnn. -move: (iltd); rewrite coefXn ltn_neqAle=> /andP [df _]; rewrite (negbTE df). -rewrite mulr0 addr0 reorg catA nth_cat sreo iltd nth_cat. -case tst: (i < size p)%N => //. -rewrite /m nth_mkseq. - by rewrite nth_default // leqNgt tst. -by rewrite ltn_subRL addnC subnK // leqNgt tst. -Qed. - -Lemma all_eq0_seqn0 (l : seq R) : (head 0 (seqn0 l) == 0) = (all_eq0 l). -Proof. -elim: l=> [ | a l IH]; first by rewrite eqxx. -by rewrite /=; case a0: (a == 0) => //=. -Qed. - -Lemma seqn0_last (l : seq R) : head 0 (seqn0 l) != 0 -> - exists l1 x l2, [&& l == l1 ++ x :: l2, x != 0 & all_eq0 l2]. -Proof. -elim: l => [ | a l IH] /=; first by rewrite eqxx. -case a0: (a == 0) => /=. - move/IH=> [l1 [x [l2 /andP [p1 p2]]]]; exists (a::l1), x, l2. - by rewrite (eqP p1) cat_cons eqxx p2. -move=> an0. -case h: (all_eq0 l). - by exists nil, a, l; rewrite /= an0 h eqxx. -move/negbT: h. -rewrite -all_eq0_seqn0; move/IH=>[l1 [x [l2 /andP [p1 p2]]]]. -by exists (a::l1), x, l2; rewrite (eqP p1) p2 cat_cons eqxx. -Qed. - -Lemma first_neg_no_change_all_le0 (l : seq R) : - head 0 (seqn0 l) < 0 -> changes (seqn0 l) = 0%N -> all_le0 l. -Proof. -elim: l=> [ | a l IH] //=; case a0: (a==0)=> /= hsn0. - by rewrite le_eqVlt a0 /=; apply: IH => //; apply/eqP. -case h0: (head 0 (seqn0 l) == 0); move: (h0). - rewrite all_eq0_seqn0 (ltW hsn0) /= => al0 _. - by move: al0; apply: sub_all => x x0; rewrite (eqP x0) lexx. -move=> _ /eqP; rewrite (ltW hsn0) addn_eq0 /= => /andP [p1]/eqP. -apply: IH. -rewrite lt_neqAle h0 /= -(ler_nM2l hsn0) mulr0. -by move: p1; rewrite eqb0 ltNge negbK. -Qed. - -Lemma first_pos_no_change_all_ge0 (l : seq R) : - 0 <= head 0 (seqn0 l) -> changes (seqn0 l) = 0%N -> all_ge0 l. -Proof. -elim: l=> [ | a l IH] //=; case a0: (a==0)=> /= hsn0. - by rewrite le_eqVlt eq_sym a0 /=; apply: IH => //; apply/eqP. -case h0: (head 0 (seqn0 l) == 0); move: (h0). - rewrite all_eq0_seqn0 hsn0 /= => al0 _. - by move: al0; apply: sub_all => x x0; rewrite (eqP x0) lexx. -move=> _ /eqP; rewrite hsn0 addn_eq0 /= => /andP [p1]/eqP. -apply: IH. -have hsn0' : 0 < a by rewrite lt_neqAle eq_sym a0. -rewrite -(ler_pM2l hsn0') mulr0. -by move: p1; rewrite eqb0 ltNge negbK. -Qed. - -Lemma changes1_alternate d (l : seq R) f : (size l <= d.+1)%N -> - (forall i, (i < d.+1)%N -> (0 < f i)) -> - changes (seqn0 l) = 1%N -> 0 <= (seqn0 l)`_0 = true -> - alternate (\sum_(i < d.+1) (l`_i * f i *: 'X^(d - i))). -Proof. -elim: d l f => [| d IH] /=. - case => /= [ | a [ | *]] // f cf _. - case: (a != 0) => //=; by rewrite mulr0 ltxx addn0. -case => [| a l] //= f; rewrite ltnS. -case h: (a!=0) => //=; last first. - rewrite -[X in 0 <= X]/((seqn0 l)`_0) => h1 h2 h3 h4. - rewrite big_ord_recl /=. - have := negbFE h => /eqP => ->; rewrite mul0r scale0r add0r. - have t : forall i : 'I_d.+1, true -> - l`_i * f (bump 0 i) *: 'X^(d.+1 - bump 0 i) = - l`_i * f (i.+1) *: 'X^(d - i). - by move=> i /=; rewrite /bump leq0n add1n subSS. - rewrite (eq_bigr _ t) {t}. - have h2' : forall i : nat, (i < d.+1)%N -> (0 < f i.+1). - by move=> i ci; apply: h2; rewrite ltnS. - by apply: IH h2' _ _. -case alt: (a * head 0 (seqn0 l) < 0)%R; last first. - rewrite add0n => h1 h2 h3 h4. - have h2' : forall i : nat, (i < d.+1)%N -> (0 < f i.+1). - by move=> i ci; apply: h2; rewrite ltnS. - have alt' : alternate (\sum_(i < d.+1) (l`_i * f i.+1) *: 'X^(d - i)). - apply: (IH l (fun i => f i.+1)) => //. - have agt0 : 0 < a by rewrite lt_neqAle eq_sym (negbTE h). - rewrite -(ler_pM2l agt0) mulr0 leNgt; apply: negbT; exact alt. - rewrite big_ord_recl subn0 nth0 /= addrC; apply: alternate_r => //. - rewrite pmulr_lgt0; first by rewrite lt_neqAle eq_sym h h4. - by apply: h2. - have asl : forall i : 'I_d.+1, - (size (('X^(d.+1 - bump 0 i):{poly R})) <= d.+1)%N. - by move=> i; rewrite /bump leq0n add1n subSS size_polyXn ltnS leq_subr. - apply: size_weighted_sum_leq=> i _; apply: asl. -rewrite add1n; move=> sl cf [c0] ap. -have negl : head 0 (seqn0 l) < 0. - have ap' : 0 < a by rewrite lt_neqAle eq_sym h ap. - by rewrite -(ltr_pM2l ap') mulr0 alt. -have int: head 0 (seqn0 l) != 0 by rewrite neq_lt negl. -move/seqn0_last: (int) => [l1 [x [l2 /andP [/eqP p1 /andP[p2 p3]]]]]. -apply/alternate_P; rewrite /= -/R. -have cfp : forall j, (j < d.+2)%N -> - (\sum_(i < d.+2) ((a :: l)`_i * f i) *: 'X^(d.+1 - i))`_j = - ((a :: l)`_(d.+1 - j) * f (d.+1 - j)%N). - move=> j cj. - have cut1 : (0 <= d.+1 - j)%N by rewrite leq0n. - have cut2 : (d.+1 - j <= d.+2)%N. - by rewrite (leq_trans _ (ltnW (ltnSn d.+1))) // leq_subr. - rewrite -(big_mkord (fun i => true) - (fun i => ((a :: l)`_i * f i) *: 'X^(d.+1 - i))). - rewrite (big_cat_nat _ xpredT _ cut1 cut2) /= coef_add_poly. - have cut3 : (d.+1 - j <= (d.+1 - j).+1)%N by rewrite leqnSn. - have cut4 : ((d.+1 - j) < d.+2)%N by rewrite ltnS leq_subr. - rewrite (big_cat_nat _ xpredT _ cut3 cut4) /= coef_add_poly. - rewrite big_nat1 coefZ subKn; last by rewrite -ltnS. - rewrite coefXn eqxx mulr1 [X in X + (_ + _)](_ : _ = 0). - rewrite add0r [X in _ + X](_ : _ = 0); first by rewrite addr0. - rewrite nth_default //. - apply: size_weighted_sum_leq=> i; rewrite mem_index_iota => /andP [ci c']. - rewrite size_polyXn. - move: ci; rewrite -(ltn_add2r j) subnK; last by rewrite -ltnS. - move=> ci; rewrite -(ltn_add2r i) subnK; first by rewrite addnC. - by rewrite -ltnS. - have t : forall i, (0 <= i < d.+1 - j)%N -> - ((a :: l)`_i * f i) *: 'X^(d.+1 - i) = - ((a :: l)`_i * f i) *: 'X^(d - j - i) * 'X^j.+1. - move=> i /andP [_ ci]; rewrite -scalerAl -exprD addnS subnAC subnK. - by rewrite subSn // -ltnS (leq_trans ci). - rewrite -(leq_add2r i) subnK; last first. - by rewrite -ltnS (leq_trans ci). - move: ci; rewrite -(ltn_add2r j) subnK. - by rewrite ltnS addnC. - by rewrite -ltnS. - by rewrite (@eq_big_nat _ _ _ _ _ _ _ t) -big_distrl coefMXn leqnn. -exists (mkseq (fun i => 0) (d.+1 - size l)++(rev l2)), (x * f (size l1).+1), - (mkseq (fun i => (rev l1)`_i * f ((size l1) - i)%N) (size l1)), - (a * f 0%N), [::]. -have am : all_eq0 (mkseq (fun _ => (0:R)) (d.+1 - size l)). - rewrite /all_eq0; apply/(all_nthP 0); rewrite size_mkseq=> i ci. - by rewrite nth_mkseq. -have apos : 0 < a * f 0%N. - by apply: mulr_gt0; first rewrite lt_neqAle ap eq_sym h //; apply: cf. -rewrite /all_eq0 /all_le0 all_cat -!all_rev -/(all_eq0 l2) p3 /=. -have al : all_le0 l by apply: first_neg_no_change_all_le0. -rewrite [all _ (mkseq _ _)]am apos /=. -have sl' : (size l1 + size l2 <= d)%N. - by move: sl; rewrite p1 size_cat /= addnS ltnS. -have sl1d : (size l1 <= d)%N. - by apply: leq_trans sl'; apply leq_addr. -have -> : x * f (size l1).+1 < 0. - rewrite pmulr_llt0; last by apply: cf; rewrite !ltnS. - rewrite lt_neqAle; rewrite p2 /=. - by move/allP: al=> al; apply al; rewrite p1 mem_cat in_cons eqxx orbT. -split => //; last split=>//. - have st : size (a * f 0%N *: 'X^d.+1) = d.+2. - rewrite -mul_polyC size_Cmul ?size_polyXn // mulf_neq0 //. - by rewrite neq_lt cf ?orbT. - set sg := \sum_(_ < _) _; have st' : size sg = d.+2. - rewrite /sg big_ord_recl /= subn0 size_addl; first by []. - rewrite st ltnS size_weighted_sum_leq ?st //. - by move=> [i C] _; rewrite /bump add1n subSS size_polyXn ltnS leq_subr. - apply: (@eq_from_nth _ 0). - move:sl; rewrite p1 !size_cat /= !size_cat /= !size_rev !addnS addn0=> T. - by rewrite !size_mkseq subSS -addnA [(size l2 + _)%N]addnC subnK. - move=> i; rewrite st' => ci; rewrite cfp // {st' sg st al apos am cfp}. - rewrite nth_cat size_cat size_mkseq size_rev. - case b1 : (i < d.+1 - size l + size l2)%N. - rewrite nth_cat size_mkseq. - case b2 : (i < d.+1 - size l)%N. - rewrite nth_mkseq // nth_default ?mul0r //=. - move: b2; rewrite -(ltn_add2r (size l)) subnK // => b2. - by rewrite -(ltn_add2r i) subnK // addnC. - have b2' : (d.+1 - size l <= i)%N by rewrite leqNgt b2. - rewrite nth_rev; last first. - by rewrite -(ltn_add2r (d.+1 - size l)) subnK // addnC. - case l2c : (l2) => [ | b l3] /=; first by move: b1; rewrite l2c addn0 b2. - move: p3 {b2}; rewrite /all_eq0=>/all_nthP=> l20. - rewrite -l2c (eqP (l20 0 _ _)); last first. - by rewrite subSS l2c /= ltnS leq_subr. - have b1' : (i < d - size l1)%N. - move: b1; rewrite p1 size_cat /= addnS subSS subnDA subnK //. - by rewrite -(leq_add2r (size l1)) subnK // addnC. - have di1 : (i <= d)%N by rewrite (leq_trans (ltnW b1')) // leq_subr. - rewrite subSn //= p1 nth_cat. - have dil1 : (d - i < size l1)%N = false. - apply: negbTE; rewrite -leqNgt -(leq_add2r i) subnK//. - move: b1; rewrite -(ltn_add2l (size l1)) => b1. - rewrite -ltnS (leq_trans b1) // p1 size_cat /= addnS subSS. - by rewrite !(addnC (size l1)) -addnA subnK // addnC. - rewrite dil1; move/negbT: dil1; rewrite -leqNgt=>dil1. - rewrite -subnDA addnC subnDA -subnSK //= (eqP (l20 _ _ _)) ?mul0r //. - rewrite -(ltn_add2r i.+1) subnK // addnS ltnS -leq_subLR. - by rewrite (leq_trans _ b2') // p1 size_cat /= addnS subSS subnDA. - move=>{p3 p2}. - move/negbT: b1; rewrite -leqNgt leq_eqVlt => /predU1P[b1 {ci}|b1]. - rewrite b1 subnn p1 /= -b1 p1 size_cat /= addnS subSS [(d - _)%N]subnDA. - rewrite subnK; last first. - by rewrite -(leq_add2r (size l1)) subnK // addnC. - by rewrite subSn ?leq_subr // subKn //= nth_cat ltnn subnn /=. - have sl2dml1: (size l2 <= d - size l1)%N. - by rewrite -(leq_add2r (size l1)) subnK // addnC. - have dml1i : (d - size l1 < i)%N. - by apply: leq_trans b1; rewrite p1 size_cat /= addnS subSS subnDA subnK. - rewrite -[(i - _)%N]subnSK //= nth_cat size_mkseq -subnDA. - rewrite subnSK //. - case b2 : (i - (d.+1 - size l + size l2) <= size l1)%N. - rewrite nth_mkseq; last by rewrite subnSK. - move: (b2); rewrite -(leq_add2r (d.+1 - size l + size l2)). - rewrite subnK; last by rewrite ltnW. - rewrite addnC p1 size_cat /= addnS subSS subnDA subnK // subnK // => b2'. - rewrite nth_rev; last first. - by rewrite -(ltn_add2r (d - size l1).+1) subnK // addnS addnC subnK. - rewrite subnSK // subSn //= subnBA; last by rewrite ltnW. - rewrite addnC subnK // subnBA // addnS addnC subnK // nth_cat. - have dmil1 : (d - i < size l1)%N. - rewrite -(ltn_add2r i) subnK //; move: dml1i. - by rewrite -(ltn_add2r (size l1)) subnK // addnC. - by rewrite dmil1 subSn. - move/negbT: b2; rewrite -ltnNge=> b2. - have difinal : i = d.+1. - apply: anti_leq; apply/andP; split; first by rewrite -ltnS. - move: b2; rewrite -(ltn_add2r (d.+1 - size l + size l2)). - rewrite subnK; last by rewrite ltnW. - by rewrite p1 size_cat /= addnS subSS subnDA subnK // addnC subnK. - rewrite difinal subnn addSn subSS p1 size_cat /= addnS subnDA subSS. - rewrite [(d - (size l1 + size l2))%N]subnDA subnK // subnBA //. - by rewrite addKn subnn. -apply/(all_nthP 0); rewrite size_mkseq => i C; rewrite nth_mkseq // pmulr_lle0. -move: al; rewrite /all_le0 p1 all_cat => /andP [al1 _]; rewrite nth_rev //. - by move/(all_nthP 0): al1 => -> //; rewrite subnSK // leq_subr. -apply: cf; rewrite ltnS (leq_trans _ (ltnW (ltnSn _))) ?(leq_trans _ sl1d) //. -by rewrite leq_subr. -Qed. - -Lemma seqn0_oppr (l : seq R) : - seqn0 (map (fun i => -i) l) = map (fun i => -i) (seqn0 l). -Proof. -elim: l => [// | a l IH] /=. -by rewrite oppr_eq0; case: (a != 0); rewrite /= IH //. -Qed. - -Lemma changes_oppr (l : seq R) : - changes [seq - x | x <- l] = changes l. -elim: l => [// | x [ | y l] IH] /=; first by rewrite !mulr0. -rewrite mulrNN; congr (_ + _)%N; exact: IH. -Qed. - -Lemma ch1_correct l d a b (q : {poly R}): - (size l <= d.+1)%N -> - a < b -> q = \sum_(i < d.+1) l`_i *: bernp a b d i -> - changes (seqn0 l) = 1%N -> unique_root_for (horner q) a b. -Proof. -wlog : l q / (0 <= (seqn0 l)`_0). - move=> main s ab qq c1. - case sg : (0 <= (seqn0 l)`_0). - apply: (main l q sg) => //. - have ur : unique_root_for (horner (-q)) a b. - apply: (main (map (fun x => -x) l) (-q)) => //. - rewrite seqn0_oppr (nth_map 0). - by rewrite lerNr oppr0 ltW // ltNge sg. - rewrite lt0n; apply/negP; move/eqP=>abs; move: sg. - by rewrite nth_default ?abs ?lexx. - by rewrite size_map. - rewrite -(mul1r q) -mulNr qq big_distrr; apply/eq_bigr. - move=> i _ /=; case ci : (i < size l)%N. - by rewrite (nth_map 0) // mulNr mul1r scaleNr. - move/negbT: ci; rewrite -leqNgt => ci. - rewrite !nth_default //; last by rewrite size_map. - by rewrite !scale0r mulr0. - by rewrite seqn0_oppr changes_oppr. - case: ur => [x [inx xr xu]]. - exists x; split; first by []. - by apply/eqP; rewrite -oppr_eq0 -hornerN; apply/eqP. - by move=> u inu /eqP; rewrite -oppr_eq0 -hornerN => /eqP; apply:xu. -move=> sg s ab qq c1. -suff : one_root1 q a b by apply: one_root1_unique. -apply: (@Bernstein_isolate _ d) => //. - rewrite lt0n size_poly_eq0; apply/negP => /eqP => abs. - move/eqP: qq; rewrite abs eq_sym=> /eqP. - move: (ab); rewrite lt_def eq_sym; case/andP => ab' _ sb. - have := bernp_free ab' sb => bf {ab' sb abs sg}. - have abs : (seqn0 l) = [::]. - move: l s bf {a b q ab c1}. - elim: d => [ | d IH]. - move=> [ | a l]; first by []. - case: l => /=; last by []. - by move=> _ l0; have := (l0 ord0) => /= => ->; rewrite eqxx /=. - move=> [ | a l] /=; first by []. - rewrite ltnS=> s l0; have := (l0 ord0) => /= => ->; rewrite eqxx /=. - apply: IH => //; move=> [i] /=; rewrite -ltnS => ci. - by have := (l0 (Ordinal ci)). - by move: c1; rewrite abs. - rewrite qq; apply: size_weighted_sum_leq. - move=> [i ci]; rewrite size_bernp ?leqnn //. - by move: ab; rewrite lt_def eq_sym; case/andP. -have anb : a != b. - by move: ab; rewrite lt_def eq_sym; case/andP. -rewrite qq Mobius_weighted_sum //; last by move=> [i ci]; rewrite size_bernp. -have t : forall i : 'I_d.+1, true -> l`_i *: Mobius d a b (bernp a b d i) = - (l`_i * ('C(d, i))%:R) *: 'X ^+ (d - i). - by move=> [i ci]; rewrite Mobius_bernp //= scalerA. -rewrite (eq_bigr _ t) {t}. -have binp : forall i, (i < d.+1)%N -> (0:R) < ('C(d, i))%:R. - by move => i ci; rewrite ltr0n bin_gt0 -ltnS. -apply: (changes1_alternate s binp) => //. -Qed. - -Lemma ch0_correct l d a b q : a < b -> q != 0 -> - q = \sum_(i < d.+1) l`_i *: bernp a b d i -> - changes (seqn0 l) = 0%N -> no_root_for (horner q) a b. -move=> ab. -wlog : l q / 0 <= head 0 (seqn0 l). -move=> wlh qn0 qq ch. - case pos : (0 <= head 0 (seqn0 l)); first by apply: (wlh l) => //. - have ssn0 : (0 < size (seqn0 l))%N. - rewrite lt0n; apply/negP=> s0. - case/negP: qn0; rewrite qq big1 //. - move=> i _; case sli: (size l <= i)%N. - by rewrite nth_default ?scale0r. - have : all_eq0 l by rewrite -all_eq0_seqn0 -nth0 nth_default // (eqP s0). - move/negbT: sli; rewrite -ltnNge=> sli /allP l0. - by have := mem_nth 0 sli => /l0/eqP=> li0; rewrite li0 scale0r. - move: ch; rewrite -changes_oppr -seqn0_oppr => ch. - move/negbT: pos; rewrite -ltNge -oppr_gt0 -nth0 -(nth_map 0 0) // nth0. - rewrite -seqn0_oppr=>pos. - have ssn0' : (0 < size (seqn0 [seq -x | x <- l]))%N. - by rewrite seqn0_oppr size_map. - move: qn0; rewrite -oppr_eq0 => qn0. - have := refl_equal (-q); rewrite [X in _ = - X]qq -[X in _ = -X]mul1r {qq}. - rewrite -mulNr big_distrr /=. - have t : forall i : 'I_d.+1, true -> - -1 * (l`_i *: bernp a b d i) = - [seq -x | x <- l]`_i *: bernp a b d i. - move=> i _; case ci : (i < size l)%N. - rewrite (nth_map 0) // -[-1]/(-(1%:P)) -polyCN mul_polyC scalerA. - by rewrite mulNr mul1r. - move/negbT: ci; rewrite -leqNgt=> ci. - rewrite !nth_default //; first by rewrite !scale0r mulr0. - by rewrite size_map. - rewrite (eq_bigr _ t) => qq {t ssn0}. - have {wlh qq ch qn0 pos ssn0'} := wlh _ _ (ltW pos) qn0 qq ch. - by move=> nx x inx; rewrite -[q.[x]]opprK -hornerN oppr_eq0 nx. -move=> h qn0 qq ch x inx; apply /negP; rewrite qq. -rewrite horner_sum psumr_eq0 /=. -move=> al0; case/negP: qn0; rewrite qq. - rewrite big1 //; move => i _; rewrite [l`_i](_ : _ = 0) ?scale0r //. - have : l`_i * (bernp a b d i).[x] == 0. - by have := (allP al0 i (mem_index_enum _)); rewrite hornerZ. - rewrite mulf_eq0. - case: i => i /=; rewrite ltnS => ci. - have := bernp_gt0 ci inx; set bf := (_.[_]) => b0. - have bn0 : (bf != 0) by rewrite neq_lt b0 orbT. - by rewrite (negbTE bn0) orbF => /eqP. -move=> i _; rewrite hornerZ. -apply: mulr_ge0; last first. - by apply/ltW/bernp_gt0=> //; case i. -case sli: (i < size l)%N; last first. - by move/negbT: sli; rewrite -leqNgt=> sli; rewrite nth_default //. -by move/allP: (first_pos_no_change_all_ge0 h ch)=> t; apply/t/mem_nth. -Qed. - -Lemma bern0_a : forall (a b : R) deg i, a != b -> (0 < deg)%N -> - (i <= deg)%N -> (bernp a b deg i).[a] == 0 = (i != 0)%N. -Proof. -move=> a b deg i anb dn0 id. -rewrite /bernp hornerMn !hornerE subrr. -rewrite mulrn_eq0 !mulf_eq0 !expf_eq0 eqxx andbT invr_eq0 expf_eq0 dn0 andTb. -rewrite subr_eq0 [b == a]eq_sym (negbTE anb) orFb lt0n andbF orbF. -by rewrite eqn0Ngt bin_gt0 id. -Qed. - -Lemma bernp_first_coeff0 l d (a b : R) q : - a != b -> (0 < d)%N -> - q = \sum_(i < d.+1) l`_i *: bernp a b d i -> - (l`_0 == 0) = (q.[a] == 0). -Proof. -move=> anb dn0 qq. -rewrite qq horner_sum big_ord_recl !hornerE. -rewrite (_ : \sum_(i < d) _ = 0). - by rewrite addr0 mulf_eq0 bern0_a // eqxx orbF. -apply: big1; move=> [i ci] _ /=; apply/eqP. -by rewrite hornerE mulf_eq0 bern0_a // [bump _ _ == _]eq_sym neq_bump orbT. -Qed. - -Lemma isol_rec_head_root : forall c l d a b q acc, - q.[a] != 0 -> head_root (horner q) (isol_rec c d a b l acc). -Proof. -elim=> [// | c IH l d a b q acc qa0 /=]. -by case tst : (changes (seqn0 l)) => [ | [ | cl]] //=; apply: IH. -Qed. - -Lemma isol_rec_correct : forall c l d a b q acc, - a < b -> (0 < d)%N -> q != 0 -> (size l <= d.+1)%N -> - q = \sum_(i < d.+1) l`_i *: bernp a b d i -> - read (horner q) acc -> head_root (horner q) acc -> - read (horner q) (isol_rec c d a b l acc). -Proof. -elim=> [// | c IH]. -move=> l d a b q acc altb dn0 qn0 sld qq ht hh /=. -have anb : a != b by rewrite neq_lt altb. -case tst : (changes (seqn0 l)) => [/= | [/= | nc]]. - by split=> //; apply (ch0_correct altb qn0 qq). - by split=> //; apply (ch1_correct sld altb qq). -have help : 2%:R^-1 = ((a + b) / 2%:R - a)/(b - a). - rewrite -[X in _ / _ - X]double_half -/(half (a + b)) half_lin half_lin1. - rewrite opprD addrCA !addrA addNr add0r /half mulrAC mulfV ?mul1r //. - by rewrite subr_eq0 eq_sym. -have help2 : 2%:R^-1 = (b - (a + b)/2%:R)/(b - a). - rewrite -[X in X - _ / _]double_half -/(half(a + b)) half_lin half_lin1. - rewrite opprD addrCA addrK [- _ + _]addrC /half mulrAC mulfV ?mul1r //. - by rewrite subr_eq0 eq_sym. -have qh' : - q = \sum_(i < d.+1) - (mkseq (dicho' 2%:R^-1 2%:R^-1 [eta nth 0 l]) d.+1)`_i *: - bernp a ((a + b) / 2%:R) d i. - have qt : forall i : 'I_d.+1, true -> - (mkseq (dicho' 2%:R^-1 2%:R^-1 [eta nth 0 l]) d.+1)`_i *: - bernp a ((a + b) / 2%:R) d i = - dicho' ((b - half (a + b))/(b - a)) - ((half (a + b) - a)/(b - a)) [eta nth 0 l] i *: - bernp a ((a + b) / 2%:R) d i. - by move => [i ci] _; rewrite -help -help2 /= nth_mkseq. - rewrite (eq_bigr _ qt); apply: dicho'_correct => //. - rewrite -[X in _ == X]double_half half_lin; apply/negP. - by move/eqP/half_inj/addrI/eqP; rewrite eq_sym; apply/negP. -have qh : - q = \sum_(i < d.+1) - (mkseq (dicho 2%:R^-1 2%:R^-1 d [eta nth 0 l]) d.+1)`_i *: - bernp ((a + b) / 2%:R) b d i. - have qt : forall i : 'I_d.+1, true -> - (mkseq (dicho 2%:R^-1 2%:R^-1 d [eta nth 0 l]) d.+1)`_i *: - bernp ((a + b) / 2%:R) b d i = - dicho ((b - half (a + b))/(b - a)) - ((half (a + b) - a)/(b - a)) d [eta nth 0 l] i *: - bernp ((a + b) / 2%:R) b d i. - by move => [i ci] _; rewrite -help -help2 /= nth_mkseq. - rewrite (eq_bigr _ qt); apply: dicho_correct; [exact: anb| |exact: qq]. - rewrite -[X in _ == X]double_half half_lin; apply/negP. - by move/eqP/half_inj/addIr/eqP; apply/negP. -apply: (IH); [|exact: dn0|exact: qn0| |exact: qh'| |]. - by case/andP : (mid_between altb) => it _; exact it. - by rewrite size_mkseq. - case ts0: (dicho 2%:R^-1 2%:R^-1 d [eta nth 0 l] 0 == 0). - rewrite /=; split. - apply/eqP; rewrite -(bernp_first_coeff0 _ dn0 qh). - by rewrite nth_mkseq. - rewrite -[X in _ == X]double_half half_lin; apply/negP. - by move/eqP/half_inj/addIr/eqP; apply/negP. - apply: IH => //. - by case/andP : (mid_between altb) => _ it; exact it. - by rewrite size_mkseq. - apply: IH => //. - by case/andP : (mid_between altb) => _ it; exact it. - by rewrite size_mkseq. -case ts0: (dicho 2%:R^-1 2%:R^-1 d [eta nth 0 l] 0 == 0); first by []. -apply: isol_rec_head_root. -rewrite -(bernp_first_coeff0 _ dn0 qh); last first. - rewrite -[X in _ == X]double_half half_lin; apply/negP. - by move/eqP/half_inj/addIr/eqP; apply/negP. -by rewrite nth_mkseq; move/negbT: ts0. -Qed. - -End isolation_algorithm. diff --git a/theories/civt.v b/theories/civt.v deleted file mode 100644 index 0cf0f63..0000000 --- a/theories/civt.v +++ /dev/null @@ -1,449 +0,0 @@ -Require Import (*QArith*) ZArith Zwf Lia. -From mathcomp Require Import ssreflect eqtype ssrbool ssrnat div fintype seq ssrfun order. -From mathcomp Require Import bigop fingroup choice ssralg ssrnum rat poly. -Require Export (*infra*) pol. - -Import GroupScope. -Import Order.Theory GRing.Theory Num.Theory. -Local Open Scope ring_scope. - -Set Printing Width 50. - -(******************************************************************************) -(* We want to prove a simple and contructive approximation of the - intermediate value theorem: if a polynomial is negative in a and positive in b, - and a < b, then for any positive epsilon, there exists c and d, so that - a <= c < d <= b, the polynomial is negative in c and positive and d, - and the variation between c and d is less than epsilon. To prove this, - we use a second polynomial, obtained by taking the the absolute value - of each coefficient. -*) -(******************************************************************************) - -Fixpoint abs_pol (l:list rat) :list rat := - match l with nil => nil | a::tl => `|a| :: abs_pol tl end. - -(* Theorem binding the slope between two points inside an interval. *) -(*Lemma cm2 (l : {poly rat}) b : - { c | forall x, 0 <= x -> x <= b -> `|l.[x] - l.[0]| <= c * x}. -Proof. -(*set al := \poly_(i < size l) `|l`_i|. -exists al.[b] => x x0 xb. -rewrite horner_poly horner_coef0 horner_coef. -have [/size0nil ->|] := eqVneq (size l) 0%N. - by rewrite !big_ord0/= normr0 mul0r. -rewrite -lt0n => l0. -rewrite -[in leLHS](prednK l0). -rewrite big_ord_recl/= expr0 mulr1 addrAC subrr add0r. -rewrite /bump. -under eq_bigr do rewrite leq0n/= add1n. -rewrite big_distrl/=. -rewrite (le_trans (ler_norm_sum _ _ _))//. -under eq_bigr do rewrite normrM. -rewrite -[in leRHS](prednK l0). -rewrite big_ord_recl/= expr0 /bump. -under [in leRHS]eq_bigr do rewrite leq0n/= add1n. -rewrite mulr1. -rewrite ler_paddl// ?mulr_ge0//. -apply: ler_sum => j _. -rewrite -mulrA. -rewrite ler_pmul//. -rewrite ger0_norm//; last first. - by rewrite exprn_ge0. -rewrite (@le_trans _ _ (b ^+ j.+1))//. -by rewrite ler_pexpn2r// nnegrE// (le_trans x0).*) -(*move=> l b; case: l =>[| a l]. -- by exists 0; move=> /= x; rewrite mul0r oppr0 addr0 normr0 lexx. -- exists (eval_pol (abs_pol l) b) => x px xb /=; rewrite mul0r addr0. - rewrite addrC addKr normrM ger0_norm // mulrC ler_wpM2r//. -(* NB(rei): ler_absr_eval_pol? *) -(* rewrite (le_trans (ler_absr_eval_pol _ _)) //. - by rewrite eval_pol_abs_pol_increase // ger0_abs. -Qed.*) (*TODO*)*) Admitted. *) - -(* Cannot be abstracted since not every ordered ring has a floor ring *) -(* -TODO? -Lemma QZ_bound : forall x:Q, (0 <= x)%Q -> {n : Z | x <= n#1}%Q. -intros [n d]; exists(Zdiv n (Zpos d)+1)%Z. -assert (dpos : (('d) > 0)%Z) by apply (refl_equal Gt). -unfold Qle; simpl; rewrite Zmult_1_r; rewrite Zmult_plus_distr_l. -rewrite Zmult_1_l {1}(Z_div_mod_eq n ('d)) //. -rewrite (Zmult_comm ('d)); apply Zplus_le_compat; auto with zarith. -destruct (Z_mod_lt n ('d)) as [_ H2]; auto. -by apply Zlt_le_weak. -Defined. -*) - -(* We will look at n points regularly placed between a and b, a satisfies - a property P and b does not, we want to find the first point among the - n points that satisfies P and has a neighbour that does not. *) -Definition find_pair : forall A:eqType, forall P:A->bool, forall Q:A->A->Prop, - forall l:seq A, forall a b:A, P a -> ~P b -> - (forall l1 l2 x y, a::l ++ b::nil= l1 ++ x :: y :: l2 -> Q x y) -> - {c :A & { d | Q c d /\ P c /\ ~P d}}. -Proof. -move => A P Q l; elim: l => [ | a l IHl] a' b' Pa Pb connect. - by exists a'; exists b'; split => //; apply: (connect [::] [::]). -case Pa1: (P a). - have tmp : - forall l1 l2 x y, a :: l ++ [:: b' ]= l1 ++ [::x, y & l2] -> Q x y. - by move => l1 l2 x y q; apply: (connect (a'::l1) l2); rewrite /= q. - by move: (IHl a b' Pa1 Pb tmp) => [c [d [cd Pc]]]; exists c; exists d. -exists a'; exists a; split; first by apply (connect nil (l++b'::nil)). -by rewrite Pa1. -Qed. - -Fixpoint nat_ns (p : Z)(n : nat) := - match n with - |0 => [:: p] - |m.+1 => (p - (Z_of_nat m.+1))%Z :: nat_ns p m - end. - -Definition ns p n := - match n with - |Zpos q => nat_ns p (nat_of_P q) - |_ => [:: p] - end. - -Lemma ltb_Zneg0 x : (Zneg x < 0)%Z. Proof. by []. Qed. - -Lemma leb_Zneg0N x : ~ (0 <= Zneg x)%Z. Proof. exact/Z.lt_nge/ltb_Zneg0. Qed. - -Lemma nat_ns_head : forall (p : Z) n, - exists l, nat_ns p n = (p - (Z_of_nat n))%Z :: l. -Proof. -move=> p; elim=>[|n [l Ih]] /=. - exists [::]. - by rewrite Z.sub_0_r. -by rewrite Ih; exists [:: (p - Z_of_nat n)%Z & l]. -Qed. - -Local Open Scope Z_scope. - -Lemma ns_head : forall p n :Z, (0 <= n) -> exists l, ns p n = (p - n) :: l. -Proof. -move=> p [|n|n] /=; last 1 first. -- by move/leb_Zneg0N. -- exists [::]. - by rewrite Z.sub_0_r. -- move=> _; set m := nat_of_P n; case: (nat_ns_head p m)=> l' ->; exists l'. - by rewrite /m Zpos_eq_Z_of_nat_o_nat_of_P. -Qed. - -Lemma nat_ns_step : forall p n, forall l1 l2 x y, - nat_ns p n = l1 ++ [:: x, y & l2] -> y = x + 1. -Proof. -move=> p; elim=> [|n Ihn] l1 l2 x y /=. - by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. -case: l1 => [|u l3] /=; last by case=> _; move/Ihn. -case=> <-; case: (nat_ns_head p n)=> [l' ->]; case=> <- _. -rewrite Zpos_P_of_succ_nat. -rewrite /Z.succ /=. -ring. -Qed. - -Lemma ns_step : forall p n, forall l1 l2 x y, 0 <= n -> - ns p n = l1 ++ [:: x, y & l2] -> y = x + 1. -Proof. -move=> p [|n|n] /=; last 1 first. -- by move=> ? ? ? ? /leb_Zneg0N. -- move=> ? ? ? ? ?. - by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. -- move=> l1 l2 x y _; exact: nat_ns_step. -Qed. - -Lemma nat_ns_tail : forall p n, exists l, nat_ns p n = l ++ [:: p]. -Proof. -move=> p; elim=> [|n [l' Ihn]] /=. -- by exists [::]; rewrite cat0s. -- rewrite Ihn. - eexists. - rewrite -cat_cons. - reflexivity. -Qed. - -Lemma ns_tail : forall p n, exists l, ns p n = l ++ p ::nil. -Proof. -move=> p [|n|n] /=. -- by exists [::]; rewrite cat0s. -- by case: (nat_ns_tail p (nat_of_P n))=> l' ->; exists l'. -- by exists [::]; rewrite cat0s. -Qed. - -Local Close Scope Z_scope. - -(* Lemmas about minus are missing in xssralg .. .*) -(* TODO - -Lemma nat_ns_bounds : forall p n x l1 l2, nat_ns p n = l1 ++ [:: x & l2] -> - (p - Z_of_nat n <= x)%Z && (x <= p). -Proof. -move=> p; elim=> [|n Ihn] x l1 l2 /= h. -- rewrite oppr0 addr0. - suff exp : p = x by rewrite exp lerr. - case: l1 h => /=; first by case. - move=> z s. - by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; - rewrite eqSS. -- case: l1 h => [| u l1] /=. - + by set sn := (' _)%Z; case=> h _; rewrite -h lerr lter_addlr /= oppr_lte0. - + case=> _; move/Ihn; case/andP=> h1 h2; rewrite h2 andbT; apply: ler_trans h1. - rewrite lter_add2r /= -lter_opp2 /= Zpos_P_of_succ_nat /Zsucc. - by rewrite -[Zplus _ _]/(Z_of_nat n + 1) lter_addrr /= ler01. -Qed. - -Lemma ns_bounds : forall p n x l1 l2, 0 <= n -> ns p n = l1 ++ x::l2 -> - (p - n <= x) && ( x <= p). -Proof. -move=> p [| n | n] x l1 l2 /=. -- move=> _ h; rewrite oppr0 addr0. - suff exp : p = x by rewrite exp lerr. - case: l1 h => /=; first by case. - move=> z s. - by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. -- by move=> _; move/nat_ns_bounds; rewrite Zpos_eq_Z_of_nat_o_nat_of_P. -- by rewrite leb_Zneg0N. -Qed. - -Lemma map_contiguous : -forall (A B : Type)(f : A -> B) l l1 l2 a b, - map f l = l1 ++ [:: a, b & l2] -> - {l'1 : seq A & - {l'2 : seq A & - {x : A & - {y : A | [/\ l1 = map f l'1, l2= map f l'2, a = f x, - b = f y & l = l'1 ++ [:: x, y & l'2]]}}}}. -Proof. -intros A B f; elim=> [|x l Ihl] /= l1 l2 a b h; first by case: l1 h. -case: l Ihl h => [|a' l'] /= h. -- by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. -- case: l1 h => [|a1 l1] /= h. - by case=> <- <- <-; exists [::]; exists l'; exists x; exists a' => /=. - case=> e1; move/h => [l1' [l2' [x' [y' [h1 h2 h3 h4 h5]]]]]. - exists [:: x & l1']; rewrite /= -h1 h2 e1; exists l2'; exists x'; exists y'. - by split=> //; rewrite h5. -Qed. - -(*This is map_cat. -Lemma map_app : - forall A B:Type, forall f : A -> B, forall l1 l2, map f (l1++l2) = map f l1 ++ map f l2. -intros A B f l1; induction l1; simpl; auto. -intros l2; rewrite IHl1; auto. -Qed. -*) - - -Lemma non_empty_tail : - forall (A : Type) (a : A) l, exists l', exists b, [:: a & l] = l' ++ [::b]. -Proof. -move=> A a l; elim: l a => [| x l Ihl] a. -- by exists [::]; exists a. -- case: (Ihl x)=> s [b Ihb]; rewrite Ihb; exists [:: a & s]; exists b. - by rewrite cat_cons. -Qed. - -(* wait and see ... -Lemma Qfrac_add_Z_l : forall a b c, - (a # 1) + (b # c)%Q = ( a * ' c + b # c)%Q :> Qcb. -intros;unfold Qeq; simpl; ring. -Qed. -*) - -Lemma leb_Z : forall x y:Z, x <= y -> Qcb_make x <= Qcb_make y. -Proof. -move => x y xy; apply/QcblebP; rewrite /qcb_val /Qcb_make /Qle /Qnum /Qden. -by rewrite 2!Zmult_1_r; apply/Zle_is_le_bool. -Qed. - -Lemma leb_0_Z : forall y, 0%Z <= y -> 0 <= Qcb_make y. -Proof. by move => y yp; apply: leb_Z. Qed. - -Lemma ltb_Z : forall x y:Z, x < y -> Qcb_make x < Qcb_make y. -Proof. - move => x y xy. apply/QcblebP; rewrite /qcb_val /Qcb_make /Qle /Qnum /Qden. -rewrite 2!Zmult_1_r; move/Zle_is_le_bool; rewrite -[Zle_bool y x]/(y <= x). -by rewrite ler_nlt xy. -Qed. - -Lemma ltb_0_Z : forall y, 0%Z < y -> 0 < Qcb_make y. -Proof. by move => y yp; apply: ltb_Z. Qed. - -Lemma Qcb_make_add : - forall x y, Qcb_make (x + y) == Qcb_make x + Qcb_make y. -move => x y; apply/Qcb_QeqP. -by rewrite -[(Qcb_make _ + _)%R]/(Q2Qcb(Qplus (qcb_val (Qcb_make x)) - (qcb_val (Qcb_make y)))) /Qcb_make - ?qcb_valE /Qplus /Qnum /Qden !Zmult_1_r Pmult_1_r /Q2Qcb ?qcb_valE - (eqP (Qcb_Z _)). -Qed. - -Lemma half_lt : forall a b :Qcb, 0 < a -> 0 < b -> - a / ((Qcb_make 2) * b) < a / b. -move => a b Ha Hb; rewrite ltef_mulpl // invr_mul //=; last first. - by rewrite unitfE eq_sym ltrWN. -by rewrite ltef_divp //= -{1}[_^-1]mulr1 ltef_mulp //= invf_cp0. -Qed. - -Lemma cut_epsilon : forall eps:Qcb, 0 < eps -> - exists eps1, exists eps2, 0 < eps1 /\ 0 < eps2 /\ eps1 + eps2 <= eps /\ - eps1 < eps /\ eps2 < eps. -move => eps p; exists (eps/Qcb_make 2); exists (eps/Qcb_make 2). -have p1 : 0 < eps/Qcb_make 2 by rewrite ltef_divp. -split; first done; split; first done; split. - rewrite -mulr_addr. - have q2 : (Qcb_make 2)^-1 + (Qcb_make 2)^-1 == 1 by []. - by rewrite (eqP q2) mulr1 lerr. -suff cmp : eps/Qcb_make 2 < eps by []. -by rewrite ltef_divp //= -{1}[eps]mulr1 ltef_mulp. -Qed. - - -Lemma constructive_ivt : - forall l x y, x < y -> eval_pol l x < 0%R -> 0%R <= eval_pol l y -> - forall epsilon, 0 < epsilon -> - exists x', exists y', - epsilon <= eval_pol l x' /\ - eval_pol l x' < 0 /\ 0 <= eval_pol l y' /\ - eval_pol l y' <= epsilon /\ x <= x' /\ x' < y' /\ y' <= y. -Proof. -move=> l a b ab nla plb. -have ba' : 0 < b - a by rewrite -(addrN a) lter_add2l. -(*have mpolapos : 0 < - eval_pol l a by rewrite gtr0_ltNr0 opprK.*) -have evalba : 0 < eval_pol l b - eval_pol l a. - rewrite -(lter_add2l (eval_pol l a)) add0r -addrA addNr addr0. - exact: lter_le_trans plb. -case: (translate_pol l a) => l' q. -case: (@cm3 (b - a) ba' l') => /= c pc. -have cpos : 0 < c. - rewrite -(ltef_mulp _ _ _ ba') /= mul0r -[b -a]addr0. - apply: lter_le_trans (pc 0 (b - a) _ _ _); rewrite ?lerr // ?(ltrW ba') //. - by rewrite -{2}(addrN a) -!q ger0_abs // ltrW. -move=> eps pe. -have pdiv : (0 < (b - a) * c / eps). - by rewrite ltef_divp // mul0r mulf_gte0 /= ba' cpos. -move: (pdiv); move/ltrW; move/QcblebP; case/QZ_bound => n qn. -(* assia : canonical structures are missing here for Z -> Qcb *) -have qn' : (((b - a) * c / eps) <= (Qcb_make n)). - by apply/QcblebP; rewrite /Qcb_make qcb_valE. -have fact1 : 0 < n. - have tmp : 0 < Qcb_make n. - by apply: lter_le_trans pdiv qn'. - move: tmp; move/QcblebP. rewrite /Qcb_make /=. - by move/Qle_bool_iff; rewrite /Qle_bool /= Zmult_1_r; move/negP. -have mkl: - exists l, forall l1 l2 x y, - [:: a & l] ++ [:: b] = l1 ++ [:: x, y & l2] -> - y - x = (b - a) / (Qcb_make n) /\ - exists k : Z, - x = a + (b - a)* (Qcb_make k)/ (Qcb_make n) /\ - (0<= k) /\ (k <= n - 1). - case en : (n == 1). - - rewrite (eqP en); exists [::] => l1 l2 x y /=; case: l1 => [| t1 ql1] /=. - case=> e1 e2 e3; rewrite e1 e2 Qcb_make1 invr1 mulr1; split=> //. - by exists 0; rewrite addrN lerr Qcb_make0 mulr0 mul0r addr0; split. - by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. -- exists (map (fun x => a + (b-a)*((Qcb_make x)/(Qcb_make n))) (ns (n-1) (n-2))). - have fact8 : 0 <= n - 2%Z. - move/eqP: en; move: fact1; rewrite -[1]/1%Z -[0]/0%Z. - clear. rewrite /is_true. rewrite -Zle_is_le_bool-[(n-2%Z)%R]/(n - 2)%Z. - rewrite -[0%Z < n]/(~~(Zle_bool n 0)); move/negP. - rewrite /is_true -Zle_is_le_bool; omega. - have fact2 : 0 <= n - 1. - by rewrite ler_eqVlt (ler_lte_trans fact8) ?orbT // lter_add2r. - move=> l1 l2 x y; case: l1 => [|t1 ql1] /=. - case: (ns_head (n - 1) (n - 2) fact8) => a1 qa1. - rewrite qa1 /= (_ : (n - 1) - (n - 2)%Z = 1) ?Qcb_make1; last first. - by rewrite addrAC [-(n - 2%Z)]oppr_add addrA opprK addrN add0r. - case => -> <- /=; split. - by rewrite addrAC addrN add0r mulrA mulr1. - exists 0; rewrite Qcb_make0 mulr0 mul0r addr0 lerr; split=> //; split=> //. - case=> ->; case: l2 => [|d l2] /=. - rewrite -[[:: x, y & [::]]]/([::x]++[:: y]) catA. - rewrite !cats1 -!rot1_cons; move/rot_inj; case=> <-. - case: (ns_tail (n - 1) (n - 2))=> l3 ->; rewrite map_cat /=. - rewrite cats1 -rot1_cons; move/rot_inj; case=> <- h2. - have fact3 : (Qcb_make (n - 1) / Qcb_make n) = 1 - (Qcb_make n)^-1. - have nn0 : ~~ (Qcb_make n == 0). - by apply/negP => nis0; move/Qcb_QeqP: nis0; - rewrite /Qeq /= Zmult_1_r => nis0; move: fact1; - rewrite nis0 ltrr. - by apply/eqP; rewrite /= (eqP (Qcb_make_add _ _)) mulr_addl mulrV /= //. - rewrite fact3 mulr_addr mulr1 oppr_add !addrA oppr_add addrA addrN add0r. - rewrite -mulrN opprK; split=> //. - exists (n - 1); split; last by rewrite lerr. - by rewrite -mulrA fact3 mulr_addr mulr1 !addrA. - case: (non_empty_tail _ d l2) => l3 [e qe]; rewrite qe. - rewrite -[ql1 ++ [:: x, y & l3 ++ [:: e]]]/(ql1 ++ [:: x, y & l3] ++ [:: e]). - rewrite [_ ++ _ ++ [:: e]]catA !cats1 -!rot1_cons; move/rot_inj; case=> -> q''. - case: (map_contiguous _ _ (fun x => t1+(e-t1)*((Qcb_make x)/(Qcb_make n))) - _ _ _ _ _ q'') => [l'1 [l'2 [n1 [n2 [_ [_ [qx [qy st]]]]]]]]. - rewrite qx qy. - have n21 : n2 = n1 + 1 by apply: ns_step st. - split. - rewrite n21 [t1 + _]addrC -addrA oppr_add [t1 + _]addrA addrN add0r -mulrN - -mulr_addr -mulNr -[_ * _^-1 + _]mulr_addl. - have fact5: Qcb_make (n1 + 1) - Qcb_make n1 = 1. - by rewrite -[_ - _]/(Q2Qcb (Qcb_make _ + Qcbopp(Qcb_make _))) - /Qcbopp /Qcb_make ?qcb_valE /Qopp /Qden /Qnum /Q2Qcb ?qcb_valE - (eqP (Qcb_Z _)) /Qplus /Qden /Qnum /Pmult 2!Zmult_1_r -Zplus_assoc - [Zplus _ (Zopp _)]Zplus_comm Zplus_assoc Zplus_opp_r Zplus_0_l. - by rewrite fact5 mul1r. - exists n1; split; first by rewrite mulrA. - have bds : (1 <= n1) && (n1 <= (n-1)). - have fact9 : (n - 1) - (n - 2%Z) = 1 - by rewrite oppr_add opprK addrA [ _ - n]addrC addKr. - by rewrite -{1}fact9; apply: ns_bounds _ _ _ _ _ fact8 st. - move/andP: bds => [bds1 bds2];split; last by []. - have fact6: 0 <= n1 by apply: ler_trans bds1; apply: ltrW; apply ltr01. - by []. -case: mkl => [sl qsl]. -have fact7 : ~ eval_pol l b < 0. - by apply/negP; rewrite ltrNge. -case: (find_pair _ (fun x => (eval_pol l x) < 0) - (fun x y => y - x = (b-a)/Qcb_make n /\ - (exists k, x = a + (b-a)*Qcb_make k / Qcb_make n /\ - 0 <= k /\ k <= (n-1))) sl a b nla fact7 qsl) => - [a' [b' [[A1 [k [A4 A5]]] [A2 A3]]]] {qsl sl}. -exists a'; exists b'. -have aa' : a <= a'. - rewrite -(addr0 a) A4; apply: lter_add=> /=; first by apply lerr. - rewrite mulr_ge0pp //; first apply: mulr_ge0pp; rewrite ?(ltrW ba') //. - by apply: leb_0_Z; case: A5. - by rewrite invf_gte0 /=; apply: leb_0_Z; apply: ltrW. -have bb' : b' <= b. - have bdec : b = a + (b - a) * (Qcb_make n) / (Qcb_make n). - have nn0 : Qcb_unit (Qcb_make n). - apply/negP => nq0; move/Qcb_QeqP: nq0. - rewrite /Qeq Zmult_1_r /Qcb_make qcb_valE /Qnum Zmult_0_l => nq0. - by move: fact1; rewrite nq0 ltrr. - by rewrite mulrK // addrA [a + _]addrC addrK. - have b'a: b' = a' + (b' - a') by rewrite addrA [ a' + _]addrC addrK /=. - rewrite b'a A1 A4 -addrA {3}bdec -mulr_addl; apply: lter_add; rewrite /= ?lerr //=. - rewrite lter_mulpr //=; first by rewrite invf_gte0; apply: leb_0_Z; apply: ltrW. - rewrite -{2}[b - a]mulr1 -mulr_addr lter_mulpl //= ?(ltrW ba') //. - rewrite -Qcb_make1 -(eqP (Qcb_make_add _ _)) /=; apply: leb_Z. - by case: A5=> _; rewrite -(lter_add2l 1) addrNK. -have ab' : a' < b'. - by rewrite -(lter_add2l (- a')) addrN A1 /= mulf_gte0 /= invf_cp0 /= ltb_0_Z // ba'. -have epsban: (b-a)*c/Qcb_make n <= eps. - by rewrite ltef_divpl ?ltb_0_Z // [eps * _]mulrC -ltef_divpl. -have main: eval_pol l b' - eval_pol l a' <= eps. - rewrite !q -(@ger0_abs _ (_ - _)). - have b'a': c * (b' - a') <= eps by rewrite A1 mulrA (mulrC c). - apply: ler_trans b'a'; rewrite -{2}(addr0 b') -(addNr a) addrA - -(addrA (b' - a)) -(opprK (a - a')) oppr_add opprK (addrC (-a)). - apply: pc. - - by rewrite subr_gte0. - - by rewrite lter_add2l /= ltrW. - - by rewrite lter_add2l. - rewrite -!q lter_addpl //=; first by rewrite oppr_gte0 /= ltrW. - by rewrite -ltrNge; apply/negP. -split; last (split; first exact A2). - rewrite lter_oppl /=; apply: ler_trans main. - by rewrite lter_addrl /= -ltrNge; apply/negP. -split; first by rewrite -ltrNge; move/negP: A3. -split; last by auto. -apply: ler_trans main; rewrite -{1}(addr0 (eval_pol l b')); apply: lter_add; rewrite /= ?lerr //. -by rewrite /= oppr_gte0 /= ltrW. -Qed. -*) diff --git a/theories/conv.v b/theories/conv.v deleted file mode 100644 index 46b2a86..0000000 --- a/theories/conv.v +++ /dev/null @@ -1,364 +0,0 @@ -From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals normedtype order boolp classical_sets. -Require Import counterclockwise. - -(******************************************************************************) -(* a <| t |> b := t *: a + (1 - t) *: b where a,b : lmodType R *) -(* for instance, a <| 0 |> b = b, etc. *) -(* between x y z := x \in [y,z] *) -(******************************************************************************) - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Import GRing Num.Theory Order.POrderTheory Order.TotalTheory. - -Local Open Scope order_scope. -Local Open Scope ring_scope. - -Section In01. -Variable R : realType. - -Definition in01 (t : R) := 0 <= t <= 1. - -Lemma in010 : in01 0. -Proof. by rewrite/in01 lexx ler01. Qed. - -Lemma in011 : in01 1. -Proof. by rewrite/in01 lexx ler01. Qed. - -Lemma in01_ge0 t : in01 t -> 0 <= t. -Proof. by move=>/andP[]. Qed. - -Lemma in01M_ge0 (t : R) : in01 t = (0 <= t * (1-t)). -Proof. -apply/idP/idP. - by move=>/andP[t0 t1]; apply mulr_ge0=>//; rewrite subr_ge0. -move=>ge0; apply/andP; split; rewrite leNgt; apply/negP=>ti; move:ge0. - by rewrite nmulr_rge0// subr_le0=>t1; move:(lt_trans ltr01 (le_lt_trans t1 ti)); rewrite ltxx. -by move:(ti); rewrite -subr_lt0=>t1'; rewrite nmulr_lge0// =>t0; move:(lt_trans (le_lt_trans t0 ltr01) ti); rewrite ltxx. -Qed. - -Lemma in01_onem t : in01 t = in01 (1 - t). -Proof. by rewrite 2!in01M_ge0 opprB addrCA subrr addr0 mulrC. Qed. - -Lemma in01M t u : in01 t -> in01 u -> in01 (t * u). -Proof. -move=>/andP[t0 t1]/andP[u0 u1]; apply/andP; split; first by apply mulr_ge0. -by apply mulr_ile1. -Qed. - -Lemma in01M1 t u : in01 t -> in01 u -> (t * u == 1) = (t == 1) && (u == 1). -Proof. -move=>/andP[t0 t1]/andP[u0 u1]. -apply/idP/idP; last by move=>/andP[/eqP-> /eqP->]; rewrite mulr1. -case tn1: (t == 1); first by move:tn1=>/eqP->; rewrite mul1r. -case un1: (u == 1); first by move:un1=>/eqP->; rewrite mulr1 tn1. -move=>/eqP tu1/=. -suff: t * u < 1 by rewrite tu1 ltxx. -by apply mulr_ilt1=>//; rewrite -subr_gt0 lt0r subr_eq0 subr_ge0 eq_sym ?t1 ?u1 ?tn1 ?un1. -Qed. - -Lemma in01_convA t u : in01 t -> in01 u -> in01 (t / (1-(1-t)*(1-u))). -Proof. -move=> t01 u01. -have c0 : 0 <= 1 - (1 - t) * (1 - u). - by move:t01 u01; rewrite in01_onem=>t01; rewrite in01_onem=>/(in01M t01); rewrite in01_onem=>/andP[]. -apply/andP; split. - by apply divr_ge0=>//; move:t01=>/andP[]. -have [->|e0] := eqVneq (1 - (1 - t) * (1 - u)) 0; first by rewrite invr0 mulr0; exact ler01. -rewrite -{4}(divff e0). -rewrite ler_wpM2r ?invr_ge0//. -rewrite mulrBr mulr1 mulrBl -addrA opprD addrA subrr add0r opprB opprK -mulrBl -subr_ge0 -addrA subrr addr0; apply mulr_ge0; last by move:u01=>/andP[]. -by move:t01; rewrite in01_onem=>/andP[]. -Qed. - -End In01. - -Section Conv. -Variable R : realType. -Variable E : lmodType R. - -Definition conv (t : R) (a b : E) := t *: a + (1 - t) *: b. - -End Conv. - -(* NB(rei): same notation as infotheo *) -Reserved Notation "x <| p |> y" (format "x <| p |> y", at level 49). -Notation "a <| p |> b" := (conv p a b). (* TODO(rei): needs scope *) - -Section Conv. -Variable R : realType. -Variable E : lmodType R. -Implicit Types (t u v : R) (a b c d : E). - -Lemma conv0 a b : a <| 0 |> b = b. -Proof. by rewrite/conv scale0r add0r subr0 scale1r. Qed. - -Lemma conv1 a b : a <| 1 |> b = a. -Proof. by rewrite/conv scale1r subrr scale0r addr0. Qed. - -Lemma convmm t a : a <| t |> a = a. -Proof. by rewrite/conv -scalerDl addrCA subrr addr0 scale1r. Qed. - -Lemma convC t a b : a <| t |> b = b <| 1 - t |> a. -Proof. by rewrite/conv opprB addrCA subrr addr0 addrC. Qed. - -Lemma convlr t a b : a <| t |> b = a + (1 - t) *: (b-a). -Proof. by rewrite scalerDr scalerN addrCA -{2}[a]scale1r -scalerBl opprB addrCA subrr addr0 addrC. Qed. - -Lemma convrl t a b : a <| t |> b = b + t *: (a - b). -Proof. by rewrite convC convlr opprB addrCA subrr addr0. Qed. - -End Conv. - -Section Conv. -Variable R : realType. -Variable E : lmodType R. -Implicit Types (t u v : R) (a b c d : E). - -Lemma convA t u a b c : in01 t -> in01 u -> - a <| t |> (b <| u |> c) = - (a <| t / ((1 : R^o) <| t |> u) |> b) <| (1 : R^o) <| t |> u |> c. -Proof. -move=> t01 u01. -have -> : (1 : R^o) <| t |> u = 1 - (1 - t) * (1 - u). - by rewrite (convlr _ (1 : R^o)) -[u-1]opprB scalerN. -rewrite/conv scalerDr addrA 2!scalerA opprB addrCA subrr addr0; congr add. -have [/eqP|tu1] := eqVneq (1 - (1 - t) * (1 - u)) 0. - rewrite {1}subr_eq0 eq_sym in01M1 -?in01_onem// -2![_-_ == 1]subr_eq0. - rewrite 2![1-_-1]addrAC subrr 2!add0r 2!oppr_eq0=>/andP[/eqP-> /eqP->]. - by rewrite mulr0 subr0 mulr1 subrr 3!scale0r addr0. -rewrite scalerDr 2!scalerA [(1-_*_)*(1-_)]mulrBr mulrCA divff// 2!mulr1 mulrBr. -by rewrite mulr1 addrAC opprB addrCA subrr addr0. -Qed. - -Lemma convA' t u a b c : in01 t -> in01 u -> - (a <| u |> b) <| t |> c = - a <| t * u |> (b <| t * (1 - u) / ((1 - u : R^o) <| t |> 1) |> c). -Proof. -move=>t01 u01. -rewrite convC (convC u) convA. - 2, 3: by rewrite -in01_onem. -rewrite -convC convC (convC _ c). -have -> : (1 - u : R^o) <| t |> 1 = 1 - t * u. - by rewrite (convrl _ _ 1) addrAC subrr add0r scalerN. -rewrite opprB addrCA subrr addr0. -have [/eqP|tu1] := eqVneq (1 - t * u) 0. - by rewrite subr_eq0 eq_sym in01M1// =>/andP[/eqP-> /eqP->]; rewrite 2!mul1r 2!conv1. -congr (_ <| _ |> (_ <| _ |> _)). -by apply (mulfI tu1); rewrite mulrBr mulr1 2![(1-t*u)*(_/_)]mulrCA divff// 2!mulr1 opprB addrCA addrAC subrr add0r mulrBr mulr1. -Qed. - -Lemma in01_conv (t u v : R) : in01 t -> in01 u -> in01 v -> - in01 ((u : R^o) <| t |> v). -Proof. -move=>/andP[t0 t1] /andP[u0 u1] /andP[v0 v1]; apply/andP; split. - apply addr_ge0; apply mulr_ge0=>//. - by rewrite subr_ge0. -have<-: t + (1-t) = 1 by rewrite addrCA subrr addr0. -apply: lerD; rewrite -subr_ge0. - rewrite -{1}[t]mulr1 -mulrBr; apply mulr_ge0=>//. - by rewrite subr_ge0. -by rewrite -{1}[1-t]mulr1 -mulrBr; apply mulr_ge0; rewrite subr_ge0. -Qed. - -Lemma in01_convl (t u : R) : 0 <= t*u -> in01 (t / (t+u)). -Proof. -have H: forall a b : R, 0 <= a*b -> 0 <= a/(a+b) by move=>a b ab0; rewrite -sgr_ge0 sgrM sgrV -sgrM sgr_ge0 mulrDr -expr2; apply addr_ge0=>//; apply sqr_ge0. -move=>tu0. -have [->|tun0] := eqVneq (t + u) 0. - by rewrite invr0 mulr0; apply in010. -apply/andP; split; first by apply H. -rewrite -{1}[t](addr0) -(subrr u) addrA mulrBl divff// -subr_ge0 opprB addrCA subrr addr0 addrC; apply H. -by rewrite mulrC. -Qed. - -Lemma conv_onem (t u v : R) : - (1-u : R^o) <| t |> (1-v) = - 1 - (u : R^o) <| t |> v. -Proof. -rewrite/conv 2!scalerBr addrACA opprD; congr add. -have sm: forall u, u *: (1 : R^o) = u*1 by []. -by rewrite 2!sm 2!mulr1 addrCA subrr addr0. -Qed. - -Lemma convACA (t u v : R) (a b c d : E) : in01 t -> in01 u -> in01 v -> - (a <| u |> b) <| t |> (c <| v |> d) = - (a <| t * u / ((u : R^o) <| t |> v) |> c) - <| (u : R^o) <| t |> v |> - (b <| t * (1 - u) / ((1 - u : R^o) <| t |> (1 - v)) |> d). -Proof. -move=>/andP[t0 t1]/andP[u0 u1]/andP[v0 v1]. -move:t0; rewrite le0r => /orP[|]. - by move=>/eqP->; rewrite !mul0r !conv0. -move=>t0; move:t1; rewrite -subr_ge0 le0r => /orP[|]. - rewrite subr_eq0=>/eqP<-; rewrite !mul1r !conv1. - move:u0; rewrite le0r => /orP[|]. - by move=>/eqP->; rewrite subr0 !conv0 divff ?oner_neq0// conv1. - rewrite lt0r=>/andP[u0 _]; rewrite divff// conv1. - move:u1; rewrite -subr_ge0 le0r => /orP[|]. - by rewrite subr_eq0=>/eqP<-; rewrite 2!conv1. - by rewrite lt0r=>/andP[t1 _]; rewrite divff// conv1. -move=>t1. -have c0: forall x y : R, 0 <= x -> 0 <= y -> (x : R^o) <| t |> y = 0 -> x = 0 /\ y = 0. - move=>x y; rewrite le0r => /orP[|]. - move=>/eqP-> _ /eqP. - rewrite/conv scaler0 add0r mulf_eq0 => /orP[|]. - by move=>t1'; move:t1; rewrite lt0r=>/andP[/negPf]; rewrite t1'. - by move=>/eqP->. - move=>x0 y0 c0. - suff: 0 < (x : R^o) <| t |> y by rewrite c0 ltxx. - rewrite /conv -(addr0 0) ; apply: ltr_leD. - by apply mulr_gt0. - by apply mulr_ge0=>//; apply ltW. -have [|uv0] := eqVneq ((u : R^o) <| t |> v) 0. - by move=>/(c0 _ _ u0 v0) [-> ->]; rewrite convmm !conv0 subr0 convmm -mulrA divff ?oner_neq0// mulr1. -move:u1 v1; rewrite -2![_ <= 1]subr_ge0=>u1 v1. -have [|uv0'] := eqVneq ((1 - u : R^o) <| t |> (1 -v)) 0. - by move=> /(c0 _ _ u1 v1)[/eqP]; rewrite subr_eq0=>/eqP<- /eqP; rewrite subr_eq0=>/eqP<-; rewrite convmm !conv1 -mulrA divff ?oner_neq0// mulr1. -rewrite{1 2 3 4 6 8}/conv 4!scalerDr 2!addrA !scalerA -conv_onem. -rewrite 2![((_ : R^o) <| _ |> _) * (1 - _)]mulrBr 2![_ * (_ * _ / _)]mulrC -!mulrA 2![_^-1 * _]mulrC divff// divff// !mulr1 /conv [t *: _ + _ + _]addrAC subrr add0r [t *: _ + _ + _]addrAC subrr add0r; congr add. -by rewrite -2!addrA; congr add; rewrite addrC. -Qed. -End Conv. - -Section between. -Variable R : realType. -Let Plane : vectType _ := (R^o * R^o)%type. - -Lemma det_conv (p p' q r : Plane) (t : R) : - det (p <| t |> p') q r = (det p q r : R^o) <| t |> det p' q r. -Proof. -have sm t' u : t' *: (u : R^o) = t' * u by []. -rewrite/conv !sm -det_cyclique -[det p q r]det_cyclique -[det p' q r]det_cyclique 3!det_scalar_productE -2!scalar_productZL -scalar_productDl; congr scalar_product. -rewrite 2!scalerBr -!addrA; congr GRing.add. -rewrite !addrA [-_ + _]addrC -addrA; congr GRing.add. -by rewrite -[-(t*:r)]scaleNr -scalerBl -opprB opprK -addrA [-t+t]addrC subrr addr0 scaleN1r. -Qed. - -Lemma det0_aligned (p q r: Plane) : det p q r = 0%R <-> - (p = q \/ exists t, p <| t |> q = r). -Proof. -rewrite det_scalar_productE. -symmetry; split. - case. - by move=>->; rewrite subrr -(scaler0 _ 0) scalar_productZL mul0r. - by move=> [t <-]; rewrite convlr addrAC subrr add0r rotateZ scalar_productZR scalar_product_rotatexx mulr0. -wlog: p q r / p == 0%R. - move=> h; rewrite -[q-p]subr0 -[r-p]subr0. - move=>/(h 0%R (q-p) (r-p) (eqxx 0%R)); case=>[ /eqP | [t] ]. - by rewrite eq_sym subr_eq0 eq_sym=>/eqP=>pq; left. - by rewrite{1}/conv scaler0 add0r=>/(f_equal (fun x=> p+x)); rewrite [r-p]addrC addrA subrr add0r=><-; right; exists t=>//; apply convlr. -move=>/eqP p0; subst p; rewrite !subr0/scalar_product/= mulrN=>/eqP; rewrite subr_eq0=>/eqP e. -have [q0|q0] := eqVneq q 0%R; first by left. -right. -move:q0; rewrite -pair_eqE /= negb_and => /orP[|] q0. - exists (1 - xcoord r / xcoord q)=>//. - rewrite -convC convrl add0r subr0; apply /eqP; rewrite -pair_eqE; apply /andP; split=>/=. - - apply/eqP. - transitivity ((xcoord r / xcoord q) * q.1) => //. - by rewrite -mulrA [_^-1*_]mulrC divff // mulr1. - - apply/eqP. - transitivity ((xcoord r / xcoord q) * q.2) => //. - by rewrite mulrC mulrA -e mulrC mulrA [_^-1*_]mulrC divff // mul1r. -exists (1 - ycoord r / ycoord q)=>//. - rewrite -convC convrl add0r subr0; apply /eqP; rewrite -pair_eqE; apply /andP; split=>/=. - - apply/eqP. - transitivity ((ycoord r / ycoord q) * q.1) => //. - by rewrite mulrC mulrA e mulrC mulrA [_^-1*_]mulrC divff // mul1r. - - apply/eqP. - transitivity ((ycoord r / ycoord q) * q.2) => //. - by rewrite -mulrA [_^-1*_]mulrC divff // mulr1. -Qed. - -Definition between (x y z : Plane) := [&& (det x y z == 0)%R, - (0%R <= scalar_product (x - y) (z - y)) , - (0%R <= scalar_product (x - z) (y - z)) & - ((y == z) ==> (x == z))]. - -Lemma between_conv x y z : between x y z <-> - exists t, in01 t && (x == y <| t |> z). -Proof. -case yz: (y == z). - rewrite/between yz; move:yz=>/eqP yz; rewrite yz subrr -(scale0r 0) scalar_productZR mul0r det_cyclique det_alternate eqxx lexx/=. - split; first by move=>/eqP->; exists 0; rewrite in010 convmm/=. - by move=>[t /andP[_]]; rewrite convmm. -rewrite /between yz/= andbT. -move:yz=>/negbT yz. -have zye: forall t (y z: Plane), t *: y + (1-t) *: z - y = (1-t) *: (z-y). - by move=>t y' z'; rewrite {1}[_*:_+_]addrC -addrA scalerBr; congr +%R; rewrite -scaleNr opprB scalerBl scale1r. -have yze: forall t (y z: Plane), t *: y + (1-t) *: z - z = t *: (y-z). - by move=>t y' z'; rewrite -addrA scalerBr; congr +%R; rewrite scalerBl scale1r [_-_*:_]addrC -addrA subrr addr0. -split. - rewrite det_cyclique =>/and3P[/eqP/det0_aligned]; case; first by move=> yz'; move:yz' yz=>->; rewrite eqxx. - move=>[t <-]. - rewrite yze zye 2!scalar_productZL=> yp zp; exists t; apply/andP; split=>//. - apply/andP; split. - by move:zp; rewrite pmulr_lge0//; apply scalar_productrr_gt0; rewrite subr_eq0. - by move:yp; rewrite pmulr_lge0 ?subr_ge0//; apply scalar_productrr_gt0; rewrite subr_eq0 eq_sym. -move=>[t] /andP [/andP [t0 t1]] /eqP->. -rewrite yze zye 2!scalar_productZL; apply/and3P; split. -- by rewrite det_cyclique; apply/eqP; apply det0_aligned; right; exists t. -- by rewrite mulr_ge0// ?subr_ge0// scalar_productrr_ge0. -- by rewrite mulr_ge0// scalar_productrr_ge0. -Qed. - -Lemma betweenC (a b c : Plane) : between a b c = between a c b. -Proof. -rewrite /between det_inverse -det_cyclique oppr_eq0; congr andb; rewrite !andbA; congr andb. - by apply andbC. -by rewrite eq_sym; apply implyb_id2l=>/eqP->. -Qed. - -Lemma betweenl (a b : Plane) : between a a b. -Proof. rewrite/between det_alternate eqxx/= subrr -(scale0r 0) scalar_productZL mul0r lexx/= Bool.implb_same andbT; apply scalar_productrr_ge0. Qed. - -Lemma betweenr (a b : Plane) : between a b a. -Proof. rewrite betweenC; apply betweenl. Qed. - -Lemma between_depl (a b c : Plane) : between a b c <-> - exists (d : Plane) (t u : R), - (t*u <= 0) && (b == a + t *: d) && (c == a + u *: d). -Proof. -split. - move=>/between_conv[t] /andP[t01]. - have aconv: a = t *: a + (1-t) *: a by rewrite -scalerDl addrCA subrr addr0 scale1r. - rewrite {1}aconv -subr_eq0 opprD addrACA -2!scalerBr. - case t1: (t == 1). - move:t1=>/eqP->; rewrite subrr scale1r scale0r addr0 subr_eq0=>/eqP->. - exists (c-b), 0, 1. - by rewrite mul0r lexx scale0r addr0 eqxx scale1r addrCA subrr addr0 eqxx. - rewrite addr_eq0 -scalerN opprB=>/eqP e. - exists (b-a), 1, (-t / (1-t)). - move:t1=>/negbT; rewrite eq_sym -subr_eq0=>tn1. - move:t01=>/andP[t0 t1]; rewrite mul1r mulNr oppr_le0 scale1r addrCA subrr addr0 eqxx mulrC scaleNr -scalerN opprB -scalerA e scalerA [_*(1-t)]mulrC divff// scale1r addrCA subrr addr0 eqxx 2!andbT; apply mulr_ge0=>//. - by rewrite invr_ge0 subr_ge0. -move=>[d][t][u]/andP[/andP[tu0]]. -wlog: d t u tu0 / 0 < t. - move=>h. - have [t0|t0] := ltP 0 t; first by apply h. - move:t0; rewrite le_eqVlt => /orP[|]. - by move=>/eqP->; rewrite scale0r addr0=>/eqP-> _; apply betweenl. - by rewrite -oppr_gt0 -(opprK d) 2![_ *: - - _]scalerN -2!scaleNr; apply h=>//; rewrite mulrN -mulNr opprK. -move=>t0 /eqP be /eqP ce. -move:tu0; rewrite pmulr_rle0// =>u0. -have tugt0: 0 < t-u by rewrite subr_gt0; exact (le_lt_trans u0 t0). -have tun0: t-u != 0 by apply/negP=>/eqP tu0; move:tugt0; rewrite tu0 ltxx. -apply/between_conv; exists (-u/(t-u)); apply/andP; split. - apply/andP; split. - by rewrite mulr_ge0 ?oppr_ge0// invr_ge0 ltW. - by rewrite -subr_ge0 -(pmulr_rge0 _ tugt0) mulrBr mulrCA divff// 2!mulr1 -addrA subrr addr0; apply ltW. -by rewrite/conv be ce 2!scalerDr addrACA -scalerDl [_ + (1-_)]addrCA subrr addr0 scale1r -subr_eq0 opprD addrA subrr add0r oppr_eq0 2!scalerA -scalerDl mulrBl mul1r addrCA -mulrBr mulrAC -mulrA divff// mulr1 subrr scale0r. -Qed. - -Lemma between_trans (a b c d e : Plane) : - between c a b -> between d a b -> between e c d -> between e a b. -Proof. -move=>/between_conv[t]/andP[t01 /eqP->] /between_conv[u]/andP[u01 /eqP->] /between_conv[v]/andP[v01 /eqP->]. -rewrite convACA// 2!convmm. -apply between_conv; exists ((t : R^o) <| v |> u); apply/andP; split=>//. -by apply in01_conv. -Qed. - -End between. diff --git a/theories/convex.v b/theories/convex.v deleted file mode 100644 index c4370a7..0000000 --- a/theories/convex.v +++ /dev/null @@ -1,545 +0,0 @@ -From HB Require Import structures. -From mathcomp Require Import all_ssreflect all_algebra lra. -From mathcomp Require Import mathcomp_extra boolp Rstruct classical_sets. -From mathcomp Require Import reals ereal interval_inference. -From infotheo Require Import realType_ext fdist convex. -Require Import preliminaries. - -Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory preliminaries. -Import fdist convex. -Local Open Scope ring_scope. - -Local Close Scope N_scope. -Delimit Scope nat_scope with N. -Delimit Scope int_scope with Z. -Delimit Scope ring_scope with R. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Local Definition R := Rdefinitions.R. - -Section convex. -Variable (E : convType R). - -Local Open Scope classical_set_scope. -Local Open Scope convex_scope. - -Definition convex_set_of (A : set E) : is_convex_set A -> {convex_set E}. -by move=> Aconv; exists A; constructor; constructor. -Defined. - -Lemma is_convex_setI (C D : {convex_set E}) : is_convex_set (C `&` D). -Proof. -apply/asboolP =>x y p [Cx Dx] [Cy Dy]; split. - by move/asboolP: (convex_setP C); apply. -by move/asboolP: (convex_setP D); apply. -Qed. - -Lemma hullX (F : @convType R) (C : set E) (D : set F) : - hull (C `*` D) = hull C `*` hull D. -Proof. -rewrite eqEsubset; split. - move=>+ [n][/=g][/=d][gCD]-> =>_. - rewrite Convn_pair; split=>/=; - exists n; [exists (Datatypes.fst \o g) | exists (Datatypes.snd \o g)]; exists d; split=> // + [i] _ <- =>_ /=; - (suff: ((C `*` D) (g i)) by move=>[]); - by apply gCD; exists i. -move=>[+ +][]/=[n][g][d][gC->][m][f][e] [fD->]=>_ _. -exists (n * m)%N, (fun i=> let (i, j) := split_prod i in (g i, f j)), (fdistmap (unsplit_prod (n:=m)) (d `x e)%fdist); split. - move=>+ [i] _ <- =>_. - by case: (split_prod i)=>a b; split; [apply gC | apply fD]. -rewrite Convn_pair/comp/=; congr pair; - apply: (S1_inj R); rewrite [LHS]S1_Convn [RHS]S1_Convn big_prod_ord/=. - apply eq_big => // i _. - rewrite -(scale1pt (scalept _ _)) scaleptA // -(FDist.f1 e). - rewrite mulr_suml. - pose h x := e x * d i. - have h0 x : 0 <= h x by rewrite /h mulr_ge0. - under eq_bigr => j _ do rewrite -[e j * d i]/(h j). - rewrite scalept_sum//; apply eq_big=>// j _. - rewrite /h /= fdistmapE. - have -> : (\sum_(a in {: 'I_n * 'I_m} | - a \in preim (@unsplit_prod _ m) (pred1 (Ordinal (unsplit_prodp i j)))) - (fdist_prod d (fun=> e)) a = - \sum_(a in {: 'I_n * 'I_m} | a \in pred1 (i, j)) - (fdist_prod d (fun=> e)) a)%R. - apply eq_big=>// k; congr andb; rewrite 3!inE. - by apply: (eqtype.inj_eq _ k (i, j)); exact: (can_inj (@unsplit_prodK _ _)). - rewrite (big_pred1 (i, j))// fdist_prodE/= mulrC; congr (scalept _ (S1 (g _))). - by move: (unsplit_prodK (i, j)) => /(congr1 Datatypes.fst)/esym. -rewrite (exchange_big_dep xpredT)//=; apply: eq_bigr => j _. -rewrite -(scale1pt (scalept _ _)) scaleptA// -(FDist.f1 d). -rewrite mulr_suml. -pose h x := d x * e j. -have h0 x : 0 <= h x by rewrite /h mulr_ge0. -under eq_bigr => i _ do rewrite -[d i * e j]/(h i). -rewrite scalept_sum//; apply: eq_big => // i _. -rewrite /h/= fdistmapE. -have -> : (\sum_(a in {: 'I_n * 'I_m} | - a \in preim (unsplit_prod (n:=m)) (pred1 (Ordinal (unsplit_prodp i j)))) - (fdist_prod d (fun=> e)) a = - \sum_(a in - {: 'I_n * 'I_m} | a \in pred1 (i, j)) - (FDist.f (fdist_prod d (fun=> e))) a)%R. - apply: eq_big=>// k; congr andb; rewrite 3!inE. - by apply: (eqtype.inj_eq _ k (i, j)); exact (can_inj (@unsplit_prodK _ _)). -rewrite (big_pred1 (i, j))// fdist_prodE/=; congr (scalept _ (S1 (f _))). -by move:(unsplit_prodK (i, j))=>/(congr1 Datatypes.snd)/esym. -Qed. - -End convex. -Import LmoduleConvex. -Lemma add_affine (E : lmodType R) : affine (fun p : E * E => p.1 + p.2). -Proof. -move=>p/= [x0 x1] [y0 y1]/=. -by rewrite/conv/= addrACA -2!scalerDr. -Qed. - -Lemma scale_affine (E : lmodType R) (t : R) : affine (fun x : E => t *: x). -Proof. -move=> p/= x y. -by rewrite/conv/= scalerDr; congr GRing.add; rewrite 2!scalerA mulrC. -Qed. - -Section C. -Variable E F: lmodType R. -Variable f : {linear E -> F}. - -Local Open Scope fun_scope. -Local Open Scope ring_scope. -Local Open Scope convex_scope. - -Lemma ker_convex: is_convex_set (preimage f [set 0]). -Proof. -apply/asboolP=>x y p /= fx0 fy0. -by rewrite linearD 2!linearZZ fx0 fy0 2!GRing.scaler0 addr0. -Qed. - -End C. - -Section face. -Variable E : convType R. - -Local Open Scope fun_scope. -Local Open Scope ring_scope. - -Definition ext (A : set E) := [set x | forall u v, u \in A -> v \in A -> - x \in segment u v -> x = u \/ x = v]%classic. - -Definition face (A F: set E) := [/\ (F `<=` A)%classic, is_convex_set F & - forall x u v, x \in F -> u \in A -> v \in A -> x \in segment u v -> - x != u -> x != v -> u \in F /\ v \in F]. - -Definition face' (A F: set E) := [/\ (F `<=` A)%classic, is_convex_set F & - forall x u v, x \in F -> u \in A -> v \in A -> x \in segment u v -> x != v -> u \in F]. - -Lemma face'P (A F: set E): face A F <-> face' A F. -Proof. -split => [[FA Fconv Fface]|[FA Fconv Fface]]. - split=> // x u v xF uA vA xuv xv; have [xu|xu] := eqVneq x u. - by rewrite xu in xF. - by move: (Fface x u v xF uA vA xuv xu xv) => []. -split => // x u v xF uA vA xuv xu xv; split; [ apply (Fface x u v) | apply (Fface x v u) ] =>//. -by rewrite segmentC. -Qed. - -End face. - -(* TODO: rm, will be fixed in infotheo 0.7.1 *) -Module LinearAffine. -Section linear_affine. -Open Scope ring_scope. -Variables (E F : lmodType R) (f : {linear E -> F}). -Import LmoduleConvex. -Let linear_is_affine: affine f. -Proof. by move=>p x y; rewrite linearD 2!linearZZ. Qed. - -#[export] HB.instance Definition _ := isAffine.Build _ _ _ _ linear_is_affine. - -End linear_affine. -End LinearAffine. -HB.export LinearAffine. - -Section face. - -Variable E: lmodType R. - -Local Open Scope fun_scope. -Local Open Scope ring_scope. -Local Open Scope convex_scope. - -Lemma probinvn1 : probinvn 1 = (1 / 2%R : R)%:pr. -Proof. -apply: val_inj => /=. -by rewrite div1r. -Qed. - -Lemma onem_half: onem 2^-1 = 2^-1 :> R. -Proof. -rewrite /onem. -rewrite [X in X - _ = _](splitr 1). -by rewrite div1r addrK. -Qed. - -Lemma ext_carac (A : {convex_set E}) (x: E): x \in A -> [<-> x \in ext A; - forall u v, u \in A -> v \in A -> x = u <| probinvn 1 |> v -> u = v; - is_convex_set (A `\ x)%classic; - face A [set x]]. -Proof. -move=>xA. -have ne20: (2 : R) != 0. - by rewrite pnatr_eq0. -have ge20: (0 : R) <= 2. - by rewrite ler0n. -split. - move=>xext u v uA vA xe. - move: xext=>/set_mem /(_ u v uA vA). - have xuv: x \in segment u v. - by apply mem_set; subst x; exists (probinvn 1). - move=>{uA} {vA} /(_ xuv) {xuv}. - wlog: u v xe / x = u. - move=> h; case=> xe'. - by apply h=>//; left. - apply /esym; apply h=>//; last by left. - rewrite xe convC; congr (v <| _ |> u). - apply val_inj=>/=. - set tmp : R := (1 + 1)%:R. - rewrite (_ : tmp = 2%R)//. - by rewrite onem_half. - move: xe=> -> + _. - move=> /(congr1 (fun x => 2 *: x)). - rewrite scalerDr probinvn1/=. - rewrite div1r. - rewrite onem_half 2!scalerA divff// 2!scale1r. - by rewrite scaler_nat mulr2n =>/addrI/esym. -split. - move=>xext. - apply/asboolP=>u v t [uA ux] [vA vx]. - split; first by move:(convex_setP A)=>/asboolP; apply. - wlog: u v t xext xA uA ux vA vx / Prob.p t <= 2^-1. - move=>h. - have [tle|tle] := leP (Prob.p t) (2^-1); first exact: (h u v t). - rewrite convC. - apply (h v u (onem t)%:pr)=>//. - rewrite -onem_half; apply: lerB=>//. - exact/ltW. - move=>tle. - have t01: ((Rdefinitions.IZR BinNums.Z0) <= 2%:R * (Prob.p t : R)) && - (2*(Prob.p t : R) <= Rdefinitions.IZR (BinNums.Zpos 1%AC)). - apply/andP; split. - by apply mulr_ge0=>//. - by move:tle=>/(ler_wpM2l ge20); rewrite divff. - move=>/esym xE. - move: xext=>/(_ (u <| Prob.mk t01 |> v) v). - rewrite -convA' convmm. - have ->: p_of_rs (Prob.mk t01) (probinvn 1) = t. - apply val_inj. - rewrite/= p_of_rsE/=. - have tE: (2*(Prob.p t : R))/2 = Prob.p t. - by rewrite mulrAC divff// mul1r. - by rewrite -{2}tE. - have wA: u <| Prob.mk t01 |> v \in A. - by apply mem_set; move:(convex_setP A)=>/asboolP; apply. - move: vA=>/mem_set vA /(_ wA vA xE) /(congr1 (fun x => x-v)). - rewrite subrr /conv/= -addrA -{2}(scale1r v) -scalerBl addrAC subrr add0r scaleNr -scalerBr. - apply /eqP; rewrite scaler_eq0; apply /negP=>/orP; case. - rewrite mulf_eq0 pnatr_eq0/= =>/eqP t0. - move:xE. - have ->: t = 0%:pr by apply val_inj. - by rewrite conv0=>/esym. - rewrite subr_eq0=>/eqP uv; subst v. - by move:xE; rewrite convmm=>/esym. -split. - move=>/asboolP Axconv. - split; [ by move=>u /= ->; apply set_mem | by apply is_convex_set1 | ]=> y u v /set_mem -> /set_mem uA /set_mem vA /set_mem [p _ xE] xu xv; exfalso. - have uAx: (A `\ x)%classic u by split=>//= ux; subst u; move: xu; rewrite eq_refl. - have vAx: (A `\ x)%classic v by split=>//= vx; subst v; move: xv; rewrite eq_refl. - have: (A `\ x)%classic x by rewrite -{2}xE; apply (Axconv _ _ _ uAx vAx). - by move=>[_ /= f]. -move=>xface; apply /mem_set=>u v uA vA xuv. -suff: (x == u) || (x == v) by move=>/orP; case=> /eqP ->; [ left | right ]. -apply /negP=>/negP; rewrite negb_or=>/andP [xu xv]. -move: xface=> [_ _ /(_ x u v)]. -have xx: x \in [set x]%classic by apply /mem_set. -move=>/(_ xx uA vA xuv xu xv) [/set_mem /= ux /set_mem /= vx]; subst u. -by move: xu; rewrite eq_refl. -Qed. - -Lemma face_trans (A : set E) (F : set E) (G : set E) : face A F -> face F G -> face A G. -Proof. -move=>[AF Fconv Fface] [FG Gconv Gface]. -split => //. -- by move=> x Gx; apply AF, FG. -- move=>// x u v xG uA vA xuv xu xv. - have [uF vF]: (u \in F /\ v \in F). - apply (Fface x)=>//. - by apply mem_set, FG, set_mem. - by apply (Gface x). -Qed. - -Definition supporting_hyperplane (A : set E) (f: {linear E -> R^o}) (a: R) := - (exists x, x \in A /\ f x = a) /\ - ((forall x, x \in A -> f x <= a) \/ (forall x, x \in A -> a <= f x)). - -Lemma is_convex_set_preimage [T U : convType R] (f : {affine T -> U}) (A : {convex_set U}) : - is_convex_set (f @^-1` A)%classic. -Proof. -apply/asboolP=>x y p/= Ax Ay. -by rewrite affine_conv -in_setE; apply/mem_convex_set; rewrite in_setE. -Qed. - -(* TOTHINK : lemmas prove is_convex_set but use {convex_set _}. *) -Lemma supporting_hyperplan_face (A : {convex_set E}) (f: {linear E -> R^o}) (a: R) : - supporting_hyperplane A f a <-> - (exists x, x \in A /\ f x = a) /\ face A (A `&` (f @^-1` [set a])). -Proof. -split; move=>[hex hface]; split=>//. - wlog: f a hex hface / (forall x : E, x \in A -> f x <= a). - move=>h; move: (hface); case=>hf. - by apply (h f a). - move: h=>/(_ (f \o (@GRing.opp E)) (- a)). - have hf' (x : E) : x \in A -> (f \o (@GRing.opp E)) x <= - a. - by move=> xA /=; rewrite -scaleN1r linearZZ scaleN1r lerNl opprK; apply hf. - have hex': exists x : E, x \in A /\ (f \o (@GRing.opp E)) x = - a. - by move: hex=>[x [xA fx]]; exists x; split=>//=; rewrite -fx -scaleN1r linearZZ scaleN1r. - move=>/(_ hex' (or_introl hf') hf'); congr (face A (A `&` _)). - by rewrite eqEsubset; split=>x /= /eqP; rewrite -scaleN1r linearZZ scaleN1r; [ rewrite eqr_opp | rewrite -eqr_opp ]=>/eqP. - move=> hf; apply face'P; split; [ by apply subIsetl | |]. - exact: (is_convex_setI _ (convex_set_of (is_convex_set_preimage f (set1 a)))). - move=> x u v /set_mem [xA xa] uA vA /set_mem [t _ tx] xv; apply mem_set; (split; [ by apply set_mem |]); apply /eqP; rewrite -lte_anti; apply /andP; (split; [ by apply hf |]). - have t0 : (Prob.p t : R) != 0. - by apply/eqP=>/val_inj t0; subst t; move: tx xv; rewrite conv0 => ->; rewrite eqxx. - have tgt : 0 < (Prob.p t : R) by rewrite lt0r t0=>/=. - move: tx=>/(f_equal (fun x=> (Prob.p t : R)^-1 *: (x - (onem t) *: v))). - rewrite -addrA subrr addr0 scalerA mulVf // scale1r=>->. - rewrite linearZZ linearD xa -scaleNr linearZZ ler_pdivlMl// addrC -subr_ge0 -addrA -mulNr -{1}[a]mul1r -mulrDl scaleNr -scalerN -mulrDr; apply mulr_ge0 => //. - by rewrite addrC Num.Internals.subr_ge0; apply hf. -have : forall x y, x \in A -> y \in A -> f x < a -> a < f y -> False. - move=> u v uA vA fua afv. - move: (Order.POrderTheory.lt_trans fua afv); rewrite -subr_gt0=>fufv. - have t01: (Rdefinitions.IZR BinNums.Z0 <= (f v - a) / (f v - f u))%R && - (((f v - a) / (f v - f u))%R <= Rdefinitions.IZR (BinNums.Zpos 1%AC)). - apply/andP; split. - by apply divr_ge0; apply ltW=>//; rewrite subr_gt0. - rewrite ler_pdivrMr// mul1r -subr_ge0 opprB addrAC addrCA subrr addr0 subr_ge0. - by apply ltW. - move: hface=>/face'P [_ _ /(_ (u <| Prob.mk t01 |> v) u v)]. - have inuv: u <| Prob.mk t01 |> v \in segment u v. - by apply mem_set; exists (Prob.mk t01). - have uva: f (u <| Prob.mk t01 |> v) = a. - rewrite/= affine_conv/=/conv/=. - move: fufv; rewrite lt0r=>/andP [fufv _]. - apply (mulfI fufv). - rewrite/GRing.scale/=. - rewrite mulrDr mulrAC mulrCA mulrAC divff// mulr1. - rewrite [onem _ * _]mulrBl mul1r mulrBr mulrAC mulrCA mulrAC divff// mulr1. - rewrite -mulrBl opprB addrAC addrCA subrr addr0. - rewrite 2!mulrBl mulrC addrAC addrCA subrr addr0. - by rewrite -mulrBr mulrC. - have Aa: u <| Prob.mk t01 |> v \in (A `&` f @^-1` [set a])%classic. - apply mem_set; split=>//. - by move:(convex_setP A)=>/asboolP; apply; rewrite -in_setE. - move=>/(_ Aa uA vA inuv). - have nev: u <|{| Prob.p := ((f v - a) / (f v - f u))%R; Prob.Op1 := t01 |}|> v != v. - rewrite -subr_eq0 -{4}(scale1r v) -addrA -scalerBl addrAC subrr add0r scaleNr -scalerBr scaler_eq0 subr_eq0. - apply/negP=>/orP; case=>/eqP. - move=>/= t0. - move:uva; rewrite/conv/= t0 scale0r add0r onem0 scale1r=>fva. - by move:afv; rewrite fva ltxx. - by move=>uv; move:fufv; rewrite uv subrr ltxx. - by move=>/(_ nev) /set_mem [_ /= fuae]; move: fua; rewrite fuae -subr_gt0 lt0r subrr eq_refl. -move=>h. -move: (boolp.EM (exists x: E, x \in A /\ f x < a)); case. - move: (boolp.EM (exists x: E, x \in A /\ a < f x)); case. - by move=>[y [yA afy]] [x [xA fxa]]; elim (h x y xA yA fxa afy). - by move=>allge _; left=> x xA; rewrite leNgt; apply /negP=>fxa; apply allge; exists x; split. -by move=>allge; right=> x xA; rewrite leNgt; apply /negP=>fxa; apply allge; exists x; split. -Qed. - -End face. -Section cone. - -Variable E: lmodType R. - -Local Open Scope fun_scope. -Local Open Scope ring_scope. -Local Open Scope convex_scope. - -Definition cone0 (A : set E) := - ([set t%:num *: a | t in (@setT {posnum R}) & a in A] `<=` A)%classic. - -Definition cone (x: E) (A: set E) := cone0 [set a - x | a in A]%classic. - -Lemma cone0_convex (A: set E): cone0 A -> - (is_convex_set A <-> ([set a+b | a in A & b in A] `<=` A)%classic). -Proof. -have ne20: (2 : R) != 0. - by rewrite pnatr_eq0. -have gt20 : ((0 : R) < 2)%R. - by rewrite ltr0n. -move=>Acone; split=>Aconv. - move=>x [u uA] [v vA] <-. - have uA2: A (2 *: u). - by apply: Acone => /=; exists 2%:pos => //; exists u. - have vA2: A (2 *: v) by apply Acone; exists 2%:pos =>//; exists v. - move:Aconv=>/asboolP/(_ _ _ (probinvn 1) uA2 vA2); congr A. - rewrite probinvn1/=. - rewrite /conv/=. - rewrite div1r. - by rewrite onem_half 2!scalerA mulVf// 2!scale1r. -apply/asboolP. -move=>x y t xA yA. -move:(prob_ge0 t); rewrite le0r=>/orP; case. - by rewrite/conv/= =>/eqP ->; rewrite scale0r add0r onem0 scale1r. -move=> t0; move: (prob_le1 t); rewrite -subr_ge0 le0r=>/orP; case. - by rewrite subr_eq0 /conv/= =>/eqP <-; rewrite onem1 scale0r addr0 scale1r. -move=> t1; apply Aconv; exists ((Prob.p t : R) *: x); - [| exists ((onem t) *: y) ]=>//; apply Acone. - by exists (PosNum t0) =>//; exists x. -by exists (PosNum t1)=>//; exists y. -Qed. - -(* Note: cone0_of A is NOT pointed due to lemma cone0_of_convE. *) -(* TODO: maybe change the 0 <= k i to 0 < k i in the definition of conv. *) - -Definition cone0_of (A: set E) : set E := - [set a | exists n (s : 'I_n.+1 -> E) (k: 'I_n.+1 -> {posnum R}), - \sum_i (k i)%:num *: (s i) = a /\ (range s `<=` A)%classic]. - -Lemma cone0_of_cone0 (A: set E): cone0 (cone0_of A). -Proof. -move=>x [t /= _] [a [n [s [k [<- sA]]]]] <-. -rewrite scaler_sumr; exists n, s, (fun i => (t%:num * (k i)%:num)%:pos); split => //. -by apply congr_big=>// i _; apply /esym; apply scalerA. -Qed. - -Lemma cone0_of_hullE (A : set E) : - cone0_of A = [set t%:num *: a | t in (@setT {posnum R}) & a in (hull A)]%classic. -Proof. -rewrite eqEsubset; split=>x. - move=>[n [s [k [<- kA]]]]; set t := \sum_i (k i)%:num. - have k0' (i : 'I_n.+1) : true -> 0 <= (k i)%:num by move=> _; apply/ltW. - have: 0 <= t by apply sumr_ge0. - rewrite le0r=>/orP; case. - move=>/eqP /psumr_eq0P; move=> /(_ k0') /(_ ord0 Logic.eq_refl) /eqP. - by rewrite gt_eqF. - move=>t0. - have tk0 i : (Rdefinitions.IZR BinNums.Z0 <= [ffun i => t^-1 * (k i)%:num] i). - by rewrite ffunE; apply/mulr_ge0; [ apply ltW; rewrite invr_gt0 | apply k0' ]. - have tk1 : \sum_(i < n.+1) [ffun i => t^-1 * (k i)%:num] i = 1. - transitivity (\sum_(i < n.+1) t^-1 * (k i)%:num). - by apply congr_big=>// i _; rewrite ffunE. - rewrite -mulr_sumr mulrC divff//. - by move:t0; rewrite lt0r=>/andP[]. - move:(t0)=> t0'; exists (PosNum t0')=>//; exists (t^-1 *: \sum_i (k i)%:num *: s i). - exists n.+1, s, (@FDist.make _ _ (finfun (fun i=> t^-1 * (k i)%:num)) tk0 tk1); split=> //. - rewrite scaler_sumr avgnrE. - apply congr_big=>// i _. - by rewrite scalerA ffunE. - by rewrite scalerA divff ?gt_eqF// scale1r. -move=>[t /= _] [a [n [s [d [sA ->]]]]] <-. -rewrite avgnrE scaler_sumr. -rewrite (@bigID_idem _ _ _ _ _ _ (fun i=> 0 < d i))/=; [| exact: addr0]. -have ->: \sum_(i | true && ~~ (0 < d i)) t%:num *: (d i *: s i) = \sum_(i | true && ~~ (0 < d i)) 0 *: 0. - apply congr_big=>// i /andP [_]; rewrite lt0r negb_and negbK. - move:(FDist.ge0 d i)=>->; rewrite orbF=>/eqP->. - by rewrite 2!scale0r GRing.scaler0. -rewrite -[\sum_(_ < _ | _) 0 *: 0]scaler_sumr scale0r addr0 -big_filter /=. -remember [seq i <- index_enum 'I_n | 0 < d i] as I; move: HeqI=>/esym HeqI. -case: I HeqI=> [| i I] HeqI. - exfalso; move: (FDist.f1 d) (oner_neq0 R); rewrite (@bigID_idem _ _ _ _ _ _ (fun i=> 0 < d i))/=; [|apply addr0 ]. - rewrite -big_filter HeqI big_nil/=. - rewrite add0r=><- /eqP; apply. - transitivity (\sum_(i < n | true && ~~ (0 < d i)) (0*0:R)). - 2: by rewrite -mulr_sumr mul0r. - apply congr_big=>// i /= dile; move: (FDist.ge0 d i); rewrite le0r. - rewrite (negbTE dile) orbF => /eqP ->. - by rewrite mul0r. -have: subseq (i::I) (index_enum 'I_n) by rewrite -HeqI; apply filter_subseq. -case: n s d sA i I HeqI=> [| n] s d sA i I HeqI. - by inversion i. -move=> /subseq_incl; move=> /(_ ord0); rewrite size_index_enum card_ord; move=> [f [fn flt]]. -rewrite /cone0_of/=. -exists (size I), (s \o (nth ord0 (i :: I))). -simple refine (ex_intro _ _ _). - move=> j. - apply: (fun x : {posnum R} => (t%:num * x%:num)%:pos). - simple refine (PosNum _). - exact (d (nth ord0 (i :: I) j)). - rewrite -HeqI. - apply/(@nth_filter _ (fun i=> 0 < d i)). - by rewrite HeqI. -split. - rewrite [in RHS]HeqI. - rewrite -[in RHS](mask_true (s:=i :: I) (leqnn (size I).+1)) big_mask. - apply congr_big=>// j. - by rewrite nth_nseq; case:j=>/= j ->. - move=>_ /=. - by rewrite scalerA (tnth_nth ord0)/=. -move=>+/= [j] _ <- =>_. -by apply sA; eexists. -Qed. - -Lemma cone0_of_sub_cone0_convex (A: set E) (B: {convex_set E}) : - (A `<=` B -> cone0 B -> cone0_of A `<=` B)%classic. -Proof. -rewrite cone0_of_hullE=>AB Bcone x [t t0 [a aA <-]]. -apply Bcone; exists t=>//; exists a=>//. -by apply (hull_sub_convex AB). -Qed. - -End cone. - - -Section Fun. -Variable E : convType R. -Variable f : E -> \bar R. - -Local Open Scope fun_scope. -Local Open Scope ring_scope. -Local Open Scope ereal_scope. -Local Open Scope convex_scope. - -Definition fconvex := forall (x y: E) (t: {prob R}), - f (x <|t|> y) <= EFin (Prob.p t : R) * f x + EFin (onem t)%R * f y. - -Definition fconvex_strict := forall (x y: E) (t: oprob R), x <> y -> - f (x <|t|> y) < EFin (Prob.p t : R) * f x + EFin (onem t)%R * f y. - -Lemma fconvex_max_ext (C: {convex_set E}) (x: E): - fconvex_strict -> - x \in C -> - f x < +oo -> - (forall y, y \in C -> f y <= f x) -> - x \in ext C. -Proof. -move=> fconv xC fxoo xmax. -rewrite in_setE/ext/= =>u v /xmax uC /xmax vC /set_mem [t] _ xE; subst x. -move: (prob_ge0 t); rewrite le0r=>/orP; case. - by move=>/eqP/val_inj ->; right; rewrite conv0. -move=>t0. -move: (prob_le1 t); rewrite -subr_ge0 le0r=>/orP; case. - rewrite subr_eq0=>/eqP t1. - rewrite (_ : t = 1%:pr)//; last first. - by apply/val_inj. - by left; rewrite conv1. -rewrite subr_gt0=>t1. -have t01: (Rdefinitions.IZR BinNums.Z0 < Prob.p t)%R && - (Prob.p t < Rdefinitions.IZR (BinNums.Zpos 1%AC))%R. - by apply/andP; split. -have [->|/eqP uv] := eqVneq u v; first by rewrite convmm; left. -move:(fconv u v (OProb.mk t01) uv)=>/=. -have fle: (Prob.p t)%:E * f u + (onem (Prob.p t))%:E * f v <= f (u <|t|> v). - have ->: f (u <|t|> v) = (Prob.p t)%:E * f (u <|t|> v) + (onem (Prob.p t))%:E * f (u <|t|> v). - rewrite -ge0_muleDl ?lee_fin /onem ?RminusE -?EFinD. - - by rewrite addrCA subrr addr0 mul1e. - - by apply ltW. - - by rewrite subr_ge0; apply/prob_le1. - apply: leeD; rewrite (@lee_pmul2l R)//= lte_fin. - by rewrite subr_gt0. -by move=>/(Order.POrderTheory.le_lt_trans fle); rewrite ltxx. -Qed. - -End Fun. diff --git a/theories/counterclockwise.v b/theories/counterclockwise.v deleted file mode 100644 index 461feb6..0000000 --- a/theories/counterclockwise.v +++ /dev/null @@ -1,380 +0,0 @@ -Require Export axiomsKnuth. -From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals. -From mathcomp Require Import normedtype order lra. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -(******************************************************************************) -(* | 1 p_x p_y | *) -(* det p q r == | 1 q_x q_y | *) -(* | 1 r_x r_y | *) -(* ccw p q r := counterclockwise *) -(* wccw p q r := counterclockwise or aligned (0 <= det p q r) *) -(******************************************************************************) - -From mathcomp.algebra_tactics Require Import ring. -From mathcomp.zify Require Import zify. - -Import GRing Num.Theory Order.POrderTheory Order.TotalTheory. - -Local Open Scope order_scope. -Local Open Scope ring_scope. - -Section Plane. -Variable R : realType. -Definition Plane : vectType _ := (R^o * R^o)%type. - -(* ------------------ Definitions ------------------- *) - -Definition xcoord (p : Plane) : R := p.1. -Definition ycoord (p : Plane) : R := p.2. - -Definition get_coord (i : 'I_3) := - match val i with - | 0 => xcoord - | 1 => ycoord - | _ => fun=> 1 - end. - -Definition get_pt (p q r : Plane) := fun j : 'I_3 => nth 0 [:: p; q; r] j. - -Let det_mx (p q r : Plane) := - \matrix_(i < 3, j < 3) get_coord i (get_pt p q r j). - -Definition det (p q r : Plane) : R := \det (det_mx p q r). - -Definition ccw (p q r : Plane) : bool := 0 < det p q r. - -Definition wccw (p q r : Plane) := (0 <= det p q r)%R. - -Lemma direct_distincts (p q r : Plane) : ccw p q r -> p <> q. -Proof. -move=> pqr pq; subst q; move: pqr; rewrite /ccw /det. -have n: (ord0: 'I_3) != lift ord0 ord0 by apply/eqP=>e; inversion e. -rewrite -det_tr (determinant_alternate n). - by rewrite ltxx. -by move=>i; rewrite !mxE. -Qed. - -Lemma det2 (R': comRingType) (M: 'M_2): (\det M: R') = - M ord0 ord0 * M (lift ord0 ord0) (lift ord0 ord0) - - M ord0 (lift ord0 ord0) * M (lift ord0 ord0) ord0. -Proof. -rewrite (expand_det_row M ord0) !big_ord_recl big_ord0 /cofactor !det_mx11. -rewrite !mxE/= /bump /= !(addn0,expr0,mul1r,add0n,addr0,expr1,mulN1r,mulrN)/=. -congr (_ - (_ * M _ _)). -exact: val_inj. -Qed. - -Lemma develop_det (p q r: Plane): det p q r = - xcoord r * (ycoord p - ycoord q) - - ycoord r * (xcoord p - xcoord q) + - xcoord p * ycoord q - ycoord p * xcoord q. -Proof. -rewrite /det (expand_det_col (det_mx p q r) (lift ord0 (lift ord0 (@ord0 0)))). -rewrite !big_ord_recl big_ord0 !mxE/= -!addrA; congr (_ * _ + _). - by rewrite /cofactor !det2 !mxE /get_coord/get_pt /=; ring. -by rewrite -mulrN; congr (_ * _ + _); - rewrite /cofactor !det2 !mxE /get_coord/get_pt /=; ring. -Qed. - -(* ---------------- produit scalaire (avec le deuxième argument tourné de pi/2) ----------------- *) -Definition scalar_product (p q: Plane) := p.1 * q.1 + p.2 * q.2. - -Definition rotate (p : Plane) := (p.2, -p.1). - -Definition swap (p : Plane) := (p.2, p.1). - -Lemma det_scalar_productE (p q r: Plane): - det p q r = scalar_product (q-p) (rotate (r-p)). -Proof. -rewrite develop_det /scalar_product /=. -rewrite /xcoord /ycoord /=. -ring. -Qed. - -Lemma scalar_productC (p q: Plane): scalar_product p q = scalar_product q p. -Proof. by rewrite /scalar_product /= [p.1*_]mulrC [p.2*_]mulrC. Qed. - -Lemma scalar_productZL (q r: Plane) (t: R): - scalar_product (t *: q) r = t * scalar_product q r. -Proof. by rewrite /scalar_product /= -!mulrA -mulrDr. Qed. - -Lemma scalar_productZR (q r: Plane) (t: R): - scalar_product q (t *: r) = t * scalar_product q r. -Proof. by rewrite scalar_productC scalar_productZL scalar_productC. Qed. - -Lemma scalar_productDl (p q r: Plane): - scalar_product (p + q) r = scalar_product p r + scalar_product q r. -Proof. by rewrite /scalar_product /=; ring. Qed. - -Lemma scalar_productDr (p q r : Plane): - scalar_product r (p + q) = scalar_product r p + scalar_product r q. -Proof. by rewrite scalar_productC scalar_productDl; congr add; apply scalar_productC. Qed. - -Lemma scalar_productrr_ge0 p : 0 <= (scalar_product p p). -Proof. by rewrite /scalar_product; apply addr_ge0; apply sqr_ge0. Qed. - -Lemma scalar_productrr_gt0 u : u != 0 -> 0 < scalar_product u u. -Proof. -move=>u0. -rewrite lt0r; apply/andP; split; last by apply scalar_productrr_ge0. -apply/negP; rewrite /scalar_product paddr_eq0. - 2, 3: by apply sqr_ge0. -rewrite 2!sqrf_eq0=>/andP[/eqP u10 /eqP u20]. -by move: u0=>/negP; apply; rewrite -pair_eqE; apply/andP; split; apply/eqP. -Qed. - -Lemma rotateZ (p : Plane) (t : R) : rotate (t *: p) = t *: rotate p. -Proof. -rewrite /rotate; apply pair_equal_spec; split=>//=. -by rewrite scalerN. -Qed. - -Lemma rotateD (p q : Plane) : rotate (p + q) = rotate p + rotate q. -Proof. -rewrite /rotate; apply pair_equal_spec; split=>//=. -by rewrite opprD. -Qed. - -Lemma rotate_rotate (p : Plane) : rotate (rotate p) = -p. -Proof. by case p=>a b; apply pair_equal_spec; split=>//. Qed. - -Lemma rotate_antisym (p q : Plane) : - scalar_product (rotate p) q = - scalar_product p (rotate q). -Proof. by rewrite /scalar_product/rotate/=; ring. Qed. - -Lemma scalar_product_rotatexx (p : Plane) : scalar_product p (rotate p) = 0. -Proof. by rewrite /scalar_product/rotate/=; ring. Qed. - -Lemma scalar_product_rotate (p q : Plane) : - scalar_product (rotate p) (rotate q) = scalar_product p q. -Proof. by rewrite/scalar_product/rotate/=; ring. Qed. - -Lemma swapD (p q : Plane) : swap (p+q) = swap p + swap q. -Proof. by apply pair_equal_spec. Qed. - -Lemma swapZ (p : Plane) (t : R) : swap (t *: p) = t *: swap p. -Proof. by apply pair_equal_spec. Qed. - -Lemma swapN (p : Plane) : swap (- p) = - swap p. -Proof. by rewrite -mulN1r swapZ scaleN1r. Qed. - -Lemma swapB (p q : Plane) : swap (p-q) = swap p - swap q. -Proof. by rewrite swapD swapN. Qed. - -Lemma swap_swap (p : Plane) : swap (swap p) = p. -Proof. by rewrite /swap/=; apply/esym; apply surjective_pairing. Qed. - -Lemma swap_inj : injective swap. -Proof. by move=>p q /(f_equal swap); rewrite 2!swap_swap. Qed. - -Lemma swap_sym (p q : Plane) : - scalar_product (swap p) q = scalar_product p (swap q). -Proof. by rewrite/scalar_product/swap/=; ring. Qed. - -Lemma scalar_product_swap (p q : Plane) : - scalar_product (swap p) (swap q) = scalar_product p q. -Proof. by rewrite swap_sym swap_swap. Qed. - -Lemma det_swap (p q r : Plane) : det (swap p) (swap q) (swap r) = - det p q r. -Proof. by rewrite 2!develop_det/swap/= /xcoord/ycoord/=; ring. Qed. - -Lemma decompose_base (p q : Plane) : q != 0 -> - p = (scalar_product p q) / (scalar_product q q) *: q + - (scalar_product p (rotate q)) / (scalar_product q q) *: rotate q. -Proof. -move=>q0. -move: (scalar_productrr_gt0 q0)=>/lt0r_neq0 q0'. -(* Is there an injectivity lemma I could use here ? *) -move: (q0')=>/negPf q0''. -apply/eqP; rewrite -subr_eq0 -[_ == 0]/(false || _) -q0'' -scaler_eq0 scalerDr scalerN subr_eq0 /= scalerDr !scalerA !mulrA ![_ q q * _ p _]mulrC -!mulrA divff ?q0'// !mulr1 -pair_eqE /scalar_product. -apply/andP; split; apply/eqP=>/=; cbn; ring. -Qed. - -(* ------------------ calcul de determinants ------------------- *) - -Lemma decompose_det (p q r t : Plane) : - det p q r = (det t q r) + (det p t r) + (det p q t). -Proof. by rewrite !develop_det; ring. Qed. - -Lemma det_inverse (p q r : Plane) : det p q r = - (det p r q). -Proof. by rewrite !develop_det; ring. Qed. - -Lemma det_cyclique (p q r : Plane) : det p q r = det q r p. -Proof. by rewrite !develop_det; ring. Qed. - -Lemma detDl (p1 p2 p3 q1 q2 q3 r1 r2 r3 : R) : - det (p1+p2, p3) (q1+q2, q3) (r1+r2, r3) = - det (p1, p3) (q1, q3) (r1, r3) + det (p2, p3) (q2, q3) (r2, r3). -Proof. by rewrite !develop_det/=; ring. Qed. - -Lemma detDr (p1 p2 p3 q1 q2 q3 r1 r2 r3 : R) : - det (p1, p2+p3) (q1, q2+q3) (r1, r2+r3) = - det (p1, p2) (q1, q2) (r1, r2) + det (p1, p3) (q1, q3) (r1, r3). -Proof. by rewrite !develop_det/=; ring. Qed. - -Lemma detZl (p1 p2 q1 q2 r1 r2 t : R) : - det (t * p1, p2) (t * q1, q2) (t * r1, r2) = - t * det (p1, p2) (q1, q2) (r1, r2). -Proof. by rewrite !develop_det/=; ring. Qed. - -Lemma detZr (p1 p2 q1 q2 r1 r2 t : R) : - det (p1, t * p2) (q1, t * q2) (r1, t * r2) = - t * det (p1, p2) (q1, q2) (r1, r2). -Proof. by rewrite !develop_det/=; ring. Qed. - -Lemma det_alternate (p q : Plane) : det p p q = 0. -Proof. -apply/eqP; rewrite -[_ == 0]/(false || _) . -have<-: (2%:R : R) == 0 = false by rewrite pnatr_eq0. -by rewrite -mulf_eq0 mulr_natl 2!det_cyclique mulr2n {2}det_inverse subrr. -Qed. - -Lemma det0_colinear (p q r : Plane) : det p q r = 0 <-> - exists (t : Plane), t != 0 /\ scalar_product t q = scalar_product t p /\ - scalar_product t r = scalar_product t p. -Proof. -rewrite det_scalar_productE; move: p q r. -suff: forall p q : Plane, scalar_product p (rotate q) = 0 <-> (exists (t : Plane), t != 0 /\ scalar_product t p = 0 /\ scalar_product t q = 0). - move=>h p q r; move: h=> /(_ (q-p) (r-p)) ->; split. - by move=>[t [t0 ts]]; exists t; split=>//; split; apply/eqP; rewrite -subr_eq0 -mulN1r -scalar_productZR -scalar_productDr scaleN1r; apply /eqP; apply ts; rewrite !in_cons eq_refl ?orbT. - by move=>[t [t0 [qp rp]]]; exists t; split=>//; rewrite -scaleN1r 2!scalar_productDr scalar_productZR mulN1r qp rp subrr. -move=> p q; split. - 2: by move=>[t [t0 [p0 q0]]]; rewrite (decompose_base p t0) [_ p t]scalar_productC p0 mul0r scale0r add0r scalar_productZL scalar_product_rotate q0 mulr0. -move=>pq. -case p0: (p == 0). - move: p0=>/eqP p0; subst p. - case q0: (q == 0). - move: q0=>/eqP q0; subst q. - exists (1, 0); split. - by rewrite negb_and; apply/orP; left=>/=; apply: oner_neq0. - by rewrite -(scale0r (0 : Plane)) scalar_productZR mul0r. - exists (rotate q); split. - apply/eqP=>/pair_equal_spec [q2 /eqP]; rewrite oppr_eq0=>/eqP q1. - by move: q0; rewrite -pair_eqE/pair_eq q1 q2 eq_refl. - by rewrite scalar_productC [_ _ q]scalar_productC scalar_product_rotatexx. -exists (rotate p); split. - apply/eqP=>/pair_equal_spec [p2 /eqP]; rewrite oppr_eq0=>/eqP p1. - by move: p0; rewrite -pair_eqE/pair_eq p1 p2 eq_refl. -split. - by rewrite scalar_productC scalar_product_rotatexx. -by rewrite rotate_antisym pq oppr0. -Qed. - -Lemma direct_uniq p q r : ccw p q r -> uniq [:: p; q; r]. -Proof. -move=>pqr. -apply/andP; split. - 2: by rewrite in_cons 2!in_nil orbF 2!andbT; apply/eqP; apply (@direct_distincts q r p); rewrite /ccw 2!det_cyclique. -rewrite negb_or orbF; apply/andP; split. - by apply/eqP; exact (direct_distincts pqr). -by rewrite eq_sym; apply/eqP; apply (@direct_distincts r p q); rewrite /ccw det_cyclique. -Qed. - -Lemma convex_combination p q r s t : - det t q r * det t s p + - det t r p * det t s q + det t p q * det t s r = - 0. -Proof. by rewrite !develop_det; ring. Qed. - - - -(***** Misc *) -Local Open Scope order_scope. -Import Order. -Lemma subr_gtlex0 (p q : Plane) : ((0%:R : R *l R) < q-p) = ((p : R *l R) < q). -Proof. -rewrite/lt/=/ProdLexiOrder.lt; congr (_ && (_ ==> _)). -- by rewrite subr_ge0. -- by rewrite subr_le0. -- by rewrite subr_gt0. -Qed. - -End Plane. - -Module ccw_KA <: KnuthAxioms. -Section Dummy. -Variable (R : realType). -Definition Plane := Plane R. -Definition OT := ccw (R:=R). - -Theorem Axiom1 (p q r : Plane) : OT p q r -> OT q r p. -Proof. -congr (_ < _). -rewrite !develop_det; ring. -Qed. - -Theorem Axiom2 (p q r : Plane) : OT p q r -> ~ OT p r q. -Proof. -rewrite /OT /ccw lt0r=>/andP [_ pqr]. -rewrite det_inverse oppr_gt0. -by rewrite ltNge pqr. -Qed. - -Theorem Axiom4 (p q r t : Plane) : - OT t q r -> OT p t r -> OT p q t -> OT p q r. -Proof. -rewrite /OT /ccw (decompose_det p q r t)=> tqr ptr pqt. -apply addr_gt0=>//. -apply addr_gt0=>//. -Qed. - -Theorem Axiom5 t s p q r : - OT t s p -> - OT t s q -> - OT t s r -> OT t p q -> OT t q r -> OT t p r. -Proof. -rewrite /OT /ccw => tsp tsq tsr tpq tqr. -have->: det t p r = - det t r p by rewrite !develop_det; ring. -rewrite ltNge oppr_le0; apply /negP=>trp. -suff: 0 < det t q r * det t s p + det t r p * det t s q + det t p q * det t s r. - by rewrite convex_combination ltxx. -rewrite addrC. -apply ltr_wpDr; [| by apply mulr_gt0]. -by apply addr_ge0; apply mulr_ge0=>//; apply ltW. -Qed. - -Local Open Scope order_scope. -Import Order. - -Theorem Axiom5' (pivot p q r : Plane) : - (pivot : R *l R) < p -> - (pivot : R *l R) < q -> - (pivot : R *l R) < r -> - ccw pivot p q -> - ccw pivot q r -> - ccw pivot p r. -Proof. -rewrite /ccw 3!det_scalar_productE/scalar_product/= !mulrN !subr_gt0 -![(pivot : R *l R) < _]subr_gtlex0 {1 2 3}/lt/=/ProdLexiOrder.lt/= !implybE -!ltNge !le_eqVlt ![(_==_)||_]orbC -!Bool.orb_andb_distrib_r=>/orP; case=>p0. - move=>/orP; case=>q0. - move=>/orP; case=>r0. - rewrite -(ltr_pdivrMl _ _ p0) mulrA -(ltr_pdivlMr _ _ q0) [_^-1*_]mulrC -(ltr_pdivrMl _ _ q0) mulrA -(ltr_pdivlMr _ _ r0) [_^-1*_]mulrC -(ltr_pdivrMl _ _ p0) mulrA -(ltr_pdivlMr _ _ r0) [_^-1*_]mulrC=>qlt rlt; exact (lt_trans qlt rlt). - move:r0=>/andP[/eqP<- r0]. - by rewrite 2!mulr0 pmulr_rgt0// pmulr_rgt0//. - move:q0=>/andP[/eqP<- q0]/orP; case. - move=>r0 _; rewrite mul0r pmulr_rlt0// =>r0'. - by move: (lt_trans r0 r0'); rewrite ltxx. - by move=>/andP[/eqP<- _] _; rewrite mul0r mulr0 ltxx. -move:p0=>/andP[/eqP<- p0]. -rewrite 2!mul0r pmulr_rlt0// pmulr_rlt0// =>/orP; case. - by move=>q0 _ q0'; move:(lt_trans q0 q0'); rewrite ltxx. -by move=>/andP[/eqP<- q0]; rewrite ltxx. -Qed. - -End Dummy. -End ccw_KA. - -(*Lemma Axiom5bis : - forall t s p q r : Plane, - OT s t p -> - OT s t q -> - OT s t r -> OT t p q -> OT t q r -> OT t p r. -Proof. -move=> t s p q r; rewrite /OT/sensDirect -![det s t _]det_cyclique ![det _ s t]det_inverse ![det _ t s]det_cyclique !oppr_gt0=>tsp tsq tsr tpq tqr. -rewrite det_inverse oppr_gt0 -(nmulr_lgt0 _ tsq). -have ->: det t r p * det t s q = - (det t q r * det t s p + det t p q * det t s r) by rewrite !develop_det; ring. -by rewrite opprD; apply addr_gt0; rewrite oppr_gt0 nmulr_llt0. - Qed.*) diff --git a/theories/desc.v b/theories/desc.v deleted file mode 100644 index 30e5ffa..0000000 --- a/theories/desc.v +++ /dev/null @@ -1,1260 +0,0 @@ -From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype order. -From mathcomp Require Import binomial bigop ssralg poly ssrnum ssrint rat archimedean. -From mathcomp Require Import polyrcf. -Require Import pol. - -(** Defining function over lists of rationals that find lists containing - exactly one alternation, from negative to positive values. *) - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Import GRing.Theory. -Import Order.Theory Num.Theory Num.Def. -Local Open Scope ring_scope. - -(** ** Sign changes *) - -Section SignChange. - -Variable R :realDomainType. -Implicit Type l: (seq R). - -Definition all_eq0 l := all (fun x => x == 0) l. -Definition all_ge0 l:= all (fun x => 0 <= x) l. -Definition all_le0 l := all (fun x => x <= 0) l. -Definition all_ss a l := all (fun x => 0 <= x * a) l. -Definition opp_seq l := [seq - z | z <- l]. - -Fixpoint alternate_1 l := - if l is a::tl then - if 0 < a then all_ge0 tl else alternate_1 tl - else false. - -Fixpoint alternate l := - if l is a::tl then - if a < 0 then alternate_1 tl else - if a == 0 then alternate tl else false - else false. - -Fixpoint schange_index_aux l i y := - if l is x::l' then - if (((y==0) && (x != 0)) || (x*y < 0)) then i :: schange_index_aux l' i.+1 x - else schange_index_aux l' i.+1 y - else [::]. - -Definition schange_index l := schange_index_aux l 0 0. - -Notation SIA := schange_index_aux. (* local short notation *) - - -(** Some helper lemmas *) - -Lemma product_neg (a b : R): a * b < 0 -> a != 0 /\ b != 0. -Proof. -move => h. -case bz: (b!=0); last by move: h; rewrite (eqP (negbFE bz)) mulr0 ltxx. -case az: (a!=0); last by move: h; rewrite (eqP (negbFE az)) mul0r ltxx. -done. -Qed. - -Lemma schange_simpl (a b x: R): b * a < 0 -> 0 <= x * b -> x * a <= 0. -Proof. -move => pa. -rewrite - (nmulr_lle0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lle0 //. -by rewrite lt0r sqr_ge0 sqrf_eq0 (proj1 (product_neg pa)). -Qed. - - -Lemma schange_simpl1 (a b x: R): b * a < 0 -> 0 < x * b -> x * a < 0. -Proof. -move => pa. -rewrite - (nmulr_llt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_llt0 //. -by rewrite lt0r sqr_ge0 sqrf_eq0 (proj1 (product_neg pa)). -Qed. - - -Lemma schange_simpl2 (a b x: R): b * a < 0 -> x * b < 0 -> 0 < x * a. -Proof. -move => pa. -rewrite - (nmulr_lgt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lgt0 //. -by rewrite lt0r sqr_ge0 sqrf_eq0 (proj1 (product_neg pa)). -Qed. - -Lemma all_rev l p: all p l = all p (rev l). -Proof. by elim:l => [// | a l hr]; rewrite rev_cons all_rcons /= hr. Qed. - -Lemma has_split p l: has p l -> - exists l1 a l2, [/\ l = l1 ++ a :: l2, p a & all (fun z => ~~(p z)) l1]. -Proof. -elim:l => // a l Hrec /=; case ha: (p a) => /=. - by move => _; exists [::], a, l; split => //. -move /Hrec => [l1 [b [l2 [-> pb pc]]]]. -by exists (a::l1),b,l2; split => //=; rewrite ha pc. -Qed. - -Lemma has_split_eq l: has (fun z => z != 0) l -> - exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l1]. -Proof. -move/has_split => [l1 [a [l2 [-> pa pb]]]]; exists l1,a,l2; split => //. -by apply /allP => x; move /(allP pb); case (x==0). -Qed. - -Lemma has_split_eq_rev l: has (fun z => z != 0) l -> - exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l2]. -Proof. -have <- : (has (fun z : R => z != 0)) (rev l) = has (fun z : R => z != 0) l. - by elim:l => [// | a l hr]; rewrite rev_cons has_rcons /= hr. -move/has_split_eq => [l1 [a [l2 [lv pa pb]]]]; exists (rev l2),a,(rev l1). -by rewrite -(cat1s a) catA cats1 -rev_cons -rev_cat -lv revK /all_eq0 -all_rev. -Qed. - -Lemma opp_seqK l :opp_seq (opp_seq l) = l. -Proof. -by rewrite/opp_seq -map_comp; apply map_id_in => a /=; rewrite opprK. -Qed. - -(** We give here a specification for alternate *) - -Lemma alternate1_p l1 x l2: - all_eq0 l1 -> x <0 -> alternate_1 l2 -> alternate (l1++x :: l2). -Proof. -elim:l1; first by move => _ xn h //=; rewrite xn. -by move => a l Hrec /= /andP [az lz] xz; rewrite az (eqP az) ltxx; apply: Hrec. -Qed. - -Lemma alternate_1P (l: seq R): - reflect (exists l1 x l2, - [/\ l = l1 ++ ( x :: l2), all_le0 l1, all_ge0 l2 & x > 0] ) - (alternate_1 l). -Proof. -apply: (iffP idP). - elim:l => [// | a l Hrec /=]; case: (ler0P a) => sa. - move => /Hrec [l1 [x [l2 [-> l1n l2p xp]]]]. - by exists (a::l1), x, l2 => /=;rewrite sa. - by move => h1; exists [::], a, l. -move=> [l1 [x [l2 [-> l1n l2p xp]]]]. -move: l1 l1n; elim; first by move => _ /=; rewrite xp. -by move => a l1' Hrec /= /andP [] ap / Hrec aux;rewrite ltNge ap. -Qed. - -Lemma alternate_P (l: seq R): - reflect (exists l1 x l2 y l3, - [/\ l = l1 ++ x :: l2 ++ (y :: l3), x<0, y> 0 - & [/\ all_eq0 l1, all_le0 l2& all_ge0 l3]]) - (alternate l). -Proof. -apply: (iffP idP); last first. - move => [l1 [x [l2 [y [l3 [-> xn yp [l1p l2p l3p]]]]]]]. - have h:alternate_1 (l2 ++y :: l3) by apply /alternate_1P; exists l2, y, l3. - move: l1p; elim l1; first by rewrite /= xn h. - by move => a l' hrec /= /andP [ az] /hrec ->; rewrite lt_neqAle az. -elim: l => // a l Hrec /=. -rewrite lt_neqAle; case az: (a==0). - rewrite andFb => /Hrec [l1 [x [l2 [y [l3 [-> xn yn [l1n l2z l3p]]]]]]]. - exists (a :: l1), x, l2, y,l3; split => //; split => //. - apply /allP => t; rewrite in_cons; case /orP; last by move/(allP l1n). - move /eqP;move/eqP: az => -> -> //. -case ane:(a <= 0) => //= /alternate_1P [l1 [x [l2 [-> l1n l2p xp]]]]. -by exists [::], a, l1, x,l2; rewrite lt_neqAle az ane. -Qed. - -Lemma schangei_Sn l n a: SIA l n.+1 a = [seq z.+1 | z <- SIA l n a]. -Proof. -move: n a; elim: l => [ n z // | a l hrec n y /=]. -by case hyp: ((y == 0) && (a != 0) || (a * y < 0))=> //=; rewrite hrec. -Qed. - -Lemma schangei_addm l n m a: - SIA l (n+m)%N a = [seq (z+m)%N | z <- SIA l n a]. -Proof. -move: n a; elim: l => [ n z // | a l hrec n y /=]. -by case hyp: ((y == 0) && (a != 0) || (a * y < 0))=> //=; rewrite - addSn hrec. -Qed. - -Lemma schangei_opp l: schange_index l = schange_index (opp_seq l). -Proof. -rewrite /schange_index - {2}oppr0; move: 0 0%N; elim: l; first by done. -by move => a l hrec y n /=; rewrite mulrNN - hrec - hrec ! oppr_eq0. -Qed. - -Lemma schangei_s0 l1 l2: all_eq0 l1 -> - schange_index (l1 ++ l2) = SIA l2 (size l1) 0. -Proof. -elim l1 => // a l hrec /= /andP [/eqP -> /hrec]. -by rewrite /schange_index /= mul0r eqxx ltxx andbF orbF !schangei_Sn => ->. -Qed. - -Lemma schangei0 l: all_eq0 l <-> schange_index l = [::]. -Proof. -split; first by move /schangei_s0 => h; move: (h [::]); rewrite /= cats0. -suff: forall l n, SIA l n 0 = [::] -> all_eq0 l by apply. -elim => [ // | a l' hrec n]. -by rewrite /= eqxx mulr0 ltxx orbF andTb; case az: (a==0) => //= /hrec. -Qed. - -Lemma schangei_s0n l1 a l2: a !=0 -> all_eq0 l1 -> - schange_index (l1 ++a :: l2) = size l1 :: (SIA l2 (size l1).+1 a). -Proof. by move => anz alz; rewrite (schangei_s0 _ alz) /= eqxx anz. Qed. - -Lemma schangei_snn l i s: - schange_index l = i::s -> exists l1 a l2, - [/\ l = l1 ++a :: l2, a != 0, i = size l1, all_eq0 l1 & - SIA l2 (size l1).+1 a = s]. -Proof. -case alt: (all_eq0 l); first by move /schangei0:alt => -> //. -move: (allPn (negbT alt)) => /hasP /has_split_eq [l1 [a [l2 [ -> az al0]]]]. -rewrite (schangei_s0n _ az al0) => /eqP;rewrite eqseq_cons. -by move => /andP [/eqP <- /eqP <-];exists l1, a, l2. -Qed. - -Lemma schangei_rec a l1 l2 n: a != 0 -> all_ss a l1 -> - SIA (l1++l2) n a = SIA l2 (n + size l1)%N a. -Proof. -move => anz; move: n; elim : l1;first by move =>n /=; rewrite addn0. -move =>b l hrec n /= /andP [pa pb]. -by rewrite ltNge pa (negbTE anz) /= (hrec _ pb) addnS addSn. -Qed. - -Lemma schangei_reca a l n: a != 0 -> ((all_ss a l) = (SIA l n a == [::])). -Proof. -move => anz; move: n; elim: l => [// | b l h n]. -by rewrite /= (negbTE anz)/= (h n.+1) ltNge; case sab: (0 <= b * a). -Qed. - -Lemma schangei_recb a l1 b l2 n: b * a < 0 -> all_ss a l1 -> - SIA (l1++ b::l2) n a = (n+size l1)%N :: SIA l2 (n + size l1).+1 b. -Proof. -move => h1 h2; move : (product_neg h1) => [bz az]. -by rewrite (schangei_rec _ _ az h2) /= bz h1 orbT. -Qed. - -Lemma schangei_recc a l i s n: a!= 0 -> - SIA l n a = i :: s -> exists l1 b l2, - [/\ l = l1 ++ b :: l2, b *a <0, b!= 0, (all_ss a l1) & - (i = n+size l1)%N /\ SIA l2 (n + size l1).+1 b = s]. -Proof. -move => anz;case alz: (all_ss a l). - by move: alz; rewrite (schangei_reca _ n anz) => /eqP ->. -move: (negbT alz); rewrite - (has_predC) => /has_split [l1 [b [l2 [-> pb pc]]]]. -move: pb => /=; rewrite - ltNge => abn. -case bz: (b!=0); last by move: abn; rewrite (eqP (negbFE bz)) mul0r ltxx. -have pc': all_ss a l1 by apply /allP => t /(allP pc) /= /negbNE. -rewrite (schangei_recb l2 n abn pc') => /eqP h. -by exists l1,b, l2; move: h; rewrite eqseq_cons => /andP [/eqP <- /eqP ->]. -Qed. - -Definition schange l := (size (schange_index l)).-1. - -Lemma schange_index_alternate l: (schange l = 1%N) <-> - (alternate l \/ alternate (opp_seq l)). -Proof. -have aux0 : (schange l = 1%N) <-> size (schange_index l) = 2%N. - rewrite /schange; split; last by move => ->. - by case (size (schange_index l)) => // n /= ->. -apply:(iff_trans aux0). -have aux: forall l, alternate l -> size (schange_index l) = 2%N. - move => l0 /alternate_P [l1 [x [l2 [y [l3 [-> xn yp [l1p l2p l3p]]]]]]]. - move: (xn); rewrite lt_neqAle => /andP [xnz _]. - move: (yp); rewrite lt0r => /andP [ynz _]. - have yxn: y * x < 0 by rewrite pmulr_rlt0. - have l2p': all_ss x l2 by apply /allP => z/(allP l2p); rewrite nmulr_lge0. - have l3p': all_ss y l3 by apply /allP => z/(allP l3p); rewrite pmulr_lge0. - move: l3p'; rewrite (schangei_reca l3 ((size l1).+1 + size l2).+1 ynz). - by rewrite (schangei_s0n _ xnz l1p) (schangei_recb _ _ yxn l2p') => /eqP->. -have p1a: forall a l, a <0 -> all_ss a l -> all_le0 l. - by move => a l1 anz h; apply /allP => x /(allP h); rewrite nmulr_lge0. -have p1b: forall b l, 0 all_ss b l -> all_ge0 l. - by move => a l1 anz h; apply /allP => x /(allP h); rewrite pmulr_lge0. -have px: forall a l, a !=0 -> all_ss a l -> all_ss (-a) (opp_seq l). - move => a l1 anz h; apply /allP => x /mapP [y /(allP h) h1 ->]. - by rewrite mulrNN. -split; last first. - by case; move /aux => //; rewrite - schangei_opp. -move=> h. -have [i [j]]: exists a b, (schange_index l) = [:: a; b]. - move: h; set s := (schange_index l); case: s => // a; case => // b. - by case => // _; exists a, b. -move /schangei_snn => [l1 [a [l2 [lv anz iv pr1 pr2]]]]. -move: (schangei_recc anz pr2); move =>[l3 [b [l4 [l2v ban bz l3p [jv]]]]]. -move /eqP; rewrite - (schangei_reca _ _ bz) => l4p. -move:anz; rewrite neq_lt; case /orP => sa; [left | right];apply /alternate_P. - exists l1, a, l3, b, l4; move: ban;rewrite lv l2v (nmulr_llt0 b sa) => sb. - split => //;split; [ exact| apply: (p1a _ _ sa l3p)| apply: (p1b _ _ sb l4p)]. -exists (opp_seq l1), (-a), (opp_seq l3), (-b), (opp_seq l4); move: ban. -rewrite (pmulr_llt0 b sa) => bn. -have man: - a < 0 by rewrite oppr_lt0. -have mbp: 0 < - b by rewrite oppr_gt0. -split => //. - by rewrite lv l2v /opp_seq map_cat map_cons map_cat map_cons. -split. - by apply /allP => x /mapP [y /(allP pr1) /eqP -> ->]; rewrite oppr0 eqxx. - by apply (p1a (- a)) => //; apply px => //; move: sa; rewrite lt0r;case /andP. -by apply (p1b (- b)) => //; apply px. -Qed. - -Lemma schange_cat l1 a l2: a != 0 -> - schange (l1++a::l2) = (schange (l1++[::a]) + schange (a::l2)) %N. -Proof. -have aux: forall a b l n m, a * b >0 -> size (SIA l n a) = size (SIA l m b). - move => c1 c2 l n m cp. - rewrite -(add0n n) - (add0n m) !schangei_addm ! size_map. - elim: l => // => u v Hrec /=. - move: cp; case c1z: (c1 == 0); first by rewrite (eqP c1z) mul0r ltxx. - case c2z: (c2 == 0); first by rewrite (eqP c2z) mulr0 ltxx. - rewrite (mulrC u) (mulrC u). - move => cp; have ->: (c1 * u < 0) = (c2 * u < 0). - apply/idP/idP => h; [ rewrite mulrC in cp |];exact :(schange_simpl1 h cp). - simpl; case: (c2 * u < 0) => //. - by rewrite - (add0n 1%N) !schangei_addm ! size_map Hrec. -rewrite /schange -cat1s catA => anz. -have: has (fun z => z != 0) (l1 ++ [:: a]). - by apply /hasP; exists a => //; rewrite mem_cat mem_head orbT. -move /has_split_eq => [l3 [b [l4 [lv bnz al0]]]]. -rewrite lv (schangei_s0n l4 bnz al0) -catA cat_cons (schangei_s0n _ bnz al0). -rewrite /schange_index cat1s {3} /SIA eqxx anz /= - /SIA. -have : a = last b l4 by move: (f_equal (last a) lv); rewrite !last_cat. -move: (size l3).+1 => n; move: {2} (SIA l4 n b) (erefl (SIA l4 n b)) => s. -clear lv l1; move: n b l4 bnz. -elim: s. - move => n b l4 bnz h alb; rewrite h add0n. - have asb: all_ss b l4 by rewrite (schangei_reca _ n bnz) h eqxx. - rewrite schangei_rec //; apply: aux; rewrite lt0r (mulf_neq0 bnz anz)/=. - have: a \in b :: l4 by rewrite alb mem_last. - rewrite inE; case /orP; first by move /eqP -> ; rewrite sqr_ge0. - by move /(allP asb); rewrite mulrC. -move => i s Hrec n b l4 bnz. -move /(schangei_recc bnz) => [l1 [c [l5 [lv pa pb pc [pd pe]]]]] pf. -have pg: a = last c l5 by rewrite pf lv last_cat last_cons. -rewrite lv - catA cat_cons ! (schangei_recb _ _ pa pc) /=. -by rewrite (Hrec (n + size l1).+1 c l5 pb pe pg) addSn. -Qed. - -Lemma schange_index_tail1 s i l n a: a !=0 -> SIA l n a = rcons s i -> - exists l1 b l2, [/\ l = l1 ++ b :: l2, b !=0, i = (n + size l1)%N & - all_ss b l2 ]. -Proof. -move: l n a; elim:s. - move => l n b bnz /= h. - move: (schangei_recc bnz h)=> [l1 [c [l2 [-> pa cz pb [pc pd]]]]]. - by exists l1,c,l2; split => //; move:pd => /eqP; rewrite - schangei_reca. -move => a l Hrec l2 n b bnz;rewrite rcons_cons. -move /(schangei_recc bnz) => [l1 [c [l3 [-> pa cz pb [pc]]]]]. -move /(Hrec _ _ _ cz) => [l0 [d [l4 [-> qa -> qc]]]]. -by exists ( l1 ++ c :: l0), d,l4; rewrite -catA cat_cons addSnnS size_cat addnA. -Qed. - -Lemma schange_index_tail2 s i l: schange_index l = rcons s i -> - exists l1 (a : R) l2, - [/\ l = l1 ++ a :: l2, a != 0, i = size l1 & all_ss a l2]. -Proof. -case: s. - move /schangei_snn => [l1 [a [l2 [ -> pb pc pd pe]]]]; exists l1, a, l2. - by split => //; move: pe => /eqP; rewrite -schangei_reca. -move => j s; move /schangei_snn => [l1 [a [l2 [-> pb pc _]]]]. -move /(schange_index_tail1 pb) => [l0 [b [l3 [-> qb -> qd]]]]. -exists (l1++a::l0),b,l3; rewrite - catA cat_cons addSnnS size_cat //=. -Qed. - - -Lemma schange_index_tail l i s : - schange_index l = rcons s i -> exists l1 a l2, - [/\ l = l1 ++ a :: l2, (i <= size l1)%N, 0 < a * l`_i & all_eq0 l2]. -Proof. -move => /schange_index_tail2 [l1 [a [l2 [-> pa pb pc]]]]. -have:has (fun z => z != 0) (a::l2) by rewrite /= pa. -move /has_split_eq_rev => [la [b [lb [qa qb qc]]]]. -exists (l1 ++ la),b, lb. - rewrite pb size_cat leq_addr nth_cat ltnn subnn /= qa catA; split => //. -rewrite lt0r (mulf_neq0 qb pa) /=. -have: b \in a :: l2 by rewrite qa mem_cat mem_head orbT. -rewrite in_cons =>/orP []; first by move /eqP => ->; rewrite sqr_ge0. -by move /(allP pc). -Qed. - -Lemma schange_odd1 x l y: x * y < 0 -> odd (schange (x::l ++ [::y])). -Proof. -move => xy; rewrite /schange. -move: (product_neg xy) => [xnz ynz]. -set s := schange_index (x :: l ++ [:: y]). -move: (refl_equal s); rewrite {1} /s; case: s. - have xl: x \in x :: l ++ [:: y] by rewrite mem_head. - by move /schangei0 => h; move: xnz; move/(allP h):xl => /eqP ->; rewrite eqxx. -move => i s /=. -rewrite /schange_index /= eqxx xnz orTb => /eqP; rewrite eqseq_cons => /andP. -move => [ _] /eqP. -have ->: (size s)= (((x * y>=0)%R) + size s)%N by rewrite leNgt xy. -clear i xy;move: x xnz 1%N l; elim: s. - move => x xnz n l => /eqP; rewrite -(schangei_reca _ _ xnz) => ss. - have: y \in (l ++ [:: y]) by rewrite mem_cat inE eqxx orbT. - by move /(allP ss); rewrite mulrC => ->. -move => a s Hrec x xnz n l. -move/(schangei_recc xnz)=> [l1 [c [l2 [lv pa cnz pb [pc]]]]]. -have cp:0 < c * c by rewrite lt0r sqr_ge0 sqrf_eq0 (proj1 (product_neg pa)). -have ->: (0 <= x * y) = ~~(0 <= c * y). - rewrite - (nmulr_rle0 (c * y) pa) mulrACA (pmulr_rle0 _ cp). - by rewrite - ltNge lt_neqAle eq_sym (mulf_neq0 xnz ynz). -move: (f_equal (last c) lv); rewrite !last_cat !last_cons /= addnS. -case l2; first by move => ->; rewrite (ltW cp) /= => <-. -move => i1 l4; rewrite last_cons (lastI i1 l4) - cats1 => <-. -move /(Hrec c cnz (n + size l1).+1 _). -by case b:((0 <= c * y)%R) => //= ->. -Qed. - -Lemma schange_index_correct l (i: nat): - i \in (schange_index l) -> (l`_i != 0 /\ l`_i * (0::l)`_i <= 0). -Proof. -move: {2 3} (schange_index l) (refl_equal (schange_index l)); case => //. -have aux: forall i l n a, - i \in SIA l n a -> exists2 j:nat, j \in SIA l 0 a & i = (j + n)%N. - by move => i' l' n a; rewrite -(add0n n) schangei_addm; move /mapP. -move => k s /schangei_snn [l1 [a [l2 [-> anz il1 l1z sv]]]]. -rewrite inE; case/ orP. - move /eqP ->; rewrite !nth_cat il1 ltnn subnn /=; split => //. - rewrite -cat_cons nth_cat /= ltnS leqnn -last_nth. - suff : (last 0 l1 == 0) by move => /eqP ->; rewrite mulr0. - by move: (mem_last 0 l1); rewrite inE => /orP; case => //; move /(allP l1z). -rewrite - sv => isv. -move : (aux i l2 (size l1).+1 a isv) => [j j2 j1]. -rewrite j1 addnC nth_cat - cat_cons nth_cat addSn - addnS ltnNge leq_addr /=. -rewrite addnC addnK /= addSn ltnNge ltnS leq_addl /= -addnS addnK. -move: j2; clear il1 l1z isv j1 sv k s l1 l i. -move: {1} 0%N {1} (SIA l2 0 a) (refl_equal (SIA l2 0 a)) => n s. -move:s l2 a n j anz; elim. - by move => l2 a n j _; rewrite -(add0n n) schangei_addm; case (SIA l2 0 a). -move => a s Hrec l b n j bnz => eq1;symmetry in eq1. -move: (schangei_recc bnz eq1)=> [l1 [c [l3 [pa pb cz pc [pd pe]]]]] => js. -have: (j + n)%N \in SIA l n b. - by rewrite-{2} (add0n n) schangei_addm; apply /mapP; exists j. -rewrite eq1 in_cons => /orP []. - rewrite pd addnC eqn_add2l => /eqP ->. - rewrite pa - cat_cons nth_cat ltnn subnn; split => //. - rewrite /= - (cat_cons) nth_cat /= ltnS leqnn -last_nth. - move: (mem_last b l1)=> /orP;case; first by move/eqP => ->;apply: ltW. - by rewrite mulrC; move/(allP pc); apply schange_simpl; rewrite mulrC. -rewrite - pe - addnS (addnC n) schangei_addm; move /mapP. -move => [j0 ka] /eqP; rewrite eqn_add2r => /eqP => ->. -move: ka; rewrite -(add0n (size l1).+1) schangei_addm => /mapP [k jv ->]. -symmetry in pe; move: (Hrec l3 c (n + size l1).+1 k cz pe jv). -rewrite pa - cat_cons ! nth_cat - addSnnS leqNgt ltnS leq_addl /=. -by rewrite addnK /= addSnnS leqNgt ltnS leq_addl /= addnK. -Qed. - -Lemma schange_monotone l l' (s:= schange_index l): - (forall k, k \in s ->l`_k * l'`_k <0) -> - l`_ (last 0%N s) * l'`_(size l) > 0 -> - (schange l < schange l') %N. -Proof. -have: schange_index l = s by []. -case: s. - move/schangei0 => alz _; rewrite /last. - suff: l`_0 = 0 by move => ->; rewrite mul0r ltxx. - by move: alz; case l => // a l1 /= /andP [/eqP ->]. -have rec0: forall l1 l2, l2`_0 != 0 -> (schange (l2) <= schange (l1++l2))%N. - by move => l1; case => // a l2 /= anz; rewrite (schange_cat _ _ anz) leq_addl. -have rec1: forall l i j, l`_i * l`_j < 0 -> (0 < (schange l))%N. - move => l1 i j; wlog : i j / (i<= j)%N. - by case /orP:(leq_total i j)=> cij h; [ | rewrite mulrC]; apply:h. - move => lij ov. - move: (product_neg ov) => [anz bnz]. - have st: size (take i l1) = i. - rewrite size_take; case (ltnP i (size l1)) => // sl. - by move: anz; rewrite (nth_default 0 sl) eqxx. - move: (cat_take_drop i l1) => eq1. - have e2: l1`_i = (drop i l1)`_0 by rewrite - {1} eq1 nth_cat st ltnn subnn. - have e3: (drop i l1)`_0 != 0 by rewrite - e2. - have e4: l1`_j = (drop i l1)`_(j-i) by rewrite -{1}eq1 nth_cat st ltnNge lij. - move:ov; rewrite e2 e4; set l3 := (drop i l1); set k:= (j - i)%N => ov. - move: (rec0 (take i l1) l3 e3); rewrite eq1; apply: leq_trans. - have st': size (take k l3) = k. - rewrite size_take; case (ltnP k (size l3)) => // sl. - by move: bnz; rewrite e4 (nth_default 0 sl) eqxx. - move: (cat_take_drop k l3) => eq2. - have l3k: l3`_k = (drop k l3)`_0 by rewrite - {1} eq2 nth_cat st' ltnn subnn. - have l3knz: l3`_k != 0 by rewrite /l3 /k - e4. - have [v eq6]: exists v, (drop k l3) = l3`_k:: v. - move:l3knz; rewrite l3k ;case (drop k l3); last by move => a b _; exists b. - by rewrite eqxx. - have [u eq7]: exists u, (take k l3) = l3`_0:: u. - move: st'; rewrite -{3} eq2; case (take k l3). - by move => /= kz; move: ov; rewrite -kz ltNge sqr_ge0. - by move => a b _; exists b. - rewrite -eq2 eq6 schange_cat // eq7 cat_cons. - by move: (schange_odd1 u ov); set w :=schange _; case w. -have ncat: forall l1 l2 b, (l1++l2)`_( (size l1) +b) = l2`_b. - by move=> l1 l2 b; rewrite nth_cat addKn -ltn_subRL subnn. -move => i s sil ha hb. -rewrite {1} /schange sil /=; move: sil ha hb. -move /schangei_snn => [l1 [a [l2 [->pa pb pc pd]]]] ha hb. -have he: (l1 ++ a :: l2)`_i = a by rewrite nth_cat pb ltnn subnn. -have skm: forall k, (l1 ++ a :: l2)`_(k + i) = (a::l2)`_k. - by move => k; rewrite addnC pb ncat. -have hc: a * l'`_i < 0 by rewrite -he;apply: ha; rewrite mem_head. -have[l2a [l2b [l2v sl]]]: exists l2a l2b, l2a ++ l2b = l' /\ size l2a = i. - exists (take i l'), (drop i l'); split; first by exact: cat_take_drop. - apply: size_takel; case /orP:(leq_total i (size l')) => //. - by move/(nth_default 0) => h; move: hc; rewrite h mulr0 ltxx. -move: (hc); rewrite -l2v nth_cat -sl ltnn subnn => hc'. -apply: (leq_trans _ (rec0 l2a l2b (proj2 (product_neg hc')))). -have sv: [seq (z + i)%N | z <- SIA l2 1 a] = s by rewrite pb -pd -schangei_addm. -have: forall k, k \in (SIA l2 1 a) -> (a::l2)`_(k-0)%N * l2b`_(k-0%N) < 0. - move => k ka; rewrite - skm subn0. - have ->: l2b`_k = l'`_(k+i) by rewrite -l2v - sl addnC ncat. - by apply: ha;rewrite inE - sv (mem_map (@addIn i)) ka orbT. -have: 0 < (a :: l2)`_((last 0%N (SIA l2 1 a)) -0) * l2b`_(size l2).+1. - move: hb; rewrite -sv /= (last_map (fun z=> (z + i)%N) (SIA l2 1 a) 0%N). - by rewrite subn0 skm - l2v size_cat -pb - sl ncat. -rewrite - sv size_map. -clear he sv skm pb pc pd ha sl s hb l2v hc l2a he l1 l l' i. -move: {2 3 4 5} (SIA l2 1 a) pa (erefl (SIA l2 1 a)) hc'. -rewrite - (addn0 1%N); move: {2 4 5 6 7} 0%N. -move => n s; move: s a n l2 l2b; elim. - move => a n l l' _ anz pnz;set j := (size l).+1 %N. - rewrite /last subnn {1}/nth mulrC ; move => lt2 _. - move:(schange_simpl1 pnz lt2);apply: rec1. -move => i s Hrec a n l l' anz. -move /(schangei_recc anz)=> [l1 [b [l2 [-> pa pb pc [pd pe]]]]]. -move => qa qb qc /=. -have imn: (i - n = (size l1).+1) %N by rewrite pd addnAC add1n addnK. -have: (i\in i :: s) by rewrite mem_head. -move /qc; rewrite imn -cat1s catA nth_cat subnn ltnn - imn => e1. -set ni := (i - n )%N. -move: (cat_take_drop ni l'). -set l1' := take ni l'; set l2' := drop ni l' => e2. -have e3: size l1' = ni. - move: e1;rewrite size_take; case (leqP (size l') ni) => //. - by move/(nth_default 0) => ->; rewrite mulr0 ltxx. -move: (schange_simpl2 qa pa); rewrite mulrC => e4. -move: (schange_simpl1 e1 e4) => e5. -move: (proj2 (product_neg e5)); set w := l'`_ni => wnz. -have [u l2v]: exists u, l2' = w::u. - move: wnz;rewrite /w - e2 nth_cat e3 ltnn subnn. - case l2'; [ by rewrite eqxx | by move => a1 b1 _; exists b1]. -move: (schange_cat l1' u wnz); rewrite - l2v e2 => ->. -suff: ((size s) < schange l2')%N. - set l1'' := (l1' ++ [:: w]). - have : l1''`_0 * l1''`_ni < 0. - move: e5; rewrite -e2 l2v /l1'' !nth_cat e3 ltnn subnn; case i => //. - by move/rec1 => e6 e7; move: (leq_add e6 e7); rewrite add1n. -clear u l2v. -have r0: b * l2'`_0 < 0 by move: e1; rewrite - e2 nth_cat e3 ltnn subnn. -move: pe; rewrite -pd - add1n => r1. -have r2 : (forall k, - k \in s -> (b :: l2)`_(k - i) * l2'`_(k - i) < 0). - move => k ks; have: k \in i::s by rewrite inE ks orbT. - move: ks; rewrite -{1} r1 schangei_addm; move /mapP => [k' k'v kv]. - have ->: (k - i)%N = k' by rewrite kv addnK. - move/ qc; rewrite - e2 - cat1s catA. - have ->: (k - n = k' + (size l1).+1)%N. - by rewrite kv pd addnAC add1n addnA addnK. - by rewrite addnC ncat -imn -/ni -e3 ncat. -have r3: 0 < (b :: l2)`_(last i s - i) * l2'`_(size l2).+1. - move:qb; rewrite - e2 size_cat - addSn - imn -/ni -e3 ncat. - suff: ((last n (i :: s) - n) = ni + (last i s - i)) %N. - by move => ->; rewrite /ni imn - cat1s catA ncat. - have lni: (n<=i) %N by rewrite pd addnAC leq_addl. - rewrite -r1 schangei_addm; case (SIA l2 1 b); first by rewrite /= subnn addn0. - move => n0 l0 /=; set la := last _ _. - have eq1: (i <= la)%N. - by rewrite /la (last_map (fun z=> (z + i)%N)) leq_addl. - by rewrite - {1} (subnK eq1) - (addnBA _ lni) addnC. -exact: (Hrec b i l2 l2' pb r1 r0 r3 r2). -Qed. - -Lemma pol_mul_cs (p: {poly R}) (x: R): - p !=0 -> x > 0 -> ( (schange p) < (schange (p * ('X - x%:P))%R))%N. -Proof. -move => pnz xn. -set q := _ * _. -have spp: size p = (size p).-1.+1. - by move: pnz; rewrite -size_poly_eq0; case sz:(size p). -have lcpnz: lead_coef p != 0 by rewrite lead_coef_eq0. -set s := (schange_index p). -suff: (forall k, k \in s -> p`_k * q`_k < 0) /\ - 0 < p`_(last 0%N s) * q`_(size p). - by move => [pa pb];apply: schange_monotone. -have -> : q`_(size p) = lead_coef p. - move: (monicXsubC x) => mc; rewrite- (lead_coef_Mmonic p mc) lead_coefE. - by rewrite (size_Mmonic pnz mc) size_XsubC addn2. -have lpp: lead_coef p \in polyseq p by apply: mem_nth; rewrite {2} spp. -have [heads [lasts sv]]: exists a b, s = rcons a b. - move: (eq_refl s); rewrite {1}/s; case s. - by move /eqP /schangei0 => ap; move:lcpnz; move /(allP ap): lpp => ->. - by move => n l _; rewrite lastI; exists (belast n l), (last n l). -move:(schange_index_tail sv) => [l1 [a [l2 [pv sl1 pn alz]]]]. -have ->: last 0%N s = lasts by rewrite sv last_rcons. -have: lead_coef p = last 0 p by rewrite (last_nth 0) spp. -rewrite {1 3} pv last_cat last_cons; move: alz. -case l2; last first. - move => b l az /= lpv; move: lcpnz. - have: lead_coef p \in (b :: l) by rewrite lpv mem_last. - by move /(allP az) => ->. -move => _ /= ->; split; last first. - move: pn; rewrite pv - cat1s catA mulrC (nth_cat 0 (l1 ++ [:: a])). - by rewrite size_cat addn1 ltnS sl1. -clear heads lasts sl1 a l2 pv sl1 pn sv. -move => k ks. -move: (schange_index_correct ks) => [eq1 eq2]. -have rhsp: 0 < p`_k * (p`_k * x). - by rewrite mulrA (pmulr_lgt0 _ xn) lt0r sqr_ge0 sqrf_eq0 eq1. -rewrite /q mulrBr coefB coefMC mulrBr subr_lt0 coefMX (le_lt_trans _ rhsp) //. -by move: eq2; case k. -Qed. - -End SignChange. - -Section DescOnOrderedRing. -Variable R :realDomainType. - -(** The definitions *) - -Definition pol_increasing (p : {poly R}) := {homo (horner p): x y / x <= y}. - -Definition slope_bounded (x k: R) (f: R -> R):= - forall y z, x <= y <= z -> k * (z - y) <= f z - f y. - -(* on a< t = -k *) -Definition slope_bounded2 (a b k: R) (f: R -> R):= - forall y z, a <= y -> y <= z -> z <= b -> k * (z - y) <= f y - f z. - -Definition neg_in_interval1 (a b: R) (f: R -> R) := - forall z, a f z < 0. -Definition neg_in_interval2 (a b: R) (f: R -> R) := - forall z, a f z < 0. - -Definition pos_in_interval (a b: R) (f: R -> R) := - forall z, a 0 < f z. - - -Definition le_below_x (x: R) (f: R -> R) := - (forall y, 0 <= y -> y <= x -> f y <= f x). - -(* Here inv stands for "invariant" *) - -Definition inv (p: {poly R}) := - forall epsilon, 0 < epsilon -> - { x | - [/\ (le_below_x x (horner p)), - {in <=%R x &, pol_increasing p} & - (0 < x) && (x * p.[x] <= epsilon)] }. - -Definition inv2 (p : {poly R}) := - forall epsilon, 0 < epsilon -> - {x | - [/\ (le_below_x x (horner p)), - {in <=%R x &, pol_increasing p} & - [&& 0 < x, 0 < p.[x] & x * p.[x] <= epsilon]] }. - - -(* initial definition said nothing on b *) -Definition one_root1 (p : {poly R}) (a b : R) := - exists c d k, - [/\ [&& a < c, c < d, d < b & 0 < k], - (pos_in_interval a c (horner p)), - (neg_in_interval1 d b (horner p)) & - (slope_bounded2 c d k (horner p))]. - -Definition one_root2 (p : {poly R}) (a : R) := - { ck | - [/\ (a < ck.1) && (0 < ck.2), - (neg_in_interval2 a ck.1 (horner p)) & - (slope_bounded ck.1 ck.2 (horner p))] }. - -(** ** Basic properties *) - -Lemma slope_product_x (f : R -> R) x k: - 0 <= x -> 0 <= k -> - slope_bounded x k f -> - forall y z, x <= y <= z -> - (x * k + f y) * (z - y) <= z * f z - y * f y. -Proof. -rewrite /slope_bounded; move =>x0 kf0 incf y z /andP [xy yz]. -rewrite -[z * _] (addrNK (z * f y)) -mulrBr -addrA -mulrBl mulrDl (mulrC (f y)). -move: (le_trans xy yz) => xz. -rewrite lerD2r; apply: le_trans (_ : z * (k * (z - y)) <= _). - by rewrite - mulrA ler_wpM2r // mulr_ge0 // subr_ge0. -by rewrite ler_wpM2l ? incf ?xy ? yz//;apply:(le_trans x0). -Qed. - -(* Note that {poly R} is automatically converted into (seq R) *) - -Lemma all_pos_positive (p : {poly R}) x: - all_ge0 p -> 0 <= x -> p.[x] >= 0. -Proof. -move=> h x0; rewrite horner_coef. -apply: sumr_ge0 => [] [i his _] /=. -apply: mulr_ge0; rewrite ?exprn_ge0 //; apply: (allP h); exact: mem_nth. -Qed. - - -Lemma all_pos_increasing (p : {poly R}): - all_ge0 p -> {in <=%R 0 &, pol_increasing p}. -Proof. -move=> posp x y le0x le0y lexy; rewrite !horner_coef. -apply: ler_sum => [] [i ihs] /= _. -apply: ler_wpM2l => //; first by apply: (allP posp); exact: mem_nth. -by apply: lerXn2r. -Qed. - -Lemma one_root1_uniq p a b: one_root1 p a b -> - uniqueness (fun z => a < z < b /\ root p z). -Proof. -move => [c [d [k [leqs pa nb dab]]]]. -move => z1 z2 [/andP [z1a z1b] /eqP rz1] [/andP [z2a z2b] /eqP rz2]. -move: leqs => /and4P [ac cd db k0]. -case: (lerP z1 c) => z1c. - have aux:(a < z1 <= c) by rewrite z1a z1c. - by move: (pa z1 aux); rewrite rz1 ltxx. -case: (lerP z2 c) => z2c. - have aux:(a < z2 <= c) by rewrite z2a z2c. - by move: (pa z2 aux); rewrite rz2 ltxx. -case: (lerP z1 d) => z1d; last first. - have aux: (d < z1 < b) by rewrite z1d z1b. - by move: (nb z1 aux); rewrite rz1 ltxx. -case: (lerP z2 d) => z2d; last first. - have aux: (d < z2 < b) by rewrite z2d z2b. - by move: (nb z2 aux); rewrite rz2 ltxx. -case /orP: (le_total z1 z2) => cp. - apply/eqP; rewrite eq_le; apply/andP; split => //. - move: (dab _ _ (ltW z1c) cp z2d). - by rewrite rz1 rz2 addrN (pmulr_rle0 _ k0) subr_le0. -move: (dab _ _ (ltW z2c) cp z1d). -rewrite rz1 rz2 addrN (pmulr_rle0 _ k0) subr_le0. -move=> z1z2. -by apply/eqP; rewrite eq_le cp z1z2. -Qed. - -Lemma one_root2_uniq p a: one_root2 p a -> - uniqueness (fun z => a < z /\ root p z). -Proof. -move => [pp]; set c:=pp.1; set k := pp.2. -move => [/andP [ac kp] nii slk]. -move => z1 z2 [az1 /eqP rz1][az2 /eqP rz2]. -case: (lerP z1 c) => z1c. - have aux: (a < z1 <= c) by rewrite az1 z1c. - by move: (nii _ aux); rewrite rz1 ltxx. -case: (lerP z2 c) => z2c. - have aux: (a < z2 <= c) by rewrite az2 z2c. - by move: (nii _ aux); rewrite rz2 ltxx. -case /orP: (le_total z1 z2) => cp; apply/eqP; rewrite eq_le; apply/andP; split => //. - have aux:(c <= z1 <= z2) by rewrite (ltW z1c) cp. - move: (slk _ _ aux). - by rewrite rz1 rz2 addrN (pmulr_rle0 _ kp) subr_le0. -have aux:(c <= z2 <= z1) by rewrite (ltW z2c) cp. -move: (slk _ _ aux). -by rewrite rz1 rz2 addrN (pmulr_rle0 _ kp) subr_le0. -Qed. - -End DescOnOrderedRing. - -Section DescOnOrderedField. - -Variable R :realFieldType. -Implicit Type (p: {poly R}). - -Lemma all_pos_inv p: all_ge0 p -> inv p. -Proof. -move=> posp eps peps. -move: (pol_cont ('X * p) 0 peps) => [e ep le]. -have he := (half_gt0 ep). -have hew:= (ltW he). -exists (half e); split. - by move=> y y0 ye; apply: all_pos_increasing. - by move=> y y1 h h1; apply: all_pos_increasing => //; apply:(le_trans hew). -have -> : half e* p.[half e] = ('X * p).[half e] - ('X * p).[0]. - by rewrite !hornerM !hornerX mul0r subr0. -have le1: `|half e - 0| < e by rewrite subr0 ger0_norm // half_ltx. -by move /ler_normlP:(ltW(le _ le1)) => [_ ->]; rewrite he. -Qed. - -Lemma one_root2_shift p a b: - one_root2 (p \shift a) b -> one_root2 p (a + b). -Proof. -move=> [ck [/andP [x1a kp] neg sl]]. -exists (a + ck.1,ck.2); split. - by rewrite ltrD2l x1a kp. - move=> x /= abxax1; rewrite -(addrNK a x) - horner_shift_poly. - by rewrite neg // ltrBrDl lerBlDl. -move=> x y /= axy. -have aux: y - x = y - a - (x - a). - by rewrite opprD addrAC -!addrA opprK addrN addr0. -rewrite -{2} (addrNK a x) -{2} (addrNK a y) -!(horner_shift_poly a _) aux. -by apply: sl; rewrite ?lerD2r // lerBrDr addrC. -Qed. - -Lemma one_root1_shift p a b c: - one_root1 (shift_poly c p) a b -> - one_root1 p (c + a) (c + b). -Proof. -move=> [x1 [x2 [k [/and4P [ax1 x1x2 x2b kp] pos neg sl]]]]. -exists (c + x1); exists (c + x2); exists k. -rewrite !ltrD2l; split => //; first by apply /and4P. - move=> x cp; rewrite - (addrNK c x). - rewrite -horner_shift_poly pos ? lerBDl ? ltrBDl //. - move=> x cp; rewrite - (addrNK c x). - by rewrite -horner_shift_poly neg // ltrBrDl ltrBlDl. -move=> x y cx1x xy ycx2. -have aux: y - x = y - c - (x - c). - by rewrite [x + _]addrC opprD opprK addrA addrNK. -rewrite -{2} (addrNK c x) -{2} (addrNK c y) aux -!(horner_shift_poly c _). -by rewrite sl ?lerD2r // ?lerBrDr? lerBlDr // addrC. -Qed. - -Lemma one_root1_scale p a b c: - 0 < c -> one_root1 (p \scale c) a b -> - one_root1 p (c * a) (c * b). -Proof. -move=> cp [x1 [x2 [k [/and4P [ax1 x1x2 x2b kp] pos neg sl]]]]. -exists (c * x1); exists (c * x2); exists (k / c). -have tc : 0 < c^-1 by rewrite invr_gt0. -rewrite !(ltr_pM2l cp). -have t: forall z, z = c * (z / c). - by move=> z; rewrite [c * _]mulrC mulfVK //;move: cp;rewrite lt0r => /andP []. -split => //; first by apply/and4P; split => //; apply:mulr_gt0. - move=> x cpp; rewrite (t x) - horner_scaleX_poly; apply: pos. - by rewrite ltr_pdivlMr // mulrC ler_pdivrMr //(mulrC x1). - move=> x cpp. - rewrite (t x) -horner_scaleX_poly neg //. - by rewrite ltr_pdivlMr // mulrC ltr_pdivrMr // (mulrC b). -move=> x y cx1x xy ycx2; rewrite -mulrA mulrDr mulrN ![c^-1 * _]mulrC - {2}(t x) {2}(t y) -!(horner_scaleX_poly _ p); apply: sl. - by rewrite ler_pdivlMr // mulrC. - by rewrite ler_wpM2r // ltW. -by rewrite ler_pdivrMr // mulrC. -Qed. - -End DescOnOrderedField. - - -(** ** Case of archifields *) - -Section DescOnArchiField. - -Variable R :archiFieldType. -Lemma desc_l4 (p: {poly R}) : alternate_1 p -> inv2 p. -Proof. -move: p;elim/poly_ind => [| p a ih]; first by rewrite/alternate_1 polyseq0. -have desc_c: alternate_1 (a%:P) -> inv2 (a%:P). - rewrite polyseqC;case: (a==0) => //=; case ha: (0< a) => // _. - move=> eps eps0; exists (eps / a); split. - by move => y _ _; rewrite !hornerC. - by move => y1 y2 _ _ _ ; rewrite !hornerC. - by rewrite hornerC ha divr_gt0 //= (divrK (unitf_gt0 ha)). -case sp : (nilp p). - by move: sp; rewrite nil_poly; move /eqP => ->; rewrite mul0r add0r. -rewrite -{1} cons_poly_def polyseq_cons sp /=. -case: (ltrgtP 0 a) => ha. -(* case a > 0 *) -move => haposp eps eps0; rewrite /inv2 /=. - have : all_ge0 (p * 'X + a%:P). - by rewrite -cons_poly_def polyseq_cons sp /= ltW. - move/all_pos_inv/(_ eps eps0)=> [x [h1x h2x /andP[h3x h4x]]]; exists x. - have xp:= ltW h3x. - split => //; rewrite h3x h4x !hornerE ltr_pwDr // mulr_ge0 //. - by rewrite all_pos_positive. -(* case a < 0 *) -rewrite -oppr_gt0 in ha. - set q := (p * 'X + a%:P). - move=> il;move: (ih il _ ((half_gt0 ha)))=> [x [H1 H2 /and3P [xp xpx xe]]]. - move: (le_lt_trans xe (half_ltx ha)) => xe'. - have qxn : q.[x] < 0 by rewrite !hornerE mulrC -(opprK a) subr_lt0. - move: (maxS x (-a/p.[x])) => /andP []; set y := (_ + _) => yx val. - have yx':= ltW yx. - have ppos: forall t, x <= t -> 0 < p.[t]. - move => t xt;exact (lt_le_trans xpx (H2 _ _ (lexx x) xt xt)). - have qsincr: forall t d, x <= t -> 0 < d -> q.[t] < q.[t+d]. - move => t d xt dp; rewrite !hornerE. - set w := _ + _. - have aux: t <= t+d by rewrite - {1}(addr0 t) lerD2l ltW. - have xtd:= (le_trans xt aux). - rewrite mulrDr -addrAC addrC ltr_pwDl ?(mulr_gt0 (ppos _ xtd) dp)//. - rewrite !lerD2r (ler_pM2r (lt_le_trans xp xt)). - by apply:H2 => //. - have qincr: forall t, x<=t -> {in <=%R t &, pol_increasing q}. - move => t xt u v ut vt; rewrite le_eqVlt; case /orP => uv. - by move /eqP:uv => ->. - rewrite ltW // - (addNKr u v); apply: (qsincr _ _(le_trans xt ut)). - by rewrite addrC subr_gt0. - move: (H2 _ _ (lexx x) yx' yx') => lepxpy. - have yge0: 0 <= y by rewrite ltW // (lt_le_trans xp yx'). - have posval : 0 <= q.[y]. - rewrite !hornerE -(addNr a) /= lerD2r /=. - apply: (@le_trans _ _ (p.[x] * y)); last by rewrite ler_wpM2r. - rewrite // mulrC - ler_pdivrMr // ltW //. - set r := ('X * q). - have negval' : r.[x] < 0 by rewrite 2!hornerE pmulr_rlt0. - have posval' : 0 <= r.[y] by rewrite 2! hornerE mulr_ge0. - move=> epsilon Hepsilon /=. - move: (half_gt0 Hepsilon) => he1. - move: (constructive_ivt yx negval' posval' he1) => [ppr]. - rewrite (surjective_pairing ppr); set u:=ppr.1;set v := ppr.2. - move /and5P => [/and3P [_ _ smallv] /and3P[xd dv v'y] _ posv _]. - have {xd dv} xv : x < v by apply: le_lt_trans xd dv. - have pv : 0 < v by apply: lt_trans xv. - move: posv; rewrite 2! hornerE -{1} (mulr0 v) (ler_pM2l pv) => posv. - move: (pol_cont r v he1) => [d' dp' pd']. - pose d := half d'. - have dp : d > 0 by rewrite half_gt0. - have dd' : d < d' by apply: half_ltx. - have vvd : v < v + d by rewrite ltrDl /=. - have xvd : x < v + d by apply: lt_trans vvd. - have lvd : 0 < p.[v + d] by apply: ppos; exact: ltW. - move => {y yx val yx' posval posval' v'y lepxpy yge0}. - have pa: le_below_x (v + d) (horner q). - move => y y0 yvd; rewrite !hornerE lerD2r /=. - case cmp: (y <= x); last first. - have cmp': x <= y by rewrite ltW // ltNge cmp. - apply: le_trans (_ : p.[v + d] * y <= _). - by apply: ler_wpM2r => //; apply: H2 => //;apply: (le_trans cmp'). - by rewrite ler_wpM2l // ltW. - apply: le_trans (_ : p.[x] * y <= _). - by rewrite ler_wpM2r //; apply: H1. - apply: le_trans (_ : p.[x] * (v + d) <= _); last first. - rewrite ler_wpM2r //; first exact: le_trans yvd. - rewrite H2 //; first (by apply: (lexx x)); by apply:ltW. - by rewrite ler_wpM2l // ltW. - exists (v + d). - rewrite (le_lt_trans posv (qsincr _ _ (ltW xv) dp)) (lt_trans pv vvd). - split => //=; first by apply: qincr; apply: ltW. - rewrite - (double_half epsilon). - apply: le_trans (_ : ((half epsilon) + r.[v+d] -r.[v]) <= _). - rewrite [ half epsilon + _] addrC -addrA. - rewrite [r.[v + d]] hornerE hornerX lerDl subr_ge0 //. - rewrite -!addrA lerD2l. - have aux:`|(v+d) - v| < d' by rewrite (addrC v) addrK ger0_norm// ltW. - by move: (ltW (pd' _ aux)) => /ler_normlP [_]. -(* case a = 0 *) -move => halt1 eps eps0. -move: (ih halt1 _ ltr01) => [x [plx pmonx /and3P [gx0 gpx0 lpx1]]]. -have e1px : 0 < eps / x by apply: mulr_gt0=> //=; rewrite invr_gt0. -move: (ih halt1 _ e1px) => [v [plv pmonv /and3P [gv0 gpv0 lpve]]]. -rewrite -ha addr0. -have aux: forall w, 0 <=w -> 0 <= p.[w] -> {in <=%R w &, pol_increasing p} -> - {in <=%R w &, pol_increasing ((p * 'X))}. - move => w wz pwz H s t sw tw st; rewrite !hornerE. - move: (H _ _ sw tw st) (le_trans pwz (H _ _ (lexx w) sw sw)) => pa pb. - by apply:(ler_pM pb (le_trans wz sw) pa st). -set w:= (Num.min x v); exists w. -have wc: w = x \/ w = v. - by rewrite /w /minr; case: ifPn; [left|right]. -have wz: 0 < w by case wc => ->. -have pw0: 0 < p.[w] by case wc => ->. -rewrite wz 3! hornerE (pmulr_lgt0 _ wz) pw0. -split. - move => t tp tw; rewrite !hornerE mulrC (mulrC _ w). - apply: (pmul2w1 tp (ltW pw0) tw). - move: tp tw;case wc=> ->; [apply: plx | apply: plv]. - by apply: aux; [apply: ltW | by apply: ltW| case wc => ->]. -move: lpve; rewrite (ler_pdivlMr _ _ gx0) => lpve. -case /orP:(le_total x v)=> xv; - rewrite /w/=. - move/min_idPr : (xv); rewrite minC => ->. - apply: le_trans lpve; rewrite mulrA. - rewrite (ler_pM2r gx0);apply: (ler_pM (ltW gx0) (ltW gpx0) xv). - exact:(pmonx _ _ (lexx x) xv xv). -move/min_idPr : (xv) => ->. -apply: le_trans lpve. -rewrite mulrA. -by rewrite (ler_pM2l (mulr_gt0 gv0 gpv0) v x). -Qed. - -Lemma desc (p: {poly R}): alternate p -> one_root2 p 0. -Proof. -move: p; elim/poly_ind => [| p a IHl]; first by rewrite polyseq0. -rewrite -cons_poly_def polyseq_cons. -case sl: (nilp p) => /=. - by rewrite polyseqC; case: (a == 0) => //=;rewrite ! if_same. -case: (ltrP a 0) => ha alt1. - rewrite - oppr_gt0 in ha. - move: (desc_l4 alt1 (half_gt0 ha)) => [x [psub pmon /and3P [xp pxp pxa1]]]. - move: (le_lt_trans pxa1 (half_ltx ha)) => pxa2. - exists (x, p.[x]); simpl; rewrite xp pxp; split => //. - move => y /andP [posy yx]. - move: (ltW posy) => posy'. - rewrite horner_cons -(opprK a) subr_lt0; apply: le_lt_trans pxa2. - rewrite mulrC; apply:(pmul2w1 posy' (ltW pxp) yx (psub _ posy' yx)). - move => y z xyz;rewrite !horner_cons opprD addrCA addrK. - rewrite [_ + _ * _]addrC [_ * z]mulrC [_ * y]mulrC. - have slp:slope_bounded x 0 (horner p). - move => t u /andP[xt tu];rewrite mul0r subr_gte0 pmon //. - exact (le_trans xt tu). - move:(slope_product_x (ltW xp) (lexx 0) slp xyz). - move/andP :xyz => [xy yz]. - rewrite mulr0 add0r; apply: le_trans. - by apply: (ler_wpM2r _ (pmon _ _ (lexx x) xy xy)); rewrite subr_ge0. -move: alt1; case a0 : (a == 0) => // alt1; move: (eqP a0) => a00. -clear ha a0. -move: (IHl alt1) => [v1k []] {IHl}. -set v1 := v1k.1; set k:= v1k.2; simpl => /andP[v1pos kpos] low incr. -have negval : (p.[v1] < 0) by apply: low; rewrite ?lexx v1pos. -set k':= half (k * v1). -have posk' : 0 < k' by apply: half_gt0; apply: mulr_gt0. -set u := (- p.[v1]) / k. -move: (maxS 0 u); set v:= Num.max 0 _ => /andP [pa pb]. -set v2:= v1 + v +1. -have v0: 0 <= v by rewrite le_max lexx. -have v1v2: v1 < v2 by rewrite /v2 - addrA (ltrDl v1). -have pos1:0 <= p.[v1 + v]. - move: (kpos); rewrite lt0r => /andP [ kne0 _]. - move: kpos; rewrite - invr_gt0 => kpos. - rewrite /v; have [caf|caf] := leP u 0. - by rewrite addr0 - oppr_le0 - (pmulr_lle0 _ kpos). - case/orP:(le_total u 0); [ | move => up]. - by rewrite leNgt caf. - have aa: v1 <= v1 <= v1 + u by rewrite lexx lerDl. - rewrite -(lerDr (- p.[v1]));apply: le_trans (incr _ _ aa). - by rewrite (addrC v1) addrK /u (mulrC _ (k^-1)) mulVKf //. -have pos : 0 < p.[v2]. - have hh: v1 <= v1 + v <= v1 + v + 1 by rewrite !lerDl v0 ler01. - apply: (le_lt_trans pos1);rewrite -subr_gt0. - by apply: (lt_le_trans _ (incr _ _ hh)); rewrite addrAC addrN add0r mulr1. -clear v0 pos1 pa pb. -move: (constructive_ivt v1v2 negval (ltW pos) posk') => [x12]. -rewrite (surjective_pairing x12); set x1:=x12.1;set x2 := x12.2. -move /and5P => [/and3P [x1close _ _] /and3P[v1x1 _ _] px1neg _ _]. -have x1pos : 0 < x1 by apply: lt_le_trans v1x1. -have Plow : forall x, 0 < x -> x <= x1 -> x * p.[x] < 0. - move=> x xpos xx1; rewrite (pmulr_rlt0 _ xpos). - case: (ltrP x v1)=> xv1; first by apply: low=> //; rewrite xpos ltW. - apply: le_lt_trans px1neg. - move: xx1; rewrite le_eqVlt; move/orP => [xx1 | xlx1]; - first by rewrite (eqP xx1) lexx. - have aux : v1 <= x <= x1 by rewrite xv1 ltW. - rewrite -subr_gte0; move: (incr _ _ aux); apply: le_trans. - by apply: ltW; apply: mulr_gt0 => //; rewrite subr_gt0. -exists (x1,k'); simpl; rewrite x1pos posk'; split => //. - by move=> x /andP[x0 xx1]; rewrite horner_cons a00 addr0 mulrC;apply : Plow. -move => x y /andP[x1x xy]. -rewrite ! horner_cons a00 !addr0 (mulrC _ x) (mulrC _ y). -have: (v1 * k + p.[x]) * (y - x) <= y * p.[y] - x * p.[x]. - apply:(slope_product_x (ltW v1pos) (ltW kpos) incr). - by rewrite xy (le_trans v1x1 x1x). -apply: le_trans; rewrite ler_wpM2r //; first by rewrite subr_ge0. -rewrite mulrC - (double_half (k * v1 )) -/k' - addrA lerDl. -rewrite - (opprK k') addrC subr_gte0 (le_trans x1close) // -subr_gte0. -have: k * (x - x1) <= p.[x] - p.[x1] by apply: incr =>//; rewrite x1x v1x1. -by apply : le_trans; apply: mulr_ge0 => //; rewrite ?(ltW kpos) ?subr_ge0. -Qed. - -Lemma one_root_reciprocal (p: {poly R}) deg : - (0 < size p)%N -> - (size p <= deg.+1)%N -> - one_root2 (recip deg p) 1 -> one_root1 p 0 1. -Proof. -move=> s0 sz [x1k [/andP []]]. -set x1 := x1k.1; set k := x1k.2; set q := (recip deg p). -move => x1gt1 kp neg sl. -have x10 : 0 < x1 by apply: lt_trans x1gt1; exact: ltr01. -set y' := x1 - q.[x1] / k. -have nx1 : q.[x1] < 0 by rewrite neg //x1gt1 lexx. -have knz: k != 0 by move: kp; rewrite lt0r; case /andP =>[]. -have y'1: x1 < y' by rewrite /y' ltrDl oppr_gt0 pmulr_llt0 // ?invr_gt0. -have y'pos : 0 <= q.[y']. - have aux: x1 <= x1 <= y' by rewrite (lexx x1) (ltW y'1). - rewrite -(lerD2r (- q.[x1])) add0r; apply: le_trans (sl _ _ aux). - by rewrite /y' (addrC x1) addrK mulrN mulrC mulfVK. -move: (@diff_xn_ub R deg 1); set u := _ *+ _; move => up. -set u':= Num.max 1 u. -have uu': u <= u' by rewrite le_max lexx orbT. -have u1: 1 <= u' by rewrite le_max lexx. -have u'0 : 0 < u' by rewrite (lt_le_trans ltr01). -have divu_ltr : forall x, 0 <= x -> x / u' <= x. - move => x x0; rewrite ler_pdivrMr // ler_peMr //. -have y'0: 0 < y' by apply: lt_trans y'1. -pose y := y' + 1. -have y'y : y' < y by rewrite /y ltrDl. -have y1 : x1 < y by apply: lt_trans y'1 _. -have ypos : 0 < q.[y]. - have aux: x1 <= y' <= y by rewrite (ltW y'1) (ltW y'y). - rewrite (le_lt_trans y'pos) // -subr_gte0. - by apply: lt_le_trans (sl _ _ aux); rewrite mulr_gt0 // subr_gt0. -have y0: 0 < y by apply: lt_trans y'y. -pose k' := half ((k * x1 ^+ 2 * y ^- 1 ^+ deg)). -have k'p : 0 < k'. - apply: half_gt0; rewrite mulr_gt0 //; first by rewrite mulr_gt0 // exprn_gt0. - rewrite exprn_gt0 // invr_gt0 //. -pose e := k' / u'. -have ep: 0 < e by rewrite /e; apply: mulr_gt0 => //; rewrite invr_gt0. -pose e1 := half e. -have e1p : e1 > 0 by apply: half_gt0. -have e1e : e1 < e by apply: half_ltx. -move: (constructive_ivt y'1 nx1 y'pos e1p)=> [pv]. -rewrite (surjective_pairing pv); set a:=pv.1;set b' := pv.2. -move=> /and5P[/and3P [cla _ clb'] /and3P[x1a ab b'y'] nega posb' _]. -move: (pol_lip q (z:=y)); set c := (norm_pol q^`()).[y] => cp. -have cp0 : 0 < c. - move: (lt_le_trans nega posb'); rewrite - subr_gt0 => dp. - move: (ltW (le_lt_trans b'y' y'y)) => pb. - move: y0; rewrite -(oppr_lt0 y) => yn0. - move: (ltW (lt_trans yn0 (lt_le_trans x10 x1a))) => pa. - move: (cp _ _ pa (ltW ab) pb); rewrite (gtr0_norm dp) => dp'. - by move: (lt_le_trans dp dp'); rewrite pmulr_lgt0 // subr_gt0. -set b := Num.min y (b' +(half e1)/c). -have blty: b <= y by rewrite /b ge_min lexx. -have b'b: b' < b. - rewrite lt_min (le_lt_trans b'y' y'y) /= - ltrBlDl addrN. - by rewrite (divr_gt0 (half_gt0 e1p) cp0). -have clb:c * (b - b') < e1. - apply: le_lt_trans (half_ltx e1p). - by rewrite -(ler_pdivlMl _ _ cp0) mulrC lerBlDl ge_min lexx orbT. -pose n := (size p).-1. -have a0 : 0 < a by apply: lt_le_trans x1a. -have b'0 : 0 < b' by apply: lt_trans ab. -have b0 : 0 < b by apply: lt_trans b'b. -have ibp: 0 < b^-1 by rewrite invr_gt0. -have inv_mono: forall x, 0 < x -> Num.sg (q.[x]) = Num.sg (p.[x^-1]). - move => x xp. - rewrite /q /recip. - rewrite hornerM (horner_reciprocal _ ( unitf_gt0 xp)) hornerXn. - rewrite !sgrM gtr0_sg ?mul1r //. - by rewrite gtr0_sg // ?mul1r // exprn_gt0. - by rewrite exprn_gt0. -rewrite /one_root1 /pos_in_interval /neg_in_interval1. -have res1:pos_in_interval 0 b^-1 (horner p). - move => x /andP[x0 xb]. - rewrite -[x]invrK -sgr_cp0 - inv_mono ?invr_gt0 // sgr_cp0. - rewrite (le_lt_trans posb') // -subr_gte0 /=. - have b'x : b' < x^-1. - by rewrite inv_comp// (le_lt_trans xb)// ltf_pV2. - have aa:x1 <= b' <= x^-1 by rewrite (ltW (le_lt_trans x1a ab)) (ltW b'x). - by apply:lt_le_trans (sl _ _ aa); rewrite mulr_gt0 // subr_gt0. -have res2: neg_in_interval1 a^-1 1 (horner p). - move => x /andP[a1x xlt1]. - have x0 : 0 < x by apply: lt_trans a1x; rewrite invr_gt0. - have xv0 : 0 < x^-1 by rewrite invr_gt0. - rewrite -[x]invrK -sgr_cp0 - inv_mono ?invr_gt0 // sgr_cp0. - have x1a0 : x^-1 < a by rewrite inv_compr. - case : (lerP x1 x^-1) => cmp; last first. - apply: neg => //;rewrite (inv_comp ltr01 x0) invr1. - by rewrite xlt1 (ltW cmp). - have aux: (x1 <= x^-1 <= a) by rewrite cmp (ltW x1a0). - apply: lt_trans nega; rewrite -subr_gte0. - apply: lt_le_trans (sl _ _ aux). - by rewrite mulr_gt0 // subr_gt0. -exists b^-1, a^-1, k'. -split => //. - rewrite k'p ibp ltf_pV2// (inv_compr ltr01 a0) invr1. - by rewrite (lt_trans ab b'b) (lt_le_trans x1gt1 x1a). -move => x z bvx xz zav. - rewrite le_eqVlt in xz; move/orP: xz => [xz | xz]. - by rewrite (eqP xz) !addrN mulr0 lexx. -have x0: 0 < x by apply: (lt_le_trans ibp bvx). -have z0 : 0 < z by apply: (lt_trans x0). -have lmrec : forall yy, 0 < yy -> p.[yy] = yy ^+ deg * q.[yy^-1]. - move => yy yy0. - rewrite hornerM horner_reciprocal1 ?unitf_gt0 // hornerXn exprVn mulrA. - case h : (size p == 1)%N. - rewrite (eqP h) !subSS !subn0 mulfV // expf_neq0 //. - by move: yy0; rewrite lt0r; case/andP. - have h' : size p = (size p).-2.+2. - case h'': (size p) => [ | [ | sp]] //. - by move: s0; rewrite h'' ltn0. - by move: h; rewrite h'' eqxx. - rewrite -expfB; last first. - rewrite h' subSS prednK; last by rewrite h'. - rewrite -{2}[deg]subn0 ltn_sub2l //. - by rewrite -ltnS (leq_trans _ sz) // h'. - by rewrite h'. - by rewrite h' !subSS subKn ?subn0 // -ltnS -h'. -rewrite (lmrec x x0) (lmrec z z0). -set s := deg. -set t1 := (x ^+ s - z ^+ s) * q.[x^-1]. -set t3 := q.[x^-1] - q.[z^-1]. -rewrite (_ : _ * _ - _ = t1 + t3 * z ^+ s); last first. - by rewrite /t1 !mulrDl !mulNr ![_.[_] *_]mulrC !addrA addrNK. -set t2 := t3 * _. -pose k1 := -k'; pose k2 := k' + k'. -have k2p : k2 = (k * x1 ^+ 2 * y ^-1 ^+ s) by apply: double_half. -rewrite (_ : k' = k1 + k2); last by rewrite /k1 /k2 addrA addNr add0r. -have xzi: z^-1 < x^-1 by rewrite ltf_pV2. -have pa : x1 <= z^-1. - by rewrite (le_trans x1a)// -(invrK a)// lef_pV2// posrE invr_gt0. -have pb: x1 <= x^-1 by rewrite (ltW (le_lt_trans pa xzi)). -have pc: 0 <= k * (x^-1 - z^-1) by apply: ltW;rewrite(mulr_gt0 kp) // subr_gt0. -have pdd:(x1 <= z^-1 <= x^-1) by rewrite pa (ltW xzi). -have pd:= (sl _ _ pdd). -have t3p:= le_trans pc pd. -have pe : 0 <= y^-1 <= z. - by rewrite invr_ge0 ltW //= (le_trans _ (ltW xz))// (le_trans _ bvx)// lef_pV2. -case /andP: (pow_monotone s pe) => _ hh. -have maj' : t3 * y^-1 ^+ s <= t3 * z^+ s by rewrite ler_wpM2l. -rewrite mulrDl; apply: lerD; last first. - apply: le_trans maj'; rewrite /t3 k2p mulrAC. - rewrite ler_pM2r; last by apply: exprn_gt0; rewrite invr_gt0. - apply: le_trans pd. - rewrite ![k * _]mulrC mulrAC ler_pM2r //. - have xn0 : (x != 0) by move: x0; rewrite lt0r; case /andP =>[]. - have zn0 : (z != 0) by move: z0; rewrite lt0r; case /andP =>[]. - have xVn0 : (x^-1 != 0) by move: x0; rewrite -invr_gt0 lt0r; case /andP =>[]. - rewrite -[x^-1](mulfK zn0) -(mulrC z) - (mulrA z _ _). - rewrite -{2}[z^-1](mulfK xn0) -(mulrA _ x _)(mulrCA _ x). - rewrite (mulrC z^-1) -mulrBl (mulrC (z - x)). - rewrite ler_pM2r /=; last by rewrite subr_gte0. - apply: le_trans (_ : x1 / z <= _); first rewrite ler_pM2l //=. - by rewrite ler_pM2r ?invr_gt0. -move:(ltW xz) => xz'. -have xzexp : (x ^+ s - z ^+ s) <= 0. - have aux: 0 <=x <= z by rewrite xz' ltW//. - by case /andP :(pow_monotone s aux)=> [_]; rewrite subr_le0. -have xzexp' : (z ^+ s - x ^+ s) >= 0 by rewrite subr_ge0 - subr_le0. -rewrite /t1 /k1 /k' {maj' t2 t3}. -case: (lerP 0 ( q.[x^-1])) => sign; last first. - apply: le_trans (_ : 0 <= _). - by rewrite mulNr lterNl oppr0 mulr_ge0 //?(ltW k'p)// subr_gte0 /= ltW. - by rewrite mulr_le0 // ltW. -rewrite mulNr lterNl -mulNr opprD opprK addrC. -have rpxe : q.[x^-1] <= e. - have bvx' : x^-1 <= b by rewrite -(invrK b)// lef_pV2. - apply: (@le_trans _ _ q.[b]). - have aux:(x1 <= x^-1 <= b) by rewrite pb bvx'. - rewrite -subr_ge0 /= ;apply: le_trans (sl _ _ aux). - rewrite mulr_ge0 ?subr_gte0 // ltW //. - rewrite -[_ _ b]addr0 -(addrN (q).[b']) addrA. - rewrite (addrC ( _ b)) -addrA -(double_half e) (lerD clb')//. - have yb: - y <= b' by apply: ltW; apply: lt_trans b'0; rewrite oppr_lt0. - move: (le_trans (cp b' b yb (ltW b'b) blty) (ltW clb)). - by move /ler_normlP => [_]. -apply: le_trans (_ : (z^+ s - x ^+ s) * e <= _). - by rewrite ler_wpM2l // ?subr_gte0. -have un0 : (u' != 0) by move: u'0; rewrite lt0r; case /andP =>[]. -rewrite [_ * e]mulrC; apply: le_trans (_ : e * (u' * (z - x)) <= _)=> /=. - apply: ler_wpM2l; first exact: ltW. - apply: (@le_trans _ _ (u * (z - x))). - have xm1: -1 <= x by exact: (ltW (lt_trans (ltrN10 R) x0)). - have a1 : 1 <= a by apply: (ltW (lt_le_trans x1gt1 x1a)). - rewrite - (ger0_norm xzexp'); apply: (up _ _ xm1 xz'). - apply: le_trans zav _. - by rewrite invr_le1 // unitf_gt0. - by rewrite ler_pM2r // subr_gte0. -rewrite mulrA ler_pM2r; last by rewrite subr_gte0. -rewrite /= /e divfK ?lterr //. -Qed. - -Lemma alternate_MX (p : {poly R}) k: - alternate ('X ^+ k * p) -> alternate p. -Proof. -elim: k => [ | k IH]; first by rewrite expr0 mul1r. -case h : (p == 0); first by rewrite (eqP h) mulr0. -rewrite mulrC polyseqMXn //=; last by rewrite h. -by rewrite ltxx eqxx -polyseqMXn ?h // mulrC. -Qed. - -Lemma Bernstein_isolate deg a b (l : {poly R}): a < b -> (0 < size l)%N -> - (size l <= deg.+1)%N -> alternate (Mobius deg a b l) -> one_root1 l a b. -Proof. -rewrite /Mobius /recip => altb s0 sz. -have sss : size ((l \shift a) \scale (b - a)) = size l. - rewrite size_scaleX; last by move: altb; rewrite -subr_gt0 lt0r; case/andP. - by rewrite size_comp_poly2 // size_XaddC. -rewrite sss => alt. -have -> : a = a + (a - a) by rewrite addrN addr0. -have -> : b = a + (b - a) by rewrite (addrC b) addNKr. -apply: one_root1_shift. -rewrite addrN -(mulr1 (b - a)) -(mulr0 (b - a)). -apply: one_root1_scale; first by rewrite subr_gt0. -move/desc: alt => alt'; move/one_root2_shift: alt'; rewrite addr0 -sss. -by apply: one_root_reciprocal; rewrite sss. -Qed. - -End DescOnArchiField. diff --git a/theories/desc1.v b/theories/desc1.v deleted file mode 100644 index f1724f0..0000000 --- a/theories/desc1.v +++ /dev/null @@ -1,697 +0,0 @@ -From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype order. -From mathcomp Require Import binomial bigop ssralg poly ssrnum ssrint rat. - -From mathcomp Require Import polydiv polyorder path interval polyrcf. - -(** Descates method 1 *) - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Import Order.Theory GRing.Theory Num.Theory Num.Def. -Local Open Scope ring_scope. -(** ** Sign changes *) - -Section SignChange. - -Variable R :realDomainType. -Implicit Type l: (seq R). -Implicit Type p: {poly R}. - -Definition all_eq0 l := all (fun x => x == 0) l. -Definition all_ge0 l:= all (fun x => 0 <= x) l. -Definition all_le0 l := all (fun x => x <= 0) l. -Definition all_ss a l := all (fun x => 0 <= x * a) l. -Definition opp_seq l := [seq - z | z <- l]. -Definition filter0 l := [seq z <- l | z != 0]. - -(** Some helper lemmas *) - -Lemma product_neg (a b : R): a * b < 0 -> a != 0 /\ b != 0. -Proof. -case (eqVneq a 0) => [->|]; first by rewrite mul0r ltxx. -case (eqVneq b 0) => [->|] //; by rewrite mulr0 ltxx. -Qed. - -Lemma square_pos (a: R): a != 0 -> 0 < a * a. -Proof. by move => anz; rewrite lt0r sqr_ge0 sqrf_eq0 anz. Qed. - -Lemma prodNsimpl_ge (a b x: R): b * a < 0 -> 0 <= x * b -> x * a <= 0. -Proof. -move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. -by rewrite - (nmulr_lle0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lle0. -Qed. - -Lemma prodNsimpl_gt (a b x: R): b * a < 0 -> 0 < x * b -> x * a < 0. -Proof. -move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. -by rewrite - (nmulr_llt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_llt0. -Qed. - -Lemma prodNsimpl_lt (a b x: R): b * a < 0 -> x * b < 0 -> 0 < x * a. -Proof. -move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. -by rewrite - (nmulr_lgt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lgt0. -Qed. - -Lemma all_rev l q: all q l = all q (rev l). -Proof. by elim:l => [// | a l hr]; rewrite rev_cons all_rcons /= hr. Qed. - -Lemma has_split q l: has q l -> - exists l1 a l2, [/\ l = l1 ++ a :: l2, q a & all (fun z => ~~(q z)) l1]. -Proof. -elim:l => // a l Hrec /=; case ha: (q a) => /=. - by move => _; exists [::], a, l; split => //. -move /Hrec => [l1 [b [l2 [-> pb pc]]]]. -by exists (a::l1),b,l2; split => //=; rewrite ha pc. -Qed. - -Lemma has_split_eq l: has (fun z => z != 0) l -> - exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l1]. -Proof. -move/has_split => [l1 [a [l2 [-> pa pb]]]]; exists l1,a,l2; split => //. -by apply /allP => x; move /(allP pb); case (x==0). -Qed. - -Lemma has_split_eq_rev l: has (fun z => z != 0) l -> - exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l2]. -Proof. -have <- : (has (fun z : R => z != 0)) (rev l) = has (fun z : R => z != 0) l. - by elim:l => [// | a l hr]; rewrite rev_cons has_rcons /= hr. -move/has_split_eq => [l1 [a [l2 [lv pa pb]]]]; exists (rev l2),a,(rev l1). -by rewrite -(cat1s a) catA cats1 -rev_cons -rev_cat -lv revK /all_eq0 -all_rev. -Qed. - -Lemma opp_seqK l: opp_seq (opp_seq l) = l. -Proof. -by rewrite/opp_seq -map_comp; apply map_id_in => a /=; rewrite opprK. -Qed. - -Definition tail_coef p := p `_(\mu_0 p). -Definition lead_tail_coef p := (tail_coef p) * (lead_coef p). - -Lemma tail_coef0a p: ~~ (root p 0) -> tail_coef p = p`_0. -Proof. by move /muNroot; rewrite /tail_coef => ->. Qed. - -Lemma tail_coef0b p: p`_0 != 0 -> tail_coef p = p`_0. -Proof. rewrite - {1} horner_coef0; apply: tail_coef0a. Qed. - -Lemma tail_coefM (p q: {poly R}): - tail_coef (p*q) = (tail_coef p) * (tail_coef q). -Proof. -rewrite /tail_coef. -case pnz: (p!=0); last by rewrite (eqP(negbFE pnz)) mul0r mu0 coef0 mul0r. -case qnz: (q!=0); last by rewrite (eqP(negbFE qnz)) mulr0 mu0 coef0 mulr0. -rewrite (mu_mul 0 (mulf_neq0 pnz qnz)). -move: (mu_spec 0 pnz) (mu_spec 0 qnz); rewrite subr0. -set a := (\mu_0 p); set b:= (\mu_0 q); move => [pa v1 ->] [qa v2 ->]. -by rewrite mulrACA -exprD 3! coefMXn ! ltnn ! subnn - ! horner_coef0 hornerM. -Qed. - -Lemma lead_tail_coefM (p q: {poly R}): - lead_tail_coef (p*q) = (lead_tail_coef p) * (lead_tail_coef q). -Proof. by rewrite /lead_tail_coef -mulrACA -tail_coefM lead_coefM. Qed. - -Lemma lead_tail_coef_opp p: lead_tail_coef (- p) = (lead_tail_coef p). -Proof. -rewrite - mulrN1 lead_tail_coefM; set one := (X in _ * lead_tail_coef(X)). -suff : lead_tail_coef one = 1 by move ->; rewrite mulr1. -have ->: one = ((-1)%:P) by rewrite polyCN. -by rewrite /lead_tail_coef /tail_coef lead_coefC mu_polyC coefC mulN1r opprK. -Qed. - -Lemma mu_spec_supp p: p != 0 -> - exists q, [/\ p = q * 'X^ (\mu_0 p), (~~ root q 0), - lead_coef p = lead_coef q, tail_coef p = tail_coef q & - tail_coef q = q`_0]. -Proof. -move /(mu_spec 0) => [q pa]; set n := (\mu_0 p) => ->; exists q. -rewrite lead_coefM tail_coefM {1 2} subr0 (eqP (monicXn R n)) mulr1 /tail_coef. -by rewrite mu_exp mu_XsubC mul1n subr0 coefXn eqxx mulr1 (muNroot pa). -Qed. - -Lemma tail_coefE p: tail_coef p = (head 0 (filter0 p)). -Proof. -have [-> |] := (eqVneq p 0); first by rewrite /tail_coef mu0 coef0 polyseq0 /=. -move /(mu_spec_supp) => [q [pa pb pc pd pe]]; rewrite /filter0. -case (eqVneq q 0) => qnz; first by move: pb; rewrite qnz root0. -have q0nz: q`_0 != 0 by rewrite - horner_coef0. -rewrite pd pe pa polyseqMXn// -cat_nseq filter_cat (eq_in_filter (a2 := pred0)). - by rewrite filter_pred0 cat0s nth0; move: q0nz; case q; case => //= a l _ ->. -have /allP h: all (pred1 (0:R)) (nseq (\mu_0 p) 0). - by rewrite all_pred1_nseq. -by move => x /h /= ->. -Qed. - -Fixpoint changes (s : seq R) : nat := - (if s is a :: q then (a * (head 0 q) < 0)%R + changes q else 0)%N. -Definition schange (l: seq R) := changes (filter0 l). - -Lemma schange_sgr l: schange l = schange [seq sgr z | z <- l]. -Proof. -rewrite /schange /filter0 filter_map; set s1 := [seq z <- l | z != 0]. -set s := (filter (preim _ _)); have -> : s l = s1. - apply: eq_in_filter => x xl /=. - by rewrite sgr_def; case xz: (x!=0); rewrite ?mulr0n ?eqxx ?mulr1n ?signr_eq0. -elim: s1 => [ // | a l1 /= ->]; case l1 => /=; first by rewrite !mulr0. -by move => b l2; rewrite - sgrM sgr_lt0. -Qed. - - -Lemma schange0_odd l: last 0 l != 0 -> - odd (schange l + (0 < head 0 (filter0 l) * last 0 l)%R). -Proof. -rewrite /schange. -have -> : filter0 l = [seq z <- 0::l | z != 0]. - by rewrite /filter0 {2} /filter eqxx. -rewrite (lastI 0 l); set b := (last 0 l) => bnz; rewrite filter_rcons bnz. -set s := [seq z <- belast 0 l | z != 0]. -have: all (fun z => z != 0) s by apply : filter_all. -elim: s; first by rewrite /= mulr0 ltxx square_pos //. -move => c s /=; set C:= changes _; set d:= head 0 _ => hr /andP [cnz etc]. -have dnz: d != 0 by move: etc; rewrite /d; case s => // s' l' /= /andP []. -rewrite addnC addnA addnC; move: (hr etc). -rewrite -sgr_gt0 - (sgr_gt0 (c*b)) - sgr_lt0 ! sgrM. -rewrite /sgr - if_neg - (if_neg (c==0))- (if_neg (b==0)) bnz dnz cnz. -by case: (d<0); case: (b<0); case: (c<0); rewrite ?mulrNN ? mulr1 ?mul1r ?ltr01 - ?ltrN10 ? ltr10 ? ltr0N1 ?addn0 ? addnS ?addn0//=; move => ->. -Qed. - -Lemma schange_odd p : p != 0 -> odd (schange p + (0 < lead_tail_coef p)%R). -Proof. -rewrite - lead_coef_eq0 /lead_tail_coef tail_coefE /schange lead_coefE nth_last. -by move => h; rewrite schange0_odd. -Qed. - -Lemma schange_cat l1 a l2: a != 0 -> - schange (l1++a::l2) = (schange (l1++[::a]) + schange (a::l2)) %N. -Proof. -move => anz. -rewrite /schange /filter0 filter_cat cats1 filter_rcons anz. -set w := [seq z <- a :: l2 | z != 0]. -elim [seq z <- l1 | z != 0]; first by rewrite /= mulr0 ltxx. -move => b l /= ->. rewrite - addnA. congr addn. -by rewrite -cats1 /w; case l => //=; rewrite anz. -Qed. - -Lemma schange_nz l i j: l`_i * l`_j < 0 -> (0 < (schange l))%N. -Proof. -move=> pn; move: (product_neg pn) => [xnz ynz]. -have aux: forall k, l`_k !=0 -> l`_k \in (filter0 l). - move => k kz; rewrite mem_filter kz /= mem_nth //. - by case (leqP (size l) k) => h //; move: kz;rewrite nth_default // eqxx. -move: pn (aux _ xnz) (aux _ ynz); set x := l`_i; set y := l`_j. -move: (filter_all (fun z => z!=0) l); rewrite /schange -/(filter0 l). -case (filter0 l) => //. -move => a l2 pa pb pc pd. -wlog : x y pb pc pd / a * x < 0. - move => H; case (ltrgt0P (a * x)) => h; try apply: (H x y pb pc pd h). - apply: (H y x) => //; [by rewrite mulrC | exact: (prodNsimpl_gt pb h)]. - move: pa => /= /andP [anz _]. - by move /eqP: h; rewrite mulf_eq0 (negbTE anz) (negbTE xnz). -move: pc; rewrite inE; case /orP. - by move /eqP <- => h; move: (lt_trans pb (prodNsimpl_lt pb h)); rewrite ltxx. -move: pa; clear; move:a x; elim l2 => //. -move => a l H b x /= /andP [bnz bl] ca bcn. -case (ltrgt0P (b * a)); last first. - by move /eqP; rewrite mulf_eq0 (negbTE bnz)=> /= ane; move: bl; rewrite ane. - move=> ->. - by rewrite add1n ltnS. -rewrite mulrC; move => ba; move: (prodNsimpl_gt bcn ba) => aca. -rewrite (ltNge (a * b)) (ltW ba) add0n. -apply: (H a x bl) => //; move: ca; rewrite inE; case /orP => // /eqP xa. -by move: (lt_trans bcn ba); rewrite xa mulrC ltxx. -Qed. - -Fixpoint schange_index_aux l i y := - if l is x::l' then - if (((y==0) && (x != 0)) || (x*y < 0)) then i :: schange_index_aux l' i.+1 x - else schange_index_aux l' i.+1 y - else [::]. - -Definition schange_index l := schange_index_aux l 0 0. - -Notation SIA := schange_index_aux. (* local short notation *) - -(** We study the sign change function *) - -Lemma schangei_addm l n m a: - SIA l (n+m)%N a = [seq (z+m)%N | z <- SIA l n a]. -Proof. -move: n a; elim: l => [ n z // | a l hrec n y /=]. -by case hyp: ((y == 0) && (a != 0) || (a * y < 0))=> //=; rewrite - addSn hrec. -Qed. - -Lemma schangei_s0 l1 l2: all_eq0 l1 -> - schange_index (l1 ++ l2) = SIA l2 (size l1) 0. -Proof. -elim l1 => // a l hrec /= /andP [/eqP -> /hrec]. -rewrite /schange_index /= mul0r eqxx ltxx andbF orbF. -by rewrite - addn1 - (addn1 (size l)) ! schangei_addm => <-. -Qed. - -Lemma schangeE l: (size (schange_index l)).-1 = (schange l). -Proof. -transitivity ((size (schange_index (filter (fun z => z != 0) l))).-1). - have aux: forall l, (all_eq0 l) -> filter (fun z => z != 0) l = [::]. - by elim => // a l' Hr /= /andP [-> /Hr ->]. - rewrite /schange; case alz: (all_eq0 l). - by rewrite (aux _ alz) - {1} (cats0 l) schangei_s0. - move: (negbT alz); rewrite - (has_predC) => /has_split_eq. - move => [l1 [b [l2 [-> pb pc]]]]; rewrite filter_cat aux //= pb. - rewrite schangei_s0 // /schange_index /= eqxx pb /=. - move: b (size l1).+1 1%N pb; elim: l2 => // a l' Hrec b n m bnz /=. - case (eqVneq a 0). - by move => ->; rewrite mul0r eqxx ltxx andbF /=; apply: Hrec. - move =>h; rewrite h /= (negbTE bnz) /=. - by case h':(a * b < 0); [ simpl; congr S |]; apply: Hrec. -move: (filter_all (fun z => z != 0) l); rewrite -/(filter0 l). -rewrite /schange; case (filter0 l) => // a s /= /andP [anz ar]. -rewrite /schange_index /SIA -/SIA eqxx anz andbT orTb /=. -move: 1%N a anz ar; elim:s; first by move => a n _ _ /=; rewrite mulr0 ltxx. -move => a s Hrec n b bnz /= /andP [anz ar]; rewrite mulrC anz (negbTE bnz) /=. -case h:(b * a < 0) => /=; rewrite Hrec // add0n. -have: (0 < b * a) by rewrite lt0r mulf_neq0 // leNgt h. -case (ltrgt0P a) => ap //; last by move: anz; rewrite ap eqxx. - by rewrite (pmulr_lgt0) // => bp; rewrite ! (pmulr_rlt0). -by rewrite (nmulr_lgt0) // => bp; rewrite ! (nmulr_rlt0). -Qed. - -Lemma schangei0 l: all_eq0 l <-> schange_index l = [::]. -Proof. -split; first by move /schangei_s0 => h; move: (h [::]); rewrite /= cats0. -suff: forall l n, SIA l n 0 = [::] -> all_eq0 l by apply. -elim => [ // | a l' hrec n]. -by rewrite /= eqxx mulr0 ltxx orbF andTb; case az: (a==0) => //= /hrec. -Qed. - -Lemma schangei_s0n l1 a l2: a !=0 -> all_eq0 l1 -> - schange_index (l1 ++a :: l2) = size l1 :: (SIA l2 (size l1).+1 a). -Proof. by move => anz alz; rewrite (schangei_s0 _ alz) /= eqxx anz. Qed. - -Lemma schangei_snn l i s: - schange_index l = i::s -> exists l1 a l2, - [/\ l = l1 ++a :: l2, a != 0, i = size l1, all_eq0 l1 & - SIA l2 (size l1).+1 a = s]. -Proof. -case alt: (all_eq0 l); first by move /schangei0:alt => -> //. -move: (allPn (negbT alt)) => /hasP /has_split_eq [l1 [a [l2 [ -> az al0]]]]. -rewrite (schangei_s0n _ az al0) => /eqP;rewrite eqseq_cons. -by move => /andP [/eqP <- /eqP <-];exists l1, a, l2. -Qed. - -Lemma schangei_reca a l n: a != 0 -> ((all_ss a l) = (SIA l n a == [::])). -Proof. -move => anz; move: n; elim: l => [// | b l h n]. -by rewrite /= (negbTE anz)/= (h n.+1) ltNge; case sab: (0 <= b * a). -Qed. - - -Lemma schangei_rec a l1 l2 n: a != 0 -> all_ss a l1 -> - SIA (l1++l2) n a = SIA l2 (n + size l1)%N a. -Proof. -move => anz; move: n; elim : l1;first by move =>n /=; rewrite addn0. -move =>b l hrec n /= /andP [pa pb]. -by rewrite ltNge pa (negbTE anz) /= (hrec _ pb) addnS addSn. -Qed. - -Lemma schangei_recb a l1 b l2 n: b * a < 0 -> all_ss a l1 -> - SIA (l1++ b::l2) n a = (n+size l1)%N :: SIA l2 (n + size l1).+1 b. -Proof. -move => h1 h2; move : (product_neg h1) => [bz az]. -by rewrite (schangei_rec _ _ az h2) /= bz h1 orbT. -Qed. - -Lemma schangei_recc a l i s n: a!= 0 -> - SIA l n a = i :: s -> exists l1 b l2, - [/\ l = l1 ++ b :: l2, b *a <0, b!= 0, (all_ss a l1) & - (i = n+size l1)%N /\ SIA l2 (n + size l1).+1 b = s]. -Proof. -move => anz;case alz: (all_ss a l). - by move: alz; rewrite (schangei_reca _ n anz) => /eqP ->. -move: (negbT alz); rewrite - (has_predC) => /has_split [l1 [b [l2 [-> pb pc]]]]. -move: pb => /=; rewrite - ltNge => abn. -case bz: (b!=0); last by move: abn; rewrite (eqP (negbFE bz)) mul0r ltxx. -have pc': all_ss a l1 by apply /allP => t /(allP pc) /= /negbNE. -rewrite (schangei_recb l2 n abn pc') => /eqP h. -by exists l1,b, l2; move: h; rewrite eqseq_cons => /andP [/eqP <- /eqP ->]. -Qed. - -Lemma schangei_tail l i s: - schange_index l = rcons s i -> exists l1 a l2, - [/\ l = l1 ++ a :: l2, (i <= size l1)%N, 0 < a * l`_i & all_eq0 l2]. -Proof. -move => h. -suff [l1 [a [l2 [-> pa pb pc]]]]: exists l1 (a : R) l2, - [/\ l = l1 ++ a :: l2, a != 0, i = size l1 & all_ss a l2]. - have:has (fun z => z != 0) (a::l2) by rewrite /= pa. - move /has_split_eq_rev => [la [b [lb [qa qb qc]]]]. - exists (l1++la),b, lb. - rewrite pb size_cat leq_addr nth_cat ltnn subnn /= qa catA; split => //. - have: b \in a :: l2 by rewrite qa mem_cat mem_head orbT. - rewrite lt0r (mulf_neq0 qb pa) /= in_cons =>/orP []; last by move /(allP pc). - by move /eqP => ->; rewrite sqr_ge0. -move: h;case: s. - move /schangei_snn => [l1 [a [l2 [ -> pb pc pd pe]]]]; exists l1, a, l2. - by split => //; move: pe => /eqP; rewrite -schangei_reca. -move => j s; move /schangei_snn => [l1 [a [l2 [-> pb pc _]]]] h. -suff [l0 [b [l3 [-> qb -> qd]]]]: exists l0 b l3, [/\ l2 = l0 ++ b :: l3, b !=0, - i = ((size l1).+1 + size l0)%N & all_ss b l3 ]. - by exists (l1++a::l0),b,l3; rewrite - catA cat_cons addSnnS size_cat //=. -move: l2 a pb (size l1).+1 h; clear; elim: s. - move => l b bnz n /= h. - move: (schangei_recc bnz h)=> [l1 [c [l2 [-> pa cz pb [pc pd]]]]]. - by exists l1,c,l2; split => //; move:pd => /eqP; rewrite - schangei_reca. -move => a l Hrec l2 b bnz n. -move /(schangei_recc bnz) => [l1 [c [l3 [-> pa cz pb [pc]]]]]. -move /(Hrec _ _ cz _) => [l0 [d [l4 [-> qa -> qc]]]]. -by exists ( l1 ++ c :: l0), d,l4; rewrite -catA cat_cons addSnnS size_cat addnA. -Qed. - -Lemma schangei_correct l (i : nat): - i \in schange_index l -> l`_i != 0 /\ l`_i * (0::l)`_i <= 0. -Proof. -move: {2 3} (schange_index l) (refl_equal (schange_index l)); case => //. -have aux: forall i l n a, - i \in SIA l n a -> exists2 j:nat, j \in SIA l 0 a & i = (j + n)%N. - by move => i' l' n a; rewrite -(add0n n) schangei_addm; move /mapP. -move => k s /schangei_snn [l1 [a [l2 [-> anz il1 l1z sv]]]]. -rewrite inE; case/ orP. - move /eqP ->; rewrite !nth_cat il1 ltnn subnn /=; split => //. - rewrite -cat_cons nth_cat /= ltnS leqnn -last_nth. - suff : (last 0 l1 == 0) by move => /eqP ->; rewrite mulr0. - by move: (mem_last 0 l1); rewrite inE => /orP; case => //; move /(allP l1z). -rewrite - sv => isv. -move : (aux i l2 (size l1).+1 a isv) => [j j2 j1]. -rewrite j1 addnC nth_cat - cat_cons nth_cat addSn - addnS ltnNge leq_addr /=. -rewrite addnC addnK /= addSn ltnNge ltnS leq_addl /= -addnS addnK. -move: j2; clear il1 l1z isv j1 sv k s l1 l i. -move: {1} 0%N {1} (SIA l2 0 a) (refl_equal (SIA l2 0 a)) => n s. -move:s l2 a n j anz; elim. - by move => l2 a n j _; rewrite -(add0n n) schangei_addm; case (SIA l2 0 a). -move => a s Hrec l b n j bnz => eq1;symmetry in eq1. -move: (schangei_recc bnz eq1)=> [l1 [c [l3 [pa pb cz pc [pd pe]]]]] => js. -have: (j + n)%N \in SIA l n b. - by rewrite-{2} (add0n n) schangei_addm; apply /mapP; exists j. -rewrite eq1 in_cons => /orP []. - rewrite pd addnC eqn_add2l => /eqP ->. - rewrite pa - cat_cons nth_cat ltnn subnn; split => //. - rewrite /= - (cat_cons) nth_cat /= ltnS leqnn -last_nth. - move: (mem_last b l1)=> /orP;case; first by move/eqP => ->;apply: ltW. - by rewrite mulrC; move/(allP pc); apply prodNsimpl_ge; rewrite mulrC. -rewrite - pe - addnS (addnC n) schangei_addm; move /mapP. -move => [j0 ka] /eqP; rewrite eqn_add2r => /eqP => ->. -move: ka; rewrite -(add0n (size l1).+1) schangei_addm => /mapP [k jv ->]. -symmetry in pe; move: (Hrec l3 c (n + size l1).+1 k cz pe jv). -rewrite pa - cat_cons ! nth_cat - addSnnS leqNgt ltnS leq_addl /=. -by rewrite addnK /= addSnnS leqNgt ltnS leq_addl /= addnK. -Qed. - -Lemma pol_mul_cs (p: {poly R}) (x: R): - p !=0 -> x > 0 -> ( (schange p) < (schange (p * ('X - x%:P))%R))%N. -Proof. -move => pnz xn. -set q := _ * _. -have spp: size p = (size p).-1.+1. - by move: pnz; rewrite -size_poly_eq0; case sz:(size p). -set s := (schange_index p). -have pa: forall k:nat, k \in s -> p`_k * q`_k < 0. - move => k ks. - move: (schangei_correct ks) => [eq1 eq2]. - have rhsp: 0 < p`_k * (p`_k * x) by rewrite mulrA pmulr_lgt0 // square_pos. - rewrite /q mulrBr coefB coefMC mulrBr subr_lt0 coefMX (le_lt_trans _ rhsp)//. - by move: eq2; case k. -have: schange_index p = s by []. -have lcpnz: lead_coef p != 0 by rewrite lead_coef_eq0. -have lpp: lead_coef p \in polyseq p by apply: mem_nth; rewrite {2} spp. -move: (eq_refl s); rewrite {1}/s; case s. - by move /eqP /schangei0 => ap; move:lcpnz; move /(allP ap): lpp => ->. -move => i l0 _ sv0. -have pb: 0 < p`_(last 0%N s) * q`_(size p). - have -> : q`_(size p) = lead_coef p. - move: (monicXsubC x) => mc; rewrite- (lead_coef_Mmonic p mc) lead_coefE. - by rewrite (size_Mmonic pnz mc) size_XsubC addn2. - move: (lastI i l0) lcpnz; rewrite - sv0 => sv1. - move:(schangei_tail sv1) => [l1 [a [l2 [pv sl1 pn]]]]. - have ->: last 0%N s = (last i l0) by rewrite /s sv1 last_rcons. - have: lead_coef p = last 0 p by rewrite (last_nth 0) spp. - rewrite pv last_cat last_cons; case l2. - move => /= ->; move: pn; rewrite pv - cat1s catA mulrC. - by rewrite (nth_cat 0 (l1 ++ [:: a])) size_cat addn1 ltnS sl1. - by move => b l anz lpv; rewrite (allP lpv) // anz /= mem_last. -have rec0: forall l1 l2, l2`_0 != 0 -> (schange (l2) <= schange (l1++l2))%N. - by move => l1; case => // a l2 /= anz; rewrite (schange_cat _ _ anz) leq_addl. -have ncat: forall l1 l2 b, (l1++l2)`_( (size l1) +b) = l2`_b. - by move=> l1 l2 b; rewrite nth_cat addKn -ltn_subRL subnn. -move: pa pb;rewrite -{1} schangeE /s sv0 /=. -move: sv0 => /schangei_snn [l1 [a [l2 [-> pa pb pc pd]]]] ha hb. -have he: (l1 ++ a :: l2)`_i = a by rewrite nth_cat pb ltnn subnn. -have skm: forall k, (l1 ++ a :: l2)`_(k + i) = (a::l2)`_k. - by move => k; rewrite addnC pb ncat. -have hc: a * q`_i < 0 by rewrite -he;apply: ha; rewrite mem_head. -have[l2a [l2b [l2v sl]]]: exists l2a l2b, l2a ++ l2b = q /\ size l2a = i. - exists (take i q), (drop i q); split; first by exact: cat_take_drop. - apply: size_takel; case /orP:(leq_total i (size q)) => //. - by move/(nth_default 0) => h; move: hc; rewrite h mulr0 ltxx. -move: (hc); rewrite -l2v nth_cat -sl ltnn subnn => hc'. -apply: (leq_trans _ (rec0 l2a l2b (proj2 (product_neg hc')))). -have sv:[seq (z + i)%N | z <- SIA l2 1 a] = l0 by rewrite pb -pd -schangei_addm. -have: forall k, k \in (SIA l2 1 a) -> (a::l2)`_(k-0)%N * l2b`_(k-0%N) < 0. - move => k ka; rewrite - skm subn0. - have ->: l2b`_k = q`_(k+i) by rewrite -l2v - sl addnC ncat. - by apply: ha;rewrite inE - sv (mem_map (@addIn i)) ka orbT. -have: 0 < (a :: l2)`_((last 0%N (SIA l2 1 a)) -0) * l2b`_(size l2).+1. - move: hb; rewrite -sv /= (last_map (fun z=> (z + i)%N) (SIA l2 1 a) 0%N). - by rewrite subn0 skm - l2v size_cat -pb - sl ncat. -rewrite - sv size_map. -move: rec0 ncat hc' pa; clear; move => rec0 ncat hc' pa. -move: {2 3 4 5} (SIA l2 1 a) pa (erefl (SIA l2 1 a)) hc'. -rewrite - (addn0 1%N); move: {2 4 5 6 7} 0%N. -move => n s; move: s a n l2 l2b; elim. - move => a n l l' _ anz pnz;set j := (size l).+1 %N. - rewrite /last subnn {1}/nth mulrC ; move => lt2 _. - move:(prodNsimpl_gt pnz lt2);apply: schange_nz. -move => i s Hrec a n l l' anz. -move /(schangei_recc anz)=> [l1 [b [l2 [-> pa pb pc [pd pe]]]]]. -move => qa qb qc /=. -have imn: (i - n = (size l1).+1) %N by rewrite pd addnAC add1n addnK. -have: (i\in i :: s) by rewrite mem_head. -move /qc; rewrite imn -cat1s catA nth_cat subnn ltnn - imn => e1. -set ni := (i - n )%N. -move: (cat_take_drop ni l'). -set l1' := take ni l'; set l2' := drop ni l' => e2. -have e3: size l1' = ni. - move: e1;rewrite size_take; case (leqP (size l') ni) => //. - by move/(nth_default 0) => ->; rewrite mulr0 ltxx. -move: (prodNsimpl_lt qa pa); rewrite mulrC => e4. -move: (prodNsimpl_gt e1 e4) => e5. -move: (proj2 (product_neg e5)); set w := l'`_ni => wnz. -have [u l2v]: exists u, l2' = w::u. - move: wnz;rewrite /w - e2 nth_cat e3 ltnn subnn. - case l2'; [ by rewrite eqxx | by move => a1 b1 _; exists b1]. -move: (schange_cat l1' u wnz); rewrite - l2v e2 => ->. -suff: ((size s) < schange l2')%N. - set l1'' := (l1' ++ [:: w]). - have : l1''`_0 * l1''`_ni < 0. - move: e5; rewrite -e2 l2v /l1'' !nth_cat e3 ltnn subnn; case i => //. - by move/schange_nz => e6 e7; move: (leq_add e6 e7); rewrite add1n. -clear u l2v. -have r0: b * l2'`_0 < 0 by move: e1; rewrite - e2 nth_cat e3 ltnn subnn. -move: pe; rewrite -pd - add1n => r1. -have r2 : (forall k, k \in s -> (b :: l2)`_(k - i) * l2'`_(k - i) < 0). - move => k ks; have: k \in i::s by rewrite inE ks orbT. - move: ks; rewrite -{1} r1 schangei_addm; move /mapP => [k' k'v kv]. - have ->: (k - i)%N = k' by rewrite kv addnK. - move/ qc; rewrite - e2 - cat1s catA. - have ->: (k - n = k' + (size l1).+1)%N. - by rewrite kv pd addnAC add1n addnA addnK. - by rewrite addnC ncat -imn -/ni -e3 ncat. -have r3: 0 < (b :: l2)`_(last i s - i) * l2'`_(size l2).+1. - move:qb; rewrite - e2 size_cat - addSn - imn -/ni -e3 ncat. - suff: ((last n (i :: s) - n) = ni + (last i s - i)) %N. - by move => ->; rewrite /ni imn - cat1s catA ncat. - have lni: (n<=i) %N by rewrite pd addnAC leq_addl. - rewrite -r1 schangei_addm; case (SIA l2 1 b); first by rewrite /= subnn addn0. - move => n0 l0 /=; set la := last _ _. - have eq1: (i <= la)%N. - by rewrite /la (last_map (fun z=> (z + i)%N)) leq_addl. - by rewrite - {1} (subnK eq1) - (addnBA _ lni) addnC. -exact: (Hrec b i l2 l2' pb r1 r0 r3 r2). -Qed. - -End SignChange. - -Section SignChangeRcf. -Variable R : rcfType. -Implicit Type p : {poly R}. - -Lemma noproots_cs p: (forall x, 0 ~~ root p x) -> 0 < lead_tail_coef p. -Proof. -move => h. -have [pz |pnz]:= (eqVneq p 0); first by move: (h _ ltr01); rewrite pz root0. -move: (mu_spec_supp pnz) => [q [pa pb pc pd pe]]. -have: {in `[0, +oo[, (forall x, ~~ root q x)}. - move=> x; rewrite in_itv/= andbT le0r; case/orP; first by move=>/eqP ->. - by move /h; rewrite pa rootM negb_or => /andP []. -move/sgp_pinftyP => ha; move: (ha 0). -rewrite in_itv/= lexx /= => H. -rewrite /lead_tail_coef pc pd pe - sgr_gt0 sgrM -/(sgp_pinfty q). -by rewrite - horner_coef0 - H // - sgrM sgr_gt0 lt0r sqr_ge0 mulf_neq0. -Qed. - -Definition fact_list p s q := - [/\ p = (\prod_(z <- s) ('X - z.1%:P) ^+ (z.2)) * q, - (all (fun z => 0 < z) [seq z.1 | z <- s]), - (sorted <%R [seq z.1 | z <- s]) & - (all (fun z => (0 (forall x, 0 ~~ root (sq.2) x)) - /\ (p = 0 -> sq.1 = [::] /\ sq.2 = 0)) }. -Proof. -case pnz: (p != 0); last first. - by exists ([::],p) => //; split => //; rewrite big_nil mul1r. -pose sa := [seq z <- rootsR p | 0 0 < z) [seq z.1 | z <- sb]). - by rewrite - sav; apply /allP => x; rewrite mem_filter => /andP []. -have pb : (sorted <%R [seq z.1 | z <- sb]). - rewrite -sav. - by apply: sorted_filter => //; [apply: lt_trans |apply: sorted_roots]. -have pc: (all (fun z => (0 x /mapP [t] /mapP [z]; rewrite mem_filter => /andP [z0 z2]. - move => -> -> /=; rewrite mu_gt0 //; apply: (root_roots z2). -suff: { q | p = (\prod_(z <- sa) ('X - z%:P) ^+ (\mu_z p)) * q & - forall x : R, 0 < x -> ~~ root q x}. - move => [q qa qb]; exists (sb,q) => //. - by split => //;rewrite qa /= big_map; congr (_ * _); apply eq_big. - by split => // pz; move: pnz; rewrite pz eqxx. -clear sb sav pa pb pc. -have: all (root p) sa. - apply/allP=> x;rewrite mem_filter =>/andP [_]; apply /root_roots. -have: uniq sa by apply:filter_uniq; apply: uniq_roots. -have: forall x, root p x -> 0 < x -> x \in sa. - by move=> x rx xp;rewrite mem_filter xp -(roots_on_rootsR pnz) rx. -move: sa=> s. -elim: s p pnz=>[p _ H _ _| ]. - exists p; first by by rewrite big_nil mul1r. - move => x xp;apply/negP =>nr; by move: (H _ nr xp). -move => a l Hrec /= p p0 rp /andP [nal ul] /andP [ap rap]. -have [q rqa pv] := (mu_spec a p0). -case q0: (q != 0); last by move:p0; rewrite pv (eqP(negbFE q0)) mul0r eqxx. -have q1 x: root q x -> 0 < x -> x \in l. - move=> rx xp; case xa: (x == a); first by rewrite -(eqP xa) rx in rqa. - by rewrite -[_ \in _]orFb -xa -in_cons rp // pv rootM rx. -have q2: all (root q) l. - apply/allP=> x xl. - case xa: (x ==a); first by move: nal; rewrite - (eqP xa) xl. - move /(allP rap): xl. - by rewrite pv rootM -[\mu__ _]prednK ?mu_gt0 // root_exp_XsubC xa orbF. -have [r qv rq]:= (Hrec q q0 q1 ul q2). -exists r => //; rewrite {1} pv {1} qv mulrAC; congr (_ * _). -rewrite big_cons mulrC; congr (_ * _). -rewrite (big_nth 0). -rewrite [in RHS](big_nth 0). -rewrite 2!big_mkord; apply: eq_bigr => i _. -set b := l`_i;congr (_ ^+ _). -have rb: root q b by apply /(allP q2); rewrite mem_nth //. -have nr: ~~ root (('X - a%:P) ^+ \mu_a p) b. - rewrite /root horner_exp !hornerE expf_neq0 // subr_eq0; apply /eqP => ab. - by move: rqa; rewrite - ab rb. -rewrite pv mu_mul ? (muNroot nr) // ?addn0//. -by rewrite mulf_neq0 // expf_neq0 // monic_neq0 // monicXsubC. -Qed. - -Definition pos_roots p := (s2val (poly_split_fact p)).1. -Definition pos_cofactor p := (s2val (poly_split_fact p)).2. -Definition npos_roots p := (\sum_(i <- (pos_roots p)) (i.2)) %N. - -Lemma pos_split1 p (s := pos_roots p) (q:= pos_cofactor p): - p != 0 -> [/\ fact_list p s q, (forall x, 0 ~~ root q x) & q != 0]. -Proof. -move => h; rewrite /s/q /pos_roots / pos_cofactor. -move: (poly_split_fact p) => H; move: (s2valP' H) (s2valP H) => [h1 _] h2. -split => //; first by apply: h1. -by apply/eqP => qz; move:h2 => [] pv; move: h; rewrite {1} pv qz mulr0 eqxx. -Qed. - - -Lemma monicXsubCe (c:R) i : ('X - c%:P) ^+ i \is monic. -Proof. apply:monic_exp; exact: monicXsubC. Qed. - -Lemma monic_prod_XsubCe I rI (P : pred I) (F : I -> R) (G : I -> nat): - \prod_(i <- rI | P i) ('X - (F i)%:P )^+ (G i) \is monic. -Proof. by apply: monic_prod => i _; exact: monicXsubCe. Qed. - -Lemma npos_root_parity p: p != 0 -> - odd (npos_roots p + (0< lead_tail_coef p)%R). -Proof. -move => pnz; move: (pos_split1 pnz) => [[pv pb pc] pd qp qnz]. -rewrite {2} pv;set r := \prod_(z <- _) _. -have rm: r \is monic by apply:monic_prod_XsubCe. -rewrite lead_tail_coefM (pmulr_lgt0 _ (noproots_cs qp)) /lead_tail_coef. -move: (refl_equal (sgr r`_0)); rewrite - {2} horner_coef0 horner_prod. -set X := \prod_(z <- _) _; have ->: X = \prod_(i <- pos_roots p) (- i.1)^+ i.2. - by apply: eq_big => // i _; rewrite horner_exp hornerXsubC sub0r. -have ->: Num.sg (\prod_(i <- pos_roots p) (- i.1) ^+ i.2) = - (-1) ^+ \sum_(i <- pos_roots p) (i.2). - move: pb; elim (pos_roots p) => [ _ | i rr /= Hr /andP [pa pb]]. - by rewrite !big_nil sgr1. - by rewrite !big_cons sgrM sgrX Hr // sgrN (gtr0_sg pa) exprD. -move => aux. -case (eqVneq r`_0 0) => nr0. - by move: aux; rewrite nr0 sgr0 => /eqP; rewrite eq_sym signr_eq0. -rewrite (eqP rm) mulr1 (tail_coef0b nr0) -sgr_gt0 aux - signr_odd signr_gt0. -by case h: (odd(npos_roots p)); [ rewrite addn0 | rewrite addn1 /= h]. -Qed. - -Lemma size_prod_XsubCe I rI (F : I -> R) (G : I -> nat) : - size (\prod_(i <- rI) ('X - (F i)%:P)^+ (G i)) = - (\sum_(i <- rI) (G i)).+1. -Proof. -elim: rI => [| i r /=]; rewrite ? big_nil ? size_poly1 // !big_cons. -rewrite size_monicM ? monicXsubCe ? monic_neq0 // ?monic_prod_XsubCe //. -by rewrite size_exp_XsubC => ->; rewrite addSn addnS. -Qed. - -Lemma schange_parity p: p != 0 -> odd (npos_roots p) = odd (schange p). -Proof. -move => pnz. -move: (npos_root_parity pnz) (schange_odd pnz). -case h: (0 < lead_tail_coef p)%R; last by rewrite !addn0 => ->. -by rewrite ! addn1 /= => /negbTE -> /negbTE ->. -Qed. - -Lemma descartes p: p != 0 -> - (odd (npos_roots p) = odd (schange p) /\ - ((npos_roots p) <= (schange p)) %N). -Proof. -move => pa; split; first by apply:schange_parity. -move: (pos_split1 pa); rewrite /npos_roots; move => [[p1 p2 p3 p4] p5 qnz]. -have [s [sa <- <-]]: exists s, [/\ (all [eta <%R 0] s), - size s = (\sum_(i <- pos_roots p) i.2)%N & - \prod_(z <- s) ('X - z%:P) * pos_cofactor p = p]. - rewrite {3}p1;move: p2;elim: (pos_roots p) => [_ | a l Hrec /= /andP [q1 q2]]. - by exists [::]; rewrite ! big_nil. - move: (Hrec q2) => [s [s1 s2 s3]]; exists ((nseq a.2 a.1) ++ s). - rewrite all_cat s1 ! big_cons -s2 size_cat size_nseq andbT; split => //. - have: all (pred1 a.1) (nseq a.2 a.1). - by rewrite all_pred1_nseq. - by move => h; apply /allP => x; move /(allP h) => /= /eqP ->//. - rewrite big_cat /= - ! mulrA -s3 ;congr ( _ * _). - rewrite (big_nth 0) big_mkord (eq_bigr (fun _ => ('X - a.1%:P)))=>[|[i]] /=. - by rewrite prodr_const card_ord size_nseq. - by rewrite size_nseq nth_nseq=> ->. -move: (pos_cofactor p) sa qnz ;clear; elim s; first by move => p _ pnz //. -move => a l Hrec p /= /andP [ap alp] pnz. -rewrite big_cons - mulrA mulrC; move: (Hrec _ alp pnz); set q := _ * _ => e1. -have qnz: q !=0 - by rewrite mulf_neq0 //; apply: monic_neq0; apply: monic_prod_XsubC. -exact (leq_ltn_trans e1 (pol_mul_cs qnz ap)). -Qed. - -End SignChangeRcf. diff --git a/theories/desc2.v b/theories/desc2.v deleted file mode 100644 index 0dc145e..0000000 --- a/theories/desc2.v +++ /dev/null @@ -1,601 +0,0 @@ -From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype order. -From mathcomp Require Import binomial bigop ssralg poly ssrnum ssrint rat. - -From mathcomp Require Import polydiv polyorder path interval polyrcf. - -(** Descates method 2 *) - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - - -Import Order.Theory GRing.Theory. -Import Num.Theory Num.Def. -Local Open Scope ring_scope. -(** ** Sign changes *) - -Section SignChange. - -Variable R :realDomainType. -Implicit Type l: (seq R). -Implicit Type p: {poly R}. - -Definition all_eq0 l := all (fun x => x == 0) l. -Definition all_ge0 l:= all (fun x => 0 <= x) l. -Definition all_le0 l := all (fun x => x <= 0) l. -Definition all_ss a l := all (fun x => 0 <= x * a) l. -Definition opp_seq l := [seq - z | z <- l]. -Definition filter0 l := [seq z <- l | z != 0]. - -(** Some helper lemmas *) - -(* TODO(rei): same as in desc1.v?! *) -Lemma product_neg (a b : R): a * b < 0 -> a != 0 /\ b != 0. -Proof. -case (eqVneq a 0) => [->|]; first by rewrite mul0r ltxx. -case (eqVneq b 0) => [->|] //; by rewrite mulr0 ltxx. -Qed. - -Lemma square_pos (a: R): a != 0 -> 0 < a * a. -Proof. by move => anz; rewrite lt0r sqr_ge0 sqrf_eq0 anz. Qed. - -Lemma prodNsimpl_ge (a b x: R): b * a < 0 -> 0 <= x * b -> x * a <= 0. -Proof. -move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. -by rewrite - (nmulr_lle0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lle0. -Qed. - -Lemma prodNsimpl_gt (a b x: R): b * a < 0 -> 0 < x * b -> x * a < 0. -Proof. -move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. -by rewrite - (nmulr_llt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_llt0. -Qed. - -Lemma prodNsimpl_lt (a b x: R): b * a < 0 -> x * b < 0 -> 0 < x * a. -Proof. -move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. -by rewrite - (nmulr_lgt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lgt0. -Qed. - -Lemma all_rev l q: all q l = all q (rev l). -Proof. by elim:l => [// | a l hr]; rewrite rev_cons all_rcons /= hr. Qed. - -Lemma has_split q l: has q l -> - exists l1 a l2, [/\ l = l1 ++ a :: l2, q a & all (fun z => ~~(q z)) l1]. -Proof. -elim:l => // a l Hrec /=; case ha: (q a) => /=. - by move => _; exists [::], a, l; split => //. -move /Hrec => [l1 [b [l2 [-> pb pc]]]]. -by exists (a::l1),b,l2; split => //=; rewrite ha pc. -Qed. - -Lemma has_split_eq l: has (fun z => z != 0) l -> - exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l1]. -Proof. -move/has_split => [l1 [a [l2 [-> pa pb]]]]; exists l1,a,l2; split => //. -by apply /allP => x; move /(allP pb); case (x==0). -Qed. - -Lemma has_split_eq_rev l: has (fun z => z != 0) l -> - exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l2]. -Proof. -have <- : (has (fun z : R => z != 0)) (rev l) = has (fun z : R => z != 0) l. - by elim:l => [// | a l hr]; rewrite rev_cons has_rcons /= hr. -move/has_split_eq => [l1 [a [l2 [lv pa pb]]]]; exists (rev l2),a,(rev l1). -by rewrite -(cat1s a) catA cats1 -rev_cons -rev_cat -lv revK /all_eq0 -all_rev. -Qed. - -Lemma opp_seqK l: opp_seq (opp_seq l) = l. -Proof. -by rewrite/opp_seq -map_comp; apply map_id_in => a /=; rewrite opprK. -Qed. - - - -Definition tail_coef p := p `_(\mu_0 p). -Definition lead_tail_coef p := (tail_coef p) * (lead_coef p). - -Lemma tail_coef0a p: ~~ (root p 0) -> tail_coef p = p`_0. -Proof. by move /muNroot; rewrite /tail_coef => ->. Qed. - -Lemma tail_coef0b p: p`_0 != 0 -> tail_coef p = p`_0. -Proof. rewrite - {1} horner_coef0; apply: tail_coef0a. Qed. - -Lemma tail_coefM (p q: {poly R}): - tail_coef (p*q) = (tail_coef p) * (tail_coef q). -Proof. -rewrite /tail_coef. -case pnz: (p!=0); last by rewrite (eqP(negbFE pnz)) mul0r mu0 coef0 mul0r. -case qnz: (q!=0); last by rewrite (eqP(negbFE qnz)) mulr0 mu0 coef0 mulr0. -rewrite (mu_mul 0 (mulf_neq0 pnz qnz)). -move: (mu_spec 0 pnz) (mu_spec 0 qnz); rewrite subr0. -set a := (\mu_0 p); set b:= (\mu_0 q); move => [pa v1 ->] [qa v2 ->]. -by rewrite mulrACA -exprD 3! coefMXn ! ltnn ! subnn - ! horner_coef0 hornerM. -Qed. - -Lemma lead_tail_coefM (p q: {poly R}): - lead_tail_coef (p*q) = (lead_tail_coef p) * (lead_tail_coef q). -Proof. by rewrite /lead_tail_coef -mulrACA -tail_coefM lead_coefM. Qed. - -Lemma lead_tail_coef_opp p: lead_tail_coef (- p) = (lead_tail_coef p). -Proof. -rewrite - mulrN1 lead_tail_coefM; set one := (X in _ * lead_tail_coef(X)). -suff : lead_tail_coef one = 1 by move ->; rewrite mulr1. -have ->: one = ((-1)%:P) by rewrite polyCN. -by rewrite /lead_tail_coef /tail_coef lead_coefC mu_polyC coefC mulN1r opprK. -Qed. - -Lemma mu_spec_supp p: p != 0 -> - exists q, [/\ p = q * 'X^ (\mu_0 p), (~~ root q 0), - lead_coef p = lead_coef q, tail_coef p = tail_coef q & - tail_coef q = q`_0]. -Proof. -move /(mu_spec 0) => [q pa]; set n := (\mu_0 p) => ->; exists q. -rewrite lead_coefM tail_coefM {1 2} subr0 (eqP (monicXn R n)) mulr1 /tail_coef. -by rewrite mu_exp mu_XsubC mul1n subr0 coefXn eqxx mulr1 (muNroot pa). -Qed. - -Lemma tail_coefE p: tail_coef p = (head 0 (filter0 p)). -Proof. -have [-> |] := (eqVneq p 0); first by rewrite /tail_coef mu0 coef0 polyseq0 /=. -move /(mu_spec_supp) => [q [pa pb pc pd pe]]; rewrite /filter0. -case (eqVneq q 0) => qnz; first by move: pb; rewrite qnz root0. -have q0nz: q`_0 != 0 by rewrite - horner_coef0. -rewrite pd pe pa polyseqMXn// -cat_nseq filter_cat (eq_in_filter (a2 := pred0)). - by rewrite filter_pred0 cat0s nth0; move: q0nz; case q; case => //= a l _ ->. -have /allP h: all (pred1 (0:R)) (nseq (\mu_0 p) 0). - by rewrite all_pred1_nseq. -by move => x /h /= ->. -Qed. - -Fixpoint changes (s : seq R) : nat := - (if s is a :: q then (a * (head 0 q) < 0)%R + changes q else 0)%N. -Definition schange (l: seq R) := changes (filter0 l). - -Lemma schange_sgr l: schange l = schange [seq sgr z | z <- l]. -Proof. -rewrite /schange /filter0 filter_map; set s1 := [seq z <- l | z != 0]. -set s := (filter (preim _ _)); have -> : s l = s1. - apply: eq_in_filter => x xl /=. - by rewrite sgr_def; case xz: (x!=0); rewrite ?mulr0n ?eqxx ?mulr1n ?signr_eq0. -elim: s1 => [ // | a l1 /= ->]; case l1 => /=; first by rewrite !mulr0. -by move => b l2; rewrite - sgrM sgr_lt0. -Qed. - -Lemma schange_deriv p (s := (schange p)) (s':= schange p^`()): - (s = s' \/ s = s'.+1). -Proof. -rewrite /s/s'. -have [-> | pnz] := (eqVneq p 0); first by rewrite deriv0; left. -move: pnz; rewrite - size_poly_gt0 => pz. -have eq: polyseq p = p`_0 :: behead p by move: pz; case p => q /=; case q => //. -have aux: forall i, p^`()`_i = (nth 0 (behead p)) i *+ i.+1. - by move => i; rewrite coef_deriv nth_behead. -rewrite schange_sgr (schange_sgr p^`()). -have <-: [seq Num.sg z | z <- (behead p)] = [seq Num.sg z | z <- p^`()]. - have aux1: size (behead p) = size p^`() by rewrite size_deriv {2} eq. - apply: (eq_from_nth (x0 :=0)); first by rewrite !size_map. - move => i; rewrite size_map => iz;rewrite (nth_map 0)// (nth_map 0) -?aux1//. - by rewrite coef_deriv nth_behead sgrMn mul1r. -rewrite eq /= /schange/filter0/filter;case h: (Num.sg p`_0 != 0); last by left. -simpl; case h': (_ < 0); [ by rewrite addSn; right | by left]. -Qed. - -Lemma schange0_odd l: last 0 l != 0 -> - odd (schange l + (0 < head 0 (filter0 l) * last 0 l)%R). -Proof. -rewrite /schange. -have -> : filter0 l = [seq z <- 0::l | z != 0]. - by rewrite /filter0 {2} /filter eqxx. -rewrite (lastI 0 l); set b := (last 0 l) => bnz; rewrite filter_rcons bnz. -set s := [seq z <- belast 0 l | z != 0]. -have: all (fun z => z != 0) s by apply : filter_all. -elim: s; first by rewrite /= mulr0 ltxx square_pos //. -move => c s /=; set C:= changes _; set d:= head 0 _ => hr /andP [cnz etc]. -have dnz: d != 0 by move: etc; rewrite /d; case s => // s' l' /= /andP []. -rewrite addnC addnA addnC; move: (hr etc). -rewrite -sgr_gt0 - (sgr_gt0 (c*b)) - sgr_lt0 ! sgrM. -rewrite /sgr - if_neg - (if_neg (c==0))- (if_neg (b==0)) bnz dnz cnz. -by case: (d<0); case: (b<0); case: (c<0); rewrite ?mulrNN ? mulr1 ?mul1r ?ltr01 - ?ltrN10 ? ltr10 ? ltr0N1 ?addn0 ? addnS ?addn0//=; move => ->. -Qed. - -Lemma schange_odd p: p != 0 -> odd (schange p + (0 < lead_tail_coef p)%R). -Proof. -rewrite - lead_coef_eq0 /lead_tail_coef tail_coefE /schange lead_coefE nth_last. -by move => h; rewrite schange0_odd. -Qed. -End SignChange. - - -Section SignChangeRcf. -Variable R :rcfType. -Implicit Type (p:{poly R}). - -(* TODO(rei): same as desc1.v?! *) -Lemma noproots_cs p: (forall x, 0 ~~ root p x) -> 0 < lead_tail_coef p. -Proof. -move => h. -have [pz |pnz]:= (eqVneq p 0); first by move: (h _ ltr01); rewrite pz root0. -move: (mu_spec_supp pnz) => [q [pa pb pc pd pe]]. -have: {in `[0, +oo[, (forall x, ~~ root q x)}. - move=> x; rewrite in_itv/= andbT le0r; case/orP; first by move=>/eqP ->. - by move /h; rewrite pa rootM negb_or => /andP []. -move/sgp_pinftyP => ha; move: (ha 0). -rewrite in_itv/= lexx /= => H. -rewrite /lead_tail_coef pc pd pe - sgr_gt0 sgrM -/(sgp_pinfty q). -by rewrite - horner_coef0 - H // - sgrM sgr_gt0 lt0r sqr_ge0 mulf_neq0. -Qed. - -Definition fact_list p s q := - [/\ p = (\prod_(z <- s) ('X - z.1%:P) ^+ (z.2)) * q, - (all (fun z => 0 < z) [seq z.1 | z <- s]), - (sorted <%R [seq z.1 | z <- s]) & - (all (fun z => (0 (forall x, 0 ~~ root (sq.2) x)) - /\ (p = 0 -> sq.1 = [::] /\ sq.2 = 0)) }. -Proof. -case pnz: (p != 0); last first. - by exists ([::],p) => //; split => //; rewrite big_nil mul1r. -pose sa := [seq z <- rootsR p | 0 a. -have pa: (all (fun z => 0 < z) [seq z.1 | z <- sb]). - by rewrite - sav; apply /allP => x; rewrite mem_filter => /andP []. -have pb : (sorted <%R [seq z.1 | z <- sb]). - rewrite - sav. - by apply: sorted_filter => //; [apply: lt_trans |apply: sorted_roots]. -have pc: (all (fun z => (0 x /mapP [t] /mapP [z]; rewrite mem_filter => /andP [z0 z2]. - move => -> -> /=; rewrite mu_gt0 //; apply: (root_roots z2). -suff: { q | p = (\prod_(z <- sa) ('X - z%:P) ^+ (\mu_z p)) * q & - forall x : R, 0 < x -> ~~ root q x}. - move => [q qa qb]; exists (sb,q) => //. - split => //;rewrite qa /= big_map; congr (_ * _); apply eq_big. - by split => // pz; move: pnz; rewrite pz eqxx. -clear sb sav pa pb pc. -have: all (root p) sa. - apply/allP=> x;rewrite mem_filter =>/andP [_]; apply /root_roots. -have: uniq sa by apply:filter_uniq; apply: uniq_roots. -have: forall x, root p x -> 0 < x -> (x \in sa). - by move=> x rx xp;rewrite mem_filter xp -(roots_on_rootsR pnz) rx. -move: sa=> s. -elim: s p pnz=>[p _ H _ _| ]. - exists p; first by by rewrite big_nil mul1r. - move => x xp;apply/negP =>nr; by move: (H _ nr xp). -move => a l Hrec /= p p0 rp /andP [nal ul] /andP [ap rap]. -have [q rqa pv] := (mu_spec a p0). -case q0: (q != 0); last by move:p0; rewrite pv (eqP(negbFE q0)) mul0r eqxx. -have q1 x: root q x -> 0 < x -> x \in l. - move=> rx xp; case xa: (x == a); first by rewrite -(eqP xa) rx in rqa. - by rewrite -[_ \in _]orFb -xa -in_cons rp // pv rootM rx. -have q2: all (root q) l. - apply/allP=> x xl. - case xa: (x ==a); first by move: nal; rewrite - (eqP xa) xl. - move /(allP rap): xl. - by rewrite pv rootM -[\mu__ _]prednK ?mu_gt0 // root_exp_XsubC xa orbF. -have [r qv rq]:= (Hrec q q0 q1 ul q2). -exists r => //; rewrite {1} pv {1} qv mulrAC; congr (_ * _). -rewrite big_cons mulrC; congr (_ * _). -rewrite (big_nth 0). -rewrite [RHS](big_nth 0). -rewrite 2! big_mkord; apply: eq_bigr => i _. -set b := l`_i;congr (_ ^+ _). -have rb: root q b by apply /(allP q2); rewrite mem_nth //. -have nr: ~~ root (('X - a%:P) ^+ \mu_a p) b. - rewrite /root horner_exp !hornerE expf_neq0 // subr_eq0; apply /eqP => ab. - by move: rqa; rewrite - ab rb. -rewrite pv mu_mul ? (muNroot nr) // ?addn0//. -by rewrite mulf_neq0 // expf_neq0 // monic_neq0 // monicXsubC. -Qed. - -Definition pos_roots p := (s2val (poly_split_fact p)).1. -Definition pos_cofactor p := (s2val (poly_split_fact p)).2. -Definition npos_roots p := (\sum_(i <- (pos_roots p)) (i.2))%N. - -Lemma pos_split1 p (s := pos_roots p) (q:= pos_cofactor p): - p != 0 -> [/\ fact_list p s q, (forall x, 0 ~~ root q x) & q != 0]. -Proof. -move => h; rewrite /s/q /pos_roots / pos_cofactor. -move: (poly_split_fact p) => H; move: (s2valP' H) (s2valP H) => [h1 _] h2. -split => //; first by apply: h1. -by apply/eqP => qz; move:h2 => [] pv; move: h; rewrite {1} pv qz mulr0 eqxx. -Qed. - -Lemma monicXsubCe (c:R) i : ('X - c%:P) ^+ i \is monic. -Proof. apply:monic_exp; exact: monicXsubC. Qed. - -Lemma monic_prod_XsubCe I rI (P : pred I) (F : I -> R) (G : I -> nat): - \prod_(i <- rI | P i) ('X - (F i)%:P )^+ (G i) \is monic. -Proof. by apply: monic_prod => i _; exact: monicXsubCe. Qed. - -Lemma npos_root_parity p: p != 0 -> - odd (npos_roots p + (0< lead_tail_coef p)%R). -Proof. -move => pnz; move: (pos_split1 pnz) => [[pv pb pc] pd qp qnz]. -rewrite {2} pv;set r := \prod_(z <- _) _. -have rm: r \is monic by apply:monic_prod_XsubCe. -rewrite lead_tail_coefM (pmulr_lgt0 _ (noproots_cs qp)) /lead_tail_coef. -move: (refl_equal (sgr r`_0)); rewrite - {2} horner_coef0 horner_prod. -set X := \prod_(z <- _) _; have ->: X = \prod_(i <- pos_roots p) (- i.1)^+ i.2. - by apply: eq_big => // i _; rewrite horner_exp hornerXsubC sub0r. -have ->: Num.sg (\prod_(i <- pos_roots p) (- i.1) ^+ i.2) = - (-1) ^+ \sum_(i <- pos_roots p) (i.2). - move: pb; elim (pos_roots p) => [ _ | i rr /= Hr /andP [pa pb]]. - by rewrite !big_nil sgr1. - by rewrite !big_cons sgrM sgrX Hr // sgrN (gtr0_sg pa) exprD. -move => aux. -case (eqVneq r`_0 0) => nr0. - by move: aux; rewrite nr0 sgr0 => /eqP; rewrite eq_sym signr_eq0. -rewrite (eqP rm) mulr1 (tail_coef0b nr0) -sgr_gt0 aux - signr_odd signr_gt0. -by case h: (odd(npos_roots p)); [ rewrite addn0 | rewrite addn1 /= h]. -Qed. - -Lemma size_prod_XsubCe I rI (F : I -> R) (G : I -> nat) : - size (\prod_(i <- rI) ('X - (F i)%:P)^+ (G i)) = - (\sum_(i <- rI) (G i)).+1. -Proof. -elim: rI => [| i r /=]; rewrite ? big_nil ? size_poly1 // !big_cons. -rewrite size_monicM ? monicXsubCe ? monic_neq0 // ?monic_prod_XsubCe //. -by rewrite size_exp_XsubC => ->; rewrite addSn addnS. -Qed. - -Lemma schange_parity p: p != 0 -> odd (npos_roots p) = odd (schange p). -Proof. -move => pnz. -move: (npos_root_parity pnz) (schange_odd pnz). -case h: (0 < lead_tail_coef p)%R; last by rewrite !addn0 => ->. -by rewrite ! addn1 /= => /negbTE -> /negbTE ->. -Qed. - -Lemma pos_split_deg p: p != 0 -> - size p = ((npos_roots p) + (size (pos_cofactor p))) %N. -Proof. -move /pos_split1 => [[pa _ _ ] _ _ pb]. -by rewrite {1} pa size_monicM // ? monic_prod_XsubCe // size_prod_XsubCe addSn. -Qed. - - -Lemma npos_roots0 p: (p != 0 /\ p^`() != 0) \/ (npos_roots p = 0)%N. -Proof. -case (eqVneq p 0) => pnz. - right; rewrite /npos_roots /pos_roots. - move: (poly_split_fact p) => H; move: (s2valP' H) (s2valP H) => [_ h1] _. - by rewrite (proj1 (h1 pnz)) // big_nil. -move: (pos_split1 pnz) => [[pa pb pc pd] pe pf]. -case (leqP (size p) 1%N) => sp; [right | left]. - move: pf sp; rewrite (pos_split_deg pnz) - size_poly_gt0. - case: (size (pos_cofactor p)) => //. - by move => m _; rewrite addnS ltnS leqn0 addn_eq0 => /andP [/eqP -> _]. -split => //. -by rewrite -size_poly_eq0 (size_deriv p); move: sp;case: (size p)=> //; case. -Qed. - -Lemma coprimep_prod p I l (F: I-> {poly R}): - (all (fun z => coprimep p (F z)) l) -> coprimep p (\prod_(z <- l) (F z)). -Proof. -elim l; first by rewrite big_nil /= coprimep1. -by move => b m Hrec /andP [ap /Hrec]; rewrite big_cons coprimepMr ap => ->. -Qed. - -Lemma Gauss_dvdp_prod p (I:eqType) (l: seq I) (F: I-> {poly R}): - (all (fun i => (F i) %| p) l) -> - (uniq [seq F i | i <- l]) -> - (forall i j, i \in l -> j \in l -> (i == j) || coprimep (F i) (F j)) -> - \prod_(i <- l) (F i) %| p. -Proof. -move: p; elim: l. - by move => p _ _ _; rewrite big_nil dvd1p. -move => a l Hrec p /= /andP [ap dr] /andP [al ul] etc. -have aa: coprimep (F a) (\prod_(j <- l) F j). - apply: coprimep_prod; apply /allP => x xl. - have xal: x \in a :: l by rewrite inE xl orbT. - have aa: F x \in [seq F i | i <- l] by apply/mapP; exists x. - by move: al;case/orP: (etc _ _ (mem_head a l) xal)=> // /eqP ->; rewrite aa. -rewrite big_cons Gauss_dvdp // ap /= Hrec // => i j il jl. -by apply: etc; rewrite inE ? il ? jl orbT. -Qed. - -Lemma Gauss_dvdp_prod2 p (l: seq (R * nat)): - (all (fun z => ('X - z.1%:P)^+ (z.2) %| p) l) -> - (uniq [seq z.1 | z <- l]) -> - \prod_(i <- l) ('X - i.1%:P)^+ (i.2) %| p. -Proof. -move => pa pb. -set l2:= [seq z <- l | z.2 != 0%N]. -have qc: all (fun z => z.2 !=0%N) l2 by apply: filter_all. -have qa:all (fun z => ('X - (z.1)%:P) ^+ z.2 %| p) l2. - by apply /allP => x; rewrite mem_filter => /andP [_] /(allP pa). -have qb: uniq [seq z.1 | z <- l2]. - move: pb;rewrite /l2; elim l => [|x s IHs] //= /andP [Hx Hs]. - case (x.2 == 0%N); rewrite /= IHs // andbT; apply /negP. - move /mapP => [y]; rewrite mem_filter => /andP [_ ys] xy. - move: Hx; rewrite xy; move/negP;case; apply /mapP; exists y => //. -have ->: \prod_(i <- l) ('X - (i.1)%:P) ^+ i.2 = - \prod_(i <- l2) ('X - (i.1)%:P) ^+ i.2. - rewrite big_filter [X in _ = X] big_mkcond /=; apply: eq_bigr => i _. - by case h: (i.2 == 0%N) => //=; rewrite (eqP h) expr0. -apply:Gauss_dvdp_prod => //. - rewrite map_inj_in_uniq. apply: (map_uniq qb). - move => i j il jl /= eq1. - rewrite (surjective_pairing i) (surjective_pairing j). - move: (size_exp_XsubC i.2 (i.1)); rewrite eq1 size_exp_XsubC. - move /eq_add_S => ->. - have: root (('X - (i.1)%:P) ^+ i.2) (i.1). - move: (allP qc _ il); rewrite -lt0n => /prednK <-. - by rewrite root_exp_XsubC eqxx. - rewrite eq1; move: (allP qc _ jl); rewrite -lt0n => /prednK <-. - by rewrite root_exp_XsubC => /eqP ->. -move => i j il2 jl2. -pose zz:(R * nat) := (0, 0%N). -move: (nth_index zz il2)(nth_index zz jl2). -move: il2 jl2; rewrite -(index_mem) -(index_mem). -set i1 := index i l2; set j1 := index j l2 => ra rb rc rd. -set l3 := [seq z.1 | z <- l2]. -have ss: size l2 = size l3 by rewrite /l3 size_map. -move: (ra) (rb);rewrite ss => ra' rb'. -move: (nth_uniq 0 ra' rb' qb) => aux. -case eqq: (i1 == j1). by rewrite - rc - rd (eqP eqq) eqxx. -apply /orP; right. -rewrite coprimep_expl // coprimep_expr // coprimep_XsubC root_XsubC. -by rewrite - rc - rd -(nth_map zz 0) // -(nth_map zz 0) // -/l3 eq_sym aux eqq. -Qed. - -Lemma sorted_prop (s: seq R) i j: sorted <%R s -> - (i < size s)%N -> (j < size s)%N -> (i < j)%N -> s`_i < s`_j. -Proof. -move: i j; elim: s => // a l Hrec i j /= pal; case: i; last first. - move => i il; case: j => // j jl /=; rewrite ltnS; apply: Hrec => //. - apply: (path_sorted pal). -clear Hrec; case: j => // j _ jl _;move: a j jl pal. -elim:l => // a l Hrec b j /=;case: j => [_ | j jl]; move /andP => [pa pb] //=. -by apply:(lt_trans pa); apply /Hrec. -Qed. - -Lemma pos_root_deriv p: ((npos_roots p) <= (npos_roots p^`()).+1) %N. -Proof. -case (npos_roots0 p); last by move => ->. -move => [pnz dnz]. -move: (pos_split1 pnz) => [[pa pb pc pd] pe pf]. -set s := pos_roots p; set q := pos_cofactor p. -move: (erefl (pos_roots p)); rewrite -{2} /s; case s. - by rewrite /npos_roots;move => ->; rewrite big_nil. -move=> a l eq1. -set r:= [seq z.1 | z <- s]; set r1:= a.1; set rs:= [seq z.1 | z <- l]. -set rd:= [seq z.2 | z <- pos_roots p]. -have ss: size s = (size l).+1 by rewrite /s eq1. -pose zz:(R * nat) := (0, 0%N). -have p0: forall i, (i < size s)%N -> (nth zz s i).2 \in rd. - move => i qis; apply /mapP; exists (nth zz s i)=> //. - by apply /(nthP zz); exists i. -have p1: forall i: 'I_(size l)%N, - {c : R | c \in `] ((r1::rs)`_i), (rs`_i)[ & (p^`()).[c] = 0}. - move: pc;rewrite eq1 /=; move /(pathP 0); rewrite size_map => h. - move => [i isl]; move: (h _ isl); rewrite -/r1 -/rs => lt1. - have ha: forall j, (j< size s)%N -> (root p (r1 :: rs)`_j). - move => j js; rewrite pa rootM /root horner_prod; apply /orP; left. - rewrite (big_nth zz) big_mkord -/s (bigD1 (Ordinal js)) //= {1} /s eq1 /=. - rewrite horner_exp hornerXsubC -(nth_map _ 0) /= -?ss // subrr expr0n. - by rewrite (gtn_eqF (allP pd _ (p0 _ js))) mul0r eqxx. - have rp: p.[(a.1 :: rs)`_i] = p.[rs`_i]. - have ->: rs`_i = (r1 :: rs)`_(i.+1) by []. - by rewrite (eqP (ha _ _ )) ? (eqP (ha _ _ )) //; rewrite ss ltnS // ltnW. - exact: (rolle lt1 rp). -set l2 := [seq (s2val (p1 i), 1%N) | i <- (enum 'I_(size l)) ]. -set l3 := [seq (z.1, z.2.-1) | z <- pos_roots p]. -set f2 := \prod_(z <- l2) ('X - (z.1)%:P) ^+ (z.2). -set f3 := \prod_(z <- l3) ('X - (z.1)%:P) ^+ (z.2). -have p2: forall t, (t < size s)%N -> (r1 :: rs)`_t = (nth zz s t).1. - by move => t ts; rewrite - (nth_map zz 0) // /s eq1. -have ->: (npos_roots p = (\sum_(i <- l2++l3)i.2).+1)%N. - rewrite big_cat - addSn /l3 /l2 ! big_map sum1_card cardE size_enum_ord - ss. - rewrite - (sum1_size s) -/s - big_split /=. - rewrite /npos_roots ! (big_nth zz) ! big_mkord; apply: eq_bigr. - by move => [i iv] _; rewrite add1n (prednK (allP pd _ (p0 _ iv))). -have p4: (all (fun z => 0 < z) [seq z0.1 | z0 <- l2 ++ l3]). - have aa: forall t, t \in s -> 0 < t.1. - by move => t ts; apply: (allP pb); apply /mapP; exists t. - apply /allP => x /mapP [y]; rewrite mem_cat => /orP []; last first. - by move/mapP => [t /aa h -> ->]. - move/mapP => [t] _ -> -> /=; move: (s2valP (p1 t)). - rewrite itv_boundlr => /= /andP [lt1 _]; apply: lt_trans lt1. - have ts: (t < size s)%N by rewrite /s eq1 /= ltnS ltnW. - by rewrite (p2 _ ts); apply: aa;rewrite mem_nth. -have pcc: forall i j, (i (j (nth zz s i).1 < (nth zz s j).1 -> (i < j)%N. - move => i j il jl;case (ltngtP j i) => //; last by move => ->; rewrite ltxx. - rewrite - (lt_asym (nth zz s i).1 (nth zz s j).1); move => ij -> /=. - move: pc;rewrite -p2 // - p2 // eq1; set s1 := [seq z.1 | z <- a::l] => ha. - have ss1 : size s = size s1 by rewrite /s1 ss size_map. - rewrite ss1 in il jl; exact: (sorted_prop ha jl il ij). -have p5: f3 %| p^`(). - apply:Gauss_dvdp_prod2. - apply /allP => x /mapP [y ys -> /=]. - have: (('X - (y.1)%:P) ^+ y.2) %| p. - rewrite pa; apply:dvdp_mulr. - move: (nth_index zz ys) => h; move: ys; rewrite - index_mem => ys. - by rewrite (big_nth zz) big_mkord (bigD1 (Ordinal ys)) //= h dvdp_mulIl. - move /dvdpP => [q1 ->]; rewrite derivM; apply:dvdp_add;apply:dvdp_mull. - set e := y.2; case e => // n /=; rewrite exprS; apply : dvdp_mulIr. - rewrite deriv_exp - mulrnAl; apply : dvdp_mulIr. - rewrite /l3 -/s -map_comp. - apply: sorted_uniq. - exact: lt_trans. - exact: ltxx. - by apply: pc. -have xx: forall i: 'I_ (size l), - [/\ (i <= size l)%N, (i < size s)%N & (i.+1 < size s)%N]. - by move => i; rewrite ss !ltnS ltnW. -have p6: f2 %| p^`(). - apply:Gauss_dvdp_prod2. - apply/allP => x /mapP [t] _ -> /=; move: (s2valP' (p1 t)). - by rewrite dvdp_XsubCl /root=> ->; rewrite eqxx. - have ->:[seq z.1 | z <- l2] = [seq s2val (p1 i)| i <- enum 'I_(size l)]. - by rewrite /l2 - map_comp. - rewrite map_inj_uniq; first by apply: enum_uniq. - move => i j /= h. - move: (xx i) (xx j)=> [isl1 isl isl2] [jsl1 jsl jsl2]. - apply: val_inj => /=; apply: anti_leq. - move: (s2valP (p1 i)) (s2valP (p1 j)); rewrite !itv_boundlr => /=. - rewrite h; move/andP => [lt1 lt2] /andP [lt3 lt4]. - move: (lt_trans lt1 lt4) (lt_trans lt3 lt2). - have ->: rs`_i = (r1 :: rs)`_(i.+1) by []. - have ->: rs`_j = (r1 :: rs)`_(j.+1) by []. - rewrite !p2 // ? ss ? ltnS //. - move /(pcc _ _ isl jsl2) => sa /(pcc _ _ jsl isl2). - by rewrite ltnS => ->; rewrite -ltnS sa. -have p7: coprimep f2 f3. - apply: coprimep_prod; apply /allP => x xl3. - rewrite coprimep_sym; apply /coprimep_prod; apply /allP => y yl2. - apply:coprimep_expl; apply: coprimep_expr. - rewrite coprimep_XsubC root_XsubC; apply /negP => /eqP. - move: xl3 => /mapP [k ks] -> /=. - rewrite - (nth_index zz ks) -/s; set kis := (index k s). - move: yl2; move /mapP => [i] _ -> /= h1. - move: (s2valP (p1 i)); rewrite !itv_boundlr => /=; rewrite h1; clear h1. - have ->: rs`_i = (r1 :: rs)`_(i.+1) by []. - move: (xx i) => [il0 il1 il2]. - have il3: (kis < size s)%N by rewrite index_mem. - rewrite ! p2 // => /andP [la lb]. - move: (pcc _ _ il1 il3 la) (pcc _ _ il3 il2 lb). - by rewrite ltnS => lc ld; move: (leq_trans lc ld); rewrite ltnn. -have : (f2 * f3) %| p^`() by rewrite Gauss_dvdp // p6 p5. -move /dvdpP => [q1]; rewrite mulrC => sd. -have sa: p^`() = \prod_(z <- l2++l3) ('X - (z.1)%:P) ^+ z.2 * q1. - by rewrite big_cat. -move: (pos_split1 dnz) => [[qa qb qc qd] qe qf]. -set Fa := \prod_(z <- l2 ++l3) ('X - (z.1)%:P) ^+ z.2. -set Fb := \prod_(z <- pos_roots p^`()) ('X - (z.1)%:P) ^+ z.2. -set q2:= pos_cofactor p^`(). -have Fbm: Fb \is monic by apply:monic_prod_XsubCe. -suff cp: coprimep Fa q2. - move: (Gauss_dvdpl Fb cp); rewrite - qa {1} sa dvdp_mulIl => h. - move: (dvdp_leq (monic_neq0 Fbm) (esym h)). - by rewrite /npos_roots ! size_prod_XsubCe. -rewrite/Fa coprimep_sym;apply/coprimep_prod /allP => x xl. -rewrite coprimep_expr// coprimep_XsubC qe //. -by apply (allP p4); apply /mapP; exists x. -Qed. - -Lemma descartes_bis p: p != 0 -> - (odd (npos_roots p) = odd (schange p) /\ - ((npos_roots p) <= (schange p)) %N). -Proof. -move => pa; split; first by apply:schange_parity. -move: p {2}(size p) (leqnn (size p)) pa => p n; move:p; elim:n. - by move => p;rewrite size_poly_leq0 => ->. -move => n Hrec p spn pnz. -move: (schange_parity pnz) => od. -case (npos_roots0 p); [move => [_ dnz] | by move => ->]. -move: (leq_trans (lt_size_deriv pnz) spn); rewrite ltnS=> spln. -move:(Hrec _ spln dnz); rewrite - ltnS => /(leq_trans (pos_root_deriv p)) eq3. -move: od; case (schange_deriv p); move => -> //; move: eq3;set s := schange _. -by rewrite leq_eqVlt ltnS;case /orP => // /eqP -> /=;case (odd _). -Qed. - -End SignChangeRcf. diff --git a/theories/door_crossing.v b/theories/door_crossing.v deleted file mode 100644 index 7067e18..0000000 --- a/theories/door_crossing.v +++ /dev/null @@ -1,1133 +0,0 @@ -From HB Require Import structures. -From mathcomp Require Import all_ssreflect all_algebra all_real_closed archimedean reals. -From mathcomp.algebra_tactics Require Import ring lra. -Require Import casteljau convex counterclockwise intersection. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Import Order.Theory. -Import GRing.Theory. -Import Num.Theory Num.Def. -Local Open Scope ring_scope. - -Section sandbox. - -Lemma poly_coord {R : rcfType} - (c : (R^o * R^o)%type) - (p : {poly R}) (t : R) : - p.[t] *: c = c.1 * p.[t] *: (1, 0) + c.2 * p.[t] *: (0, 1). -Proof. -congr (_, _); rewrite /= !scaler0 ?addr0 ?add0r mulrC /GRing.scale /=; ring. -Qed. - -Variable R : reals.Real.type. - -(* This version differs from the one in the hulls development to avoid - using Program Fixpoint. Here the sequence of control point is given - by a function and the degree is given as argument. *) -Fixpoint bezier (c : nat -> Plane R) (n : nat) (t : R) := - match n with - | 0 => c 0%N - | S p => (1 - t) *: (bezier c p t) + - t *: (bezier (c \o S) p t) - end. - -Definition f3pt (a b c : Plane R) := - [fun n : nat => a with 1%nat |-> b, 2%nat |-> c]. - -Lemma bezier_step_conv c n t : - bezier c (S n) t = - bezier (c \o S) n t <| t |> bezier c n t. -Proof. by rewrite /= /conv addrC. Qed. - -(* TODO: complain about the wrong error message for the following mistake. *) -(* Lemma bezier_bernstein2 c t : - bezier c 2 t = (bernp 0 1 2 0) *: c 0%N. *) - -Lemma bezier_bernstein2 c t : - bezier c 2 t = - \sum_(i < 3) (bernp 0 1 2 i).[t] *: c i. -Proof. -rewrite !big_ord_recr big_ord0 /= add0r. -rewrite /= scalerDr scalerA -!addrA; congr (_ *: _ + _). - by rewrite /bernp !hornerE /= subr0 expr1n invr1; ring. -rewrite !(scalerA, scalerDr) addrA -scalerDl; congr (_ *:_ + _ *: _). - by rewrite /bernp !hornerE /= subr0 expr1n invr1; ring. -by rewrite /bernp !hornerE /= subr0 expr1n invr1; ring. -Qed. - -(* The proofs of these lemmas follow a general pattern explained in file - casteljau. However, here, we can brute force the proof because we are - working with a known low degree. *) -Lemma bezier2_dichotomy_l (c : nat -> Plane R) (t u : R) : - bezier c 2 (t * u) = - bezier (f3pt (c 0%nat) (bezier c 1 u) (bezier c 2 u)) 2 t. -Proof. -rewrite /bezier /= !scalerDr !scalerA !addrA. -(* Make sure all instance of c 0 are grouped on the left and c 0 is - factored out. *) -rewrite !(addrAC _ (_ *: c (S O)) (_ *: c O)) -!scalerDl. -rewrite -!addrA; congr (_ *: _ + _); first by ring. -(* Now factor out all instances of c 1. *) -rewrite !addrA -!scalerDl; congr (_ *: _ + _ *: _); ring. -Qed. - -Lemma bezier2_dichotomy_r (c : nat -> Plane R) (t u : R) : - bezier c 2 (u + t * (1 - u)) = - bezier (f3pt (bezier c 2 u) (bezier (c \o S) 1 u) (c 2%nat)) 2 t. -Proof. -rewrite /bezier /= !scalerDr !scalerA !addrA. -(* There is only one instance of c 0 on the left, we can process it directly *) -rewrite -!addrA; congr (_ *: _ + _); first by ring. -rewrite !addrA -!scalerDl. -rewrite !(addrAC _ (_ *: c (S (S _))) (_ *: c (S O))) -!scalerDl. -rewrite -!addrA -!scalerDl. -congr (_ *: _ + _ *: _); ring. -Qed. - -Record edge := Bedge - { left_pt : Plane R; - right_pt : Plane R; - edge_cond : left_pt.1 < right_pt.1}. - -Record cell := - { left_pts : seq (Plane R); - right_pts : seq (Plane R); - low : edge; high : edge}. - -Definition valid_edge : edge -> Plane R -> bool := - fun g p => (left_pt g).1 <= p.1 <= (right_pt g).1. - -Definition point_on_edge (p : Plane R) (g : edge) := - valid_edge g p && (det (left_pt g) (right_pt g) p == 0). - -Notation "p '===' e" := (point_on_edge p e)( at level 70, no associativity). - -Definition dummy_pt : Plane R := (0, 0). - -Definition closed_cell_side_limit_ok c := - [&& left_pts c != [::], - all (fun p => p.1 == (last dummy_pt (left_pts c)).1) (left_pts c), - sorted >%R [seq p.2 | p <- left_pts c], - head dummy_pt (left_pts c) === high c, - last dummy_pt (left_pts c) === low c, - right_pts c != [::], - all (fun p => p.1 == (head dummy_pt (right_pts c)).1) (right_pts c), - sorted <%R [seq p.2 | p <- right_pts c], - head dummy_pt (right_pts c) === low c & - last dummy_pt (right_pts c) === high c]. - -Definition left_limit (c : cell) := (last dummy_pt (left_pts c)).1. - -Definition right_limit c := (last dummy_pt (right_pts c)).1. - -Definition point_under_edge (p : Plane R) (e : edge) : bool := - det p (left_pt e) (right_pt e) <= 0. - - (* returns true if p is strictly under e *) -Definition point_strictly_under_edge (p : Plane R) (e : edge) : bool := - det p (left_pt e) (right_pt e) < 0. - -Notation "p '<<=' e" := (point_under_edge p e)( at level 70, no associativity). -Notation "p '<<<' e" := (point_strictly_under_edge p e) - (at level 70, no associativity). - -Definition strict_inside_closed (p : Plane R) (c : cell) := - (p <<< high c) && (~~(p <<= low c)) && - (left_limit c < p.1 < right_limit c). - -Definition bottom_left_corner (c : cell) := last dummy_pt (left_pts c). - -Record vert_edge := { ve_x : R; ve_top : R; ve_bot : R}. - -Definition vert_edge_eqb (v1 v2 : vert_edge) := - let: Build_vert_edge v1x v1t v1b := v1 in - let: Build_vert_edge v2x v2t v2b := v2 in - (v1x == v2x) && (v1t == v2t) && (v1b == v2b). - -Lemma vert_edge_eqP : Equality.axiom vert_edge_eqb. -Proof. -move=> [vxa vta vba] [vxb vtb vbb] /=. -have [/eqP <-|/eqP anb] := boolP(vxa == vxb). - have [/eqP <-|/eqP anb] := boolP(vta == vtb). - have [/eqP <-| /eqP anb] := boolP(vba == vbb). - by apply:ReflectT. - by apply: ReflectF=> [] []. - by apply: ReflectF=> [] []. -by apply: ReflectF=> [] []. -Qed. - -Fail Check (fun (x : vert_edge) (l : seq vert_edge) => x \in l). - -HB.instance Definition _ := hasDecEq.Build _ vert_edge_eqP. - -Fixpoint seq_to_intervals_aux [A : Type] (a : A) (s : seq A) := -match s with -| nil => nil -| b :: tl => (a, b) :: seq_to_intervals_aux b tl -end. - -Definition seq_to_intervals [A : Type] (s : seq A) := -match s with - nil => nil -| a :: tl => seq_to_intervals_aux a tl -end. - -Definition cell_safe_exits_left (c : cell) : seq vert_edge := - let lx := (seq.head dummy_pt (left_pts c)).1 in - map (fun p => Build_vert_edge lx (p.1).2 (p.2).2) - (seq_to_intervals (left_pts c)). - -Definition cell_safe_exits_right (c : cell) : seq vert_edge := - let lx := (seq.head dummy_pt (right_pts c)).1 in - map (fun p => Build_vert_edge lx (p.1).2 (p.2).2) - (seq_to_intervals (rev (right_pts c))). - -Definition dummy_vert_edge := - {| ve_x := 0; ve_top := 0; ve_bot := 0|}. - -Definition on_vert_edge (p : Plane R) (v : vert_edge) : bool := - (p.1 == ve_x v) && (ve_bot v < p.2 < ve_top v). - -Check fun (v : vert_edge) (l : seq vert_edge) => v \in l. -Check fun (v : vert_edge)(c : cell) => - v \in cell_safe_exits_left c. - -Lemma detDM2 (l p1 p2 q1 q2 r1 r2 : R) : - l * det (p1, p2) (q1, q2) (r1, r2) = - det (p1, p2) (p1 + l * (q1 - p1), p2 + l * (q2 - p2)) (r1, r2). -Proof. by rewrite !develop_det /xcoord /ycoord /=; ring. Qed. - -Lemma detDM1 (l p1 p2 q1 q2 r1 r2 : R) : - l * det (p1, p2) (q1, q2) (r1, r2) = - det (q1 + l * (p1 - q1), q2 + l * (p2 - q2)) (q1, q2) (r1, r2). -Proof. by rewrite !develop_det /xcoord /ycoord /=; ring. Qed. - -Lemma detDM3 (l p1 p2 q1 q2 r1 r2 : R) : -det (p1, p2) (q1, q2) (r1, r2) = -det (p1, p2) (q1, q2) (r1 + l * (q1 - p1), r2 + l * (q2 - p2)). -Proof. by rewrite !develop_det /xcoord /ycoord /=; ring. Qed. - -Lemma detVert (p1 p2 q1 q2 r2 : R) : - det (p1, p2) (q1, q2) (q1, r2) = - (r2 - q2) * (q1 - p1). -Proof. rewrite !develop_det /xcoord /ycoord /=; ring. Qed. - -Lemma bezier1_conv c t : bezier c 1 t = c 0%nat <| (1 - t) |> c 1%nat. -Proof. rewrite /= /conv; congr (_ *: _ + _ *: _); ring. Qed. - -Lemma left_vertical_edge_wrt_high c v : - left_limit c < right_limit c -> - closed_cell_side_limit_ok c -> - v \in cell_safe_exits_left c -> - (ve_top v <= (head dummy_pt (left_pts c)).2) && - ((left_pt (high c)).1 <= ve_x v < (right_pt (high c)).1) && - (ve_x v == (head dummy_pt (left_pts c)).1). -Proof. -move=> llr /andP[] leftn0 /andP[] /allP samexl /andP[] sortl. -move=> /andP[] lonh /andP[] lonl. -move=> /andP[] rightn0 /andP[] /allP samexr /andP[] sortr /andP[] ronl ronh vin. -have {}samexl : - {in left_pts c, forall p, (head dummy_pt (left_pts c)).1 = p.1 }. - move=> x xin; rewrite (eqP (samexl x xin)). - rewrite -(eqP (samexl (head dummy_pt (left_pts c)) _)) //. - by move: leftn0; case (left_pts c)=> //= s l _; rewrite inE eqxx. -have vxleft : ve_x v = left_limit c. - move: vin. - rewrite /left_limit /cell_safe_exits_left. - elim: (left_pts c) leftn0 samexl => [ // | e1 [// | e2 tl] Ih] _ /= samexl. - rewrite inE=> /orP[/eqP -> /= | vin]. - by apply: samexl; rewrite inE mem_last orbT. - apply: (Ih isT)=> /=. - move=> x xin. rewrite -(samexl e2); last by rewrite !inE eqxx orbT. - by apply: samexl; rewrite inE xin orbT. - by rewrite -(samexl e2) //; rewrite !inE eqxx orbT. -apply/andP; split; last first. - rewrite vxleft /left_limit (samexl (last dummy_pt (left_pts c))) //. - by case: (left_pts c) leftn0=> [// | ? ?]; rewrite /= mem_last. -move: llr. -rewrite vxleft /left_limit -(samexl (last dummy_pt (left_pts c))); last first. - by case: (left_pts c) leftn0 => //= a tl _ ; rewrite mem_last. -move: lonh=> /andP[] /andP[] -> /= _ _ llr. -rewrite (lt_le_trans llr) ?andbT; last first. - by rewrite /right_limit; move: ronh=> /andP[] /andP[] _ ->. -move: vin; rewrite /cell_safe_exits_left. -elim: (left_pts c) leftn0 sortl samexl - => [// | e1 [ // | e2 tl] /(_ isT) Ih] _ /= /andP[] cmp s samexl. -rewrite inE=> /orP[/eqP -> // | vin ]. -apply: (le_trans _ (ltW cmp)). -apply Ih=> //=. - move=> x xin. - by rewrite -(samexl e2) ?inE ?eqxx ?orbT // (samexl x) // inE xin orbT. -by rewrite -(samexl e2) // !inE eqxx orbT. -Qed. - -Lemma seq_to_intervals_rcons [A : Type](e1 e2 : A) l : - seq_to_intervals (rcons (rcons l e2) e1) = - rcons (seq_to_intervals (rcons l e2)) (e2, e1). -Proof. by elim: l => [// | e3 [// | e4 l] /= Ih] //; rewrite Ih. Qed. - -Lemma right_vertical_edge_wrt_high c v : - left_limit c < right_limit c -> - closed_cell_side_limit_ok c -> - v \in cell_safe_exits_right c -> - (ve_top v <= (last dummy_pt (right_pts c)).2) && - ((left_pt (high c)).1 < ve_x v <= (right_pt (high c)).1) && - (ve_x v == (last dummy_pt (right_pts c)).1). -Proof. -move=> llr /andP[] leftn0 /andP[] /allP samexl /andP[] sortl. -move=>/andP[] lonh /andP[] lonl. -move=> /andP[] rightn0 /andP[] /allP samexr /andP[] sortr /andP[] ronl ronh vin. -have vxright : ve_x v = right_limit c. - move: vin. - rewrite /right_limit /cell_safe_exits_right. - elim/last_ind: (right_pts c) rightn0 samexr => [ // | lh e1 Ih] _ /=. - elim/last_ind: lh Ih => [ // | lh e2 _] Ih samexr. - rewrite last_rcons !rev_rcons/=. - rewrite inE=> /orP[/eqP -> /= | vin]. - by rewrite (eqP (samexr e1 _)) // mem_rcons inE eqxx. - rewrite (eqP (samexr e1 _)); last by rewrite mem_rcons inE eqxx. - rewrite -(eqP (samexr e2 _)); last by rewrite !(mem_rcons, inE) eqxx ?orbT. - rewrite [e2](_ : _ = last dummy_pt (rcons lh e2)); last by rewrite last_rcons. - apply: Ih=> /=. - by case lhq: lh. - move=> x xin. - rewrite (eqP (samexr x _)); last by rewrite mem_rcons inE xin orbT. - by rewrite 3!headI /=. - rewrite - [head _ (rcons _ _)](_ : _ = head dummy_pt (rcons lh e2)) in vin; last first. - by rewrite 3!headI /=. - by rewrite rev_rcons; apply: vin. -apply/andP; split; last by rewrite vxright. -move: llr. -rewrite vxright /right_limit. -move: ronh=> /andP[] /andP[] _ -> /= _ llr. -rewrite (le_lt_trans _ llr) ?andbT; last first. - rewrite /left_limit; move: lonh=> /andP[] /andP[] + _ _. - rewrite (eqP (samexl (head dummy_pt (left_pts c)) _)) //. - by case: (left_pts c) leftn0 => [// | a ?]; rewrite /= inE eqxx. -move: vin; rewrite /cell_safe_exits_right. -elim/last_ind: (right_pts c) rightn0 sortr samexr=> [// | + e1 ]. -elim/last_ind=> [// | l e2 _] Ih _ sortr samexr. -rewrite 2!rev_rcons /= inE last_rcons=> /orP[/eqP -> | vin]; first by []. -have cmp : e2.2 < e1.2. - move: sortr; rewrite -2!cats1 -catA /= map_cat=> /cat_sorted2[_ /=]. - by rewrite andbT. -have {}sortr : sorted <%R [seq p.2 | p <- rcons l e2]. - by move: sortr; rewrite -cats1 map_cat=> /cat_sorted2[]. -apply: (le_trans _ (ltW cmp)). -rewrite [e2](_ : _ = last dummy_pt (rcons l e2)); last by rewrite last_rcons. -apply Ih=> //=. - by case lq : l. - move=> x xin. - have -> : head dummy_pt (rcons l e2) = head dummy_pt (rcons (rcons l e2) e1). - by case lq : l. - by apply: samexr; rewrite mem_rcons inE xin orbT. -have -> : head dummy_pt (rcons l e2) = head dummy_pt (rcons (rcons l e2) e1). - by case lq : l. -by rewrite rev_rcons. -Qed. - -Lemma left_vertical_edge_wrt_low c v : - left_limit c < right_limit c -> - closed_cell_side_limit_ok c -> - v \in cell_safe_exits_left c -> - ((last dummy_pt (left_pts c)).2 <= ve_bot v) && - ((left_pt (low c)).1 <= ve_x v < (right_pt (low c)).1) && - (ve_x v == (last dummy_pt (left_pts c)).1). -Proof. -move=> llr /andP[] leftn0 /andP[] /allP samexl /andP[] sortl. -move=>/andP[] lonh /andP[] lonl. -move=> /andP[] rightn0 /andP[] /allP samexr /andP[] sortr /andP[] ronl ronh vin. -have {}samexl: {in left_pts c, forall p, (head dummy_pt (left_pts c)).1 = p.1 }. - move=> x xin; rewrite (eqP (samexl x xin)). - rewrite -(eqP (samexl (head dummy_pt (left_pts c)) _)) //. - by move: leftn0; case (left_pts c)=> //= s l _; rewrite inE eqxx. -have vxleft : ve_x v = left_limit c. - move: vin. - rewrite /left_limit /cell_safe_exits_left. - elim: (left_pts c) leftn0 samexl => [ // | e1 [// | e2 tl] Ih] _ /= samexl. - rewrite inE=> /orP[/eqP -> /= | vin]. - by apply: samexl; rewrite inE mem_last orbT. - apply: (Ih isT)=> /=. - move=> x xin. rewrite -(samexl e2); last by rewrite !inE eqxx orbT. - by apply: samexl; rewrite inE xin orbT. - by rewrite -(samexl e2) //; rewrite !inE eqxx orbT. -apply/andP; split; last by rewrite vxleft. -move: llr. -rewrite vxleft /left_limit. -move: lonl=> /andP[] /andP[] -> /= _ _ llr. -rewrite (lt_le_trans llr) ?andbT; last first. - rewrite /right_limit; move: ronl=> /andP[] /andP[] _ + _. - rewrite -(eqP (samexr (last dummy_pt (right_pts c)) _)) //. - by move: rightn0; case: (right_pts c)=> [// | ? ?]; rewrite /= mem_last. -move: vin; rewrite /cell_safe_exits_left. -elim: (left_pts c) leftn0 sortl samexl - => [// | e1 [ // | e2 tl] /(_ isT) Ih] _ /= /andP[] cmp s samexl. -rewrite inE=> /orP[/eqP -> /= | vin ]. - have sgt : subrel >%R (>=%R : rel R) by move=> x y /ltW. - have s' : path >=%R e2.2 [seq p.2 | p <- tl]. - by apply: (sub_path sgt). - case tlq : tl => [// | e3 tl']; rewrite -tlq. - move: s'; rewrite path_sortedE; last by apply/rev_trans/le_trans. - move=> /andP[] /allP /(_ (last e2 tl).2) + _; apply. - by apply/mapP; exists (last e2 tl); rewrite // tlq /= mem_last. -apply Ih=> //=. - move=> x xin. - by rewrite -(samexl e2) ?inE ?eqxx ?orbT // (samexl x) // inE xin orbT. -by rewrite -(samexl e2) // !inE eqxx orbT. -Qed. - -Lemma right_vertical_edge_wrt_low c v : - left_limit c < right_limit c -> - closed_cell_side_limit_ok c -> - v \in cell_safe_exits_right c -> - ((head dummy_pt (right_pts c)).2 <= ve_bot v) && - ((left_pt (low c)).1 < ve_x v <= (right_pt (low c)).1) && - (ve_x v == (head dummy_pt (right_pts c)).1). -Proof. -move=> llr /andP[] leftn0 /andP[] /allP samexl /andP[] sortl. -move=>/andP[] lonh /andP[] lonl. -move=> /andP[] rightn0 /andP[] /allP samexr /andP[] sortr /andP[] ronl ronh vin. -have vxright : ve_x v = right_limit c. - move: vin. - rewrite /right_limit /cell_safe_exits_right. - elim/last_ind: (right_pts c) rightn0 samexr => [ // | lh e1 Ih] _ /=. - elim/last_ind: lh Ih => [ // | lh e2 _] Ih samexr. - rewrite last_rcons !rev_rcons/=. - rewrite inE=> /orP[/eqP -> /= | vin]. - by rewrite (eqP (samexr e1 _)) // mem_rcons inE eqxx. - rewrite (eqP (samexr e1 _)); last by rewrite mem_rcons inE eqxx. - rewrite -(eqP (samexr e2 _)); last by rewrite !(mem_rcons, inE) eqxx ?orbT. - rewrite [e2](_ : _ = last dummy_pt (rcons lh e2)); last by rewrite last_rcons. - apply: Ih=> /=. - by case lhq: lh. - move=> x xin. - rewrite (eqP (samexr x _)); last by rewrite mem_rcons inE xin orbT. - by rewrite 3!headI /=. - rewrite [head _ (rcons _ _)] - (_ : _ = head dummy_pt (rcons lh e2)) in vin; last first. - by rewrite 3!headI /=. - by rewrite rev_rcons; apply: vin. -apply/andP; split; last first. - rewrite vxright /right_limit; apply: samexr. - by case: (right_pts c) rightn0=> [// | ? ?]; rewrite /= mem_last. -move: llr. -rewrite vxright /right_limit. -move: ronl=> /andP[] /andP[] _ + _ /=. -rewrite -(eqP (samexr (last dummy_pt (right_pts c)) _)); last first. - by case: (right_pts c) rightn0 => [// | ? ?]; rewrite /= mem_last. -move=> -> xcond; rewrite ?andbT. -rewrite (le_lt_trans _ xcond) ?andbT; last by move: lonl=> /andP[] /andP[]. -move: vin; rewrite /cell_safe_exits_right. -elim/last_ind: (right_pts c) rightn0 sortr samexr=> [// | + e1 ]. -elim/last_ind=> [// | l e2 _] Ih _ sortr samexr. -have cmp : e2.2 < e1.2. - move: sortr; rewrite -2!cats1 -catA /= map_cat=> /cat_sorted2[_ /=]. - by rewrite andbT. -have {}sortr : sorted <%R [seq p.2 | p <- rcons l e2]. - by move: sortr; rewrite -cats1 map_cat=> /cat_sorted2[]. -rewrite [head dummy_pt _](_ : _ = head e2 l); last by rewrite 2!headI /=. -rewrite 2!rev_rcons /= inE => /orP[/eqP -> /= | vin]. - case lq : l => [// | e3 l'] /=. - move: sortr; rewrite lq /= => /(sub_path ltW). - rewrite (path_sortedE le_trans)=> /andP[] /allP + _; apply. - by apply/mapP; exists e2; rewrite // mem_rcons inE eqxx. -rewrite [X in X.2 <= _](_ : _ = head dummy_pt (rcons l e2)); last first. - by case lq: l. -apply Ih=> //=. - by case lq : l. - move=> x xin. - have -> : head dummy_pt (rcons l e2) = head dummy_pt (rcons (rcons l e2) e1). - by case lq : l. - by apply: samexr; rewrite mem_rcons inE xin orbT. -have -> : head dummy_pt (rcons l e2) = head dummy_pt (rcons (rcons l e2) e1). - by case lq : l. -by rewrite rev_rcons 2!headI /=. -Qed. - -Lemma vert_projr (p q r : Plane R) : - p.1 != q.1 -> (det p q r == 0) = - (r.2 == q.2 + (r.1 - q.1) / (q.1 - p.1) * (q.2 - p.2)). -Proof. -case: p q r=> [p1 p2][q1 q2][r1 r2] /=; rewrite develop_det /= => e_cnd. -apply/idP/eqP; last first. - move=> -> /=; rewrite !mulrDl -(opprB q1 p1) !mulrN (mulrAC _ _ (q1 - p1)). - rewrite mulfVK; last by rewrite subr_eq0 eq_sym. - rewrite (mulrAC _ _ (q1 - p1)). - rewrite mulfVK; last by rewrite subr_eq0 eq_sym. - apply/eqP; ring. -rewrite !(addrAC _ (- (r2 * (p1 - q1)))) subr_eq0 eq_sym => /eqP r2Mdf. -have dn0 : (p1 - q1) != 0 by rewrite subr_eq0. -apply: (mulIf dn0); rewrite r2Mdf mulrDl (mulrAC _ _ (p1 - q1)) -(opprB p1 q1). -rewrite invrN !(mulrN, mulNr). -rewrite mulfVK //; ring. -Qed. - -Lemma vert_projl (p q r : Plane R) : - p.1 != q.1 -> (det p q r == 0) = - (r.2 == p.2 + (r.1 - p.1) / (q.1 - p.1) * (q.2 - p.2)). -Proof. -case: p q r=> [p1 p2][q1 q2][r1 r2] /=; rewrite develop_det /= => e_cnd. -apply/idP/eqP; last first. - move=> -> /=; rewrite !mulrDl -(opprB q1 p1) !mulrN (mulrAC _ _ (q1 - p1)). - rewrite mulfVK; last by rewrite subr_eq0 eq_sym. - rewrite (mulrAC _ _ (q1 - p1)). - rewrite mulfVK; last by rewrite subr_eq0 eq_sym. - apply/eqP; ring. -rewrite !(addrAC _ (- (r2 * (p1 - q1)))) subr_eq0 eq_sym => /eqP r2Mdf. -have dn0 : (p1 - q1) != 0 by rewrite subr_eq0. -apply: (mulIf dn0); rewrite r2Mdf mulrDl (mulrAC _ _ (p1 - q1)) -(opprB p1 q1). -rewrite invrN !(mulrN, mulNr). -rewrite mulfVK //; ring. -Qed. - -Lemma on_vert_edge_under_high_left v c p : - left_limit c < right_limit c -> - closed_cell_side_limit_ok c -> - on_vert_edge p v -> - v \in cell_safe_exits_left c -> - p <<< high c. -Proof. -move=> llr cok onv vin. -have /andP[/andP[vtople xcond] xcond2] := - left_vertical_edge_wrt_high llr cok vin. -move: (cok)=> /andP[] leftn0 /andP[] samexl /andP[] sortl /andP[] lonh _. -rewrite /point_strictly_under_edge. -set l := ((right_pt (high c)).1 - p.1) / - ((right_pt (high c)).1 - (left_pt (high c)).1). -set q := ((right_pt (high c)).1 - l * - ((right_pt (high c)).1 - (left_pt (high c)).1), - (right_pt (high c)).1 - l * - ((right_pt (high c)).2 - (left_pt (high c)).2)). -case pq : p => [p1 p2]. -case lq : (left_pt (high c)) => [q1 q2]. -case rq : (right_pt (high c)) => [r1 r2]. -have lv : l = (r1 - p1) / (r1 - q1) by rewrite /l pq rq lq /=. -have p1ltr1 : p1 < r1. - move: onv xcond => /andP[] /eqP + _. - by rewrite lq rq pq /= => -> => /andP[]. -have lgt0 : 0 < l. - rewrite /l divr_gt0 // subr_gt0 ?pq ?lq ?rq //=. - by move: (edge_cond (high c)); rewrite lq rq. -rewrite det_cyclique. -rewrite -(pmulr_rlt0 _ lgt0). -rewrite detDM1 det_cyclique. -have <- : p1 = r1 + l * (q1 - r1). - rewrite lv -(opprB r1 q1) mulrN mulfVK; first by ring. - rewrite subr_eq0; apply/eqP=> abs. - by have := edge_cond (high c); rewrite lq rq abs lt_irreflexive. -rewrite detVert lv. -rewrite nmulr_llt0; last by rewrite subr_lt0. -have proj2: (head dummy_pt (left_pts c)).2 = - r2 + (r1 - p1) / (r1 - q1) * (q2 - r2). - have ecnd : (left_pt (high c)).1 != (right_pt (high c)).1. - by apply/eqP=> abs; have := edge_cond (high c); rewrite abs lt_irreflexive. - have := vert_projr (head dummy_pt (left_pts c)) ecnd. - move: lonh=> /andP[] _ -> => /esym /eqP; rewrite ?pq ?lq ?rq /= => ->. - rewrite -(eqP xcond2); move: onv=>/andP[] /eqP <- _; rewrite pq /=; ring. -rewrite -proj2 subr_gt0. -apply: lt_le_trans vtople. -by move: onv=> /andP[] _ /andP[]; rewrite pq /=. -Qed. - -Lemma on_vert_edge_above_low_left v c p : - left_limit c < right_limit c -> - closed_cell_side_limit_ok c -> - on_vert_edge p v -> - v \in cell_safe_exits_left c -> - ~~ (p <<= low c). -Proof. -move=> llr cok onv vin. -have /andP[/andP[vtople xcond] xcond2] := - left_vertical_edge_wrt_low llr cok vin. -move: (cok)=> /andP[] leftn0 /andP[] samexl /andP[] sortl. -move=>/andP[] _ /andP[] lonl _. -rewrite /point_under_edge -ltNge. -set l := ((right_pt (low c)).1 - p.1) / ((right_pt (low c)).1 - (left_pt (low c)).1). -set q := ((right_pt (low c)).1 - l * ((right_pt (low c)).1 - (left_pt (low c)).1), - (right_pt (low c)).1 - l * ((right_pt (low c)).2 - (left_pt (low c)).2)). -case pq : p => [p1 p2]. -case lq : (left_pt (low c)) => [q1 q2]. -case rq : (right_pt (low c)) => [r1 r2]. -have lv : l = (r1 - p1) / (r1 - q1) by rewrite /l pq rq lq /=. -have p1ltr1 : p1 < r1. - move: onv xcond => /andP[] /eqP + _. - by rewrite lq rq pq /= => -> => /andP[]. -have lgt0 : 0 < l. - rewrite /l divr_gt0 // subr_gt0 ?pq ?lq ?rq //=. - by move: (edge_cond (low c)); rewrite lq rq. -rewrite det_cyclique. -rewrite -(pmulr_rgt0 _ lgt0). -rewrite detDM1 det_cyclique. -have <- : p1 = r1 + l * (q1 - r1). - rewrite lv -(opprB r1 q1) mulrN mulfVK; first by ring. - rewrite subr_eq0; apply/eqP=> abs. - by have := edge_cond (low c); rewrite lq rq abs lt_irreflexive. -rewrite detVert lv. -rewrite nmulr_lgt0; last by rewrite subr_lt0. -have proj2: (last dummy_pt (left_pts c)).2 = r2 + (r1 - p1) / (r1 - q1) * (q2 - r2). - have ecnd : (left_pt (low c)).1 != (right_pt (low c)).1. - by apply/eqP=> abs; have := edge_cond (low c); rewrite abs lt_irreflexive. - have := vert_projr (last dummy_pt (left_pts c)) ecnd. - move: lonl=> /andP[] _ -> => /esym /eqP; rewrite ?pq ?lq ?rq /= => ->. - rewrite -(eqP xcond2); move: onv=>/andP[] /eqP <- _; rewrite pq /=; ring. -rewrite -proj2 subr_lt0. -apply: (le_lt_trans vtople). -by move: onv=> /andP[] _ /andP[]; rewrite pq /=. -Qed. - -Lemma on_vert_edge_under_high_right v c p : - left_limit c < right_limit c -> - closed_cell_side_limit_ok c -> - on_vert_edge p v -> - v \in cell_safe_exits_right c -> - p <<< high c. -Proof. -move=> llr cok onv vin. -have /andP[/andP[vtople xcond] xcond2] := right_vertical_edge_wrt_high llr cok vin. -move: (cok); rewrite /closed_cell_side_limit_ok. -rewrite 4!andbA=> /andP[] _. -move=> /andP[] rightn0 /andP[] samexr /andP[] sortr /andP[] _ ronh. -rewrite /point_strictly_under_edge. -set l := (p.1 - (left_pt (high c)).1) / ((right_pt (high c)).1 - (left_pt (high c)).1). -set q := ((left_pt (high c)).1 + l * ((right_pt (high c)).1 - (left_pt (high c)).1), - (left_pt (high c)).1 + l * ((right_pt (high c)).2 - (left_pt (high c)).2)). -case pq : p => [p1 p2]. -case lq : (left_pt (high c)) => [q1 q2]. -case rq : (right_pt (high c)) => [r1 r2]. -have lv : l = (p1 - q1) / (r1 - q1) by rewrite /l pq rq lq /=. -have q1ltp1 : q1 < p1. - move: onv xcond => /andP[] /eqP + _. - by rewrite lq rq pq /= => -> => /andP[]. -have lgt0 : 0 < l. - rewrite /l divr_gt0 // subr_gt0 ?pq ?lq ?rq //=. - by move: (edge_cond (high c)); rewrite lq rq. -rewrite det_inverse det_cyclique oppr_lt0. -rewrite -(pmulr_rgt0 _ lgt0). -rewrite detDM1 det_cyclique. -have <- : p1 = q1 + l * (r1 - q1). - rewrite lv mulfVK; first by ring. - rewrite subr_eq0; apply/eqP=> abs. - by have := edge_cond (high c); rewrite lq rq abs lt_irreflexive. -rewrite detVert lv. -rewrite pmulr_lgt0; last by rewrite subr_gt0. -have proj2: (last dummy_pt (right_pts c)).2 = q2 + (p1 - q1) / (r1 - q1) * (r2 - q2). - have ecnd : (left_pt (high c)).1 != (right_pt (high c)).1. - by apply/eqP=> abs; have := edge_cond (high c); rewrite abs lt_irreflexive. - have := vert_projl (last dummy_pt (right_pts c)) ecnd. - move: ronh=> /andP[] _ -> => /esym /eqP; rewrite ?pq ?lq ?rq /= => ->. - rewrite -(eqP xcond2); move: onv=>/andP[] /eqP <- _; rewrite pq /=; ring. -rewrite -proj2 subr_gt0. -apply: lt_le_trans vtople. -by move: onv=> /andP[] _ /andP[]; rewrite pq /=. -Qed. - -Lemma on_vert_edge_above_low_right v c p : - left_limit c < right_limit c -> - closed_cell_side_limit_ok c -> - on_vert_edge p v -> - v \in cell_safe_exits_right c -> - ~~ (p <<= low c). -Proof. -move=> llr cok onv vin. -have /andP[/andP[vtople xcond] xcond2] := right_vertical_edge_wrt_low llr cok vin. -move: (cok); rewrite /closed_cell_side_limit_ok. -rewrite 4!andbA=> /andP[] _. -move=> /andP[] rightn0 /andP[] samexr /andP[] sortr /andP[] ronl _. -rewrite /point_under_edge -ltNge. -set l := (p.1 - (left_pt (low c)).1) / ((right_pt (low c)).1 - (left_pt (low c)).1). -set q := ((left_pt (low c)).1 + l * ((right_pt (low c)).1 - (left_pt (low c)).1), - (left_pt (low c)).1 + l * ((right_pt (low c)).2 - (left_pt (low c)).2)). -case pq : p => [p1 p2]. -case lq : (left_pt (low c)) => [q1 q2]. -case rq : (right_pt (low c)) => [r1 r2]. -have lv : l = (p1 - q1) / (r1 - q1) by rewrite /l pq rq lq /=. -have q1ltp1 : q1 < p1. - move: onv xcond => /andP[] /eqP + _. - by rewrite lq rq pq /= => -> => /andP[]. -have lgt0 : 0 < l. - rewrite /l divr_gt0 // subr_gt0 ?pq ?lq ?rq //=. - by move: (edge_cond (low c)); rewrite lq rq. -rewrite det_inverse det_cyclique oppr_gt0. -rewrite -(pmulr_rlt0 _ lgt0). -rewrite detDM1 det_cyclique. -have <- : p1 = q1 + l * (r1 - q1). - rewrite lv mulfVK; first by ring. - rewrite subr_eq0; apply/eqP=> abs. - by have := edge_cond (low c); rewrite lq rq abs lt_irreflexive. -rewrite detVert lv. -rewrite pmulr_llt0; last by rewrite subr_gt0. -have proj2: (head dummy_pt (right_pts c)).2 = q2 + (p1 - q1) / (r1 - q1) * (r2 - q2). - have ecnd : (left_pt (low c)).1 != (right_pt (low c)).1. - by apply/eqP=> abs; have := edge_cond (low c); rewrite abs lt_irreflexive. - have := vert_projl (head dummy_pt (right_pts c)) ecnd. - move: ronl=> /andP[] _ -> => /esym /eqP; rewrite ?pq ?lq ?rq /= => ->. - rewrite -(eqP xcond2); move: onv=>/andP[] /eqP <- _; rewrite pq /=; ring. -rewrite -proj2 subr_lt0. -apply: (le_lt_trans vtople). -by move: onv=> /andP[] _ /andP[]; rewrite pq /=. -Qed. - -Lemma conv_num_sg s (a b t : R) : - 0 < t < 1 -> sgz a = s -> sgz b = s -> sgz ((a : R^o) <| t |> b) = s. -Proof. -move=> tint. -have [ -> <- | agt0 <- | alt0 <-] := sgzP a. - have [ -> | // | // ] := sgzP b. - by rewrite convmm sgz0. - have [ // | bgt0 _ | // ] := sgzP b. - rewrite /conv; apply/gtr0_sgz/addr_gt0; apply/mulr_gt0; lra. -have [ // | // | blt0 _] := sgzP b. -rewrite /conv; apply/ltr0_sgz; rewrite -oppr_gt0 opprD. -apply/addr_gt0; rewrite -mulrN; apply/mulr_gt0; lra. -Qed. - -Lemma conv_num_gtl (a b t c : R) : - 0 < t < 1 -> c < a -> c <= b -> c < (a : R^o) <| t |> b. -Proof. -move=> tint clta cleb; rewrite /conv. -rewrite -[_ *: (a : R^o)]/(t * a). -rewrite -[_ *: (b : R^o)]/((1 - t) * b). -rewrite [X in _ < X] - (_ : _ = c + ((t * (a - c)) + (1 - t) * (b - c))); last by ring. -have fact1 : 0 < t * (a - c) by apply: mulr_gt0; lra. -have fact2 : 0 <= (1 - t) * (b - c) by apply: mulr_ge0; lra. -lra. -Qed. - -Lemma conv_num_ltr (a b t c : R) : - 0 < t < 1 -> a < c -> b <= c -> (a : R^o) <| t |> b < c. -Proof. -move=> tint clta cleb; rewrite /conv. -rewrite -[_ *: (a : R^o)]/(t * a). -rewrite -[_ *: (b : R^o)]/((1 - t) * b). -rewrite [X in X < _] - (_ : _ = c - ((t * (c - a)) + (1 - t) * (c - b))); last by ring. -have fact1 : 0 < t * (c - a) by apply: mulr_gt0; lra. -have fact2 : 0 <= (1 - t) * (c - b) by apply: mulr_ge0; lra. -lra. -Qed. - -Lemma conv_p1 (a b : Plane R) t : (a <| t |> b).1 = - ((a.1 : R^o) <| t |> b.1). -Proof. by []. Qed. - -Lemma safe_bezier2 p1 p2 p3 c1 c2 vert_e u : - closed_cell_side_limit_ok c1 -> - closed_cell_side_limit_ok c2 -> - strict_inside_closed p1 c1 -> - strict_inside_closed p3 c2 -> - vert_e \in cell_safe_exits_right c1 -> - vert_e \in cell_safe_exits_left c2 -> - on_vert_edge p2 vert_e -> - 0 < u < 1 -> - on_vert_edge (bezier (f3pt p1 p2 p3) 2 u) vert_e -> - forall t, 0 <= t <= 1 -> - let bzt := bezier (f3pt p1 p2 p3) 2 t in - (strict_inside_closed bzt c1) || - (strict_inside_closed bzt c2) || - on_vert_edge bzt vert_e. -Proof. -move=> ok1 ok2 p1in p3in v1 v2 p2in uin bzuin t tin. -have un0 : u != 0 by apply: lt0r_neq0; case/andP: uin. -set bzt := bezier _ 2 t; lazy zeta. -have [tu | nut] := eqVneq t u; first by rewrite /bzt tu bzuin !orbT. -have llr1 : left_limit c1 < right_limit c1. - by move: p1in=> /andP[] _ /andP[]; apply: lt_trans. -have llr2 : left_limit c2 < right_limit c2. - by move: p3in=> /andP[] _ /andP[]; apply: lt_trans. -have p2belh1 : p2 <<< high c1. - by apply: (on_vert_edge_under_high_right _ ok1 p2in v1). -have p2belh2 : p2 <<< high c2. - by apply: (on_vert_edge_under_high_left _ ok2 p2in v2). -have p2abol1 : ~~(p2 <<= low c1). - by apply: (on_vert_edge_above_low_right _ ok1 p2in v1). -have p2abol2 : ~~(p2 <<= low c2). - by apply: (on_vert_edge_above_low_left _ ok2 p2in v2). -have bzubelh1 : bezier (f3pt p1 p2 p3) 2 u <<< high c1. - by apply: (on_vert_edge_under_high_right _ ok1 bzuin v1). -have bzuabol1 : ~~(bezier (f3pt p1 p2 p3) 2 u <<= low c1). - by apply: (on_vert_edge_above_low_right _ ok1 bzuin v1). -have bzubelh2 : bezier (f3pt p1 p2 p3) 2 u <<< high c2. - by apply: (on_vert_edge_under_high_left _ ok2 bzuin v2). -have bzuabol2 : ~~(bezier (f3pt p1 p2 p3) 2 u <<= low c2). - by apply: (on_vert_edge_above_low_left _ ok2 bzuin v2). -have [P1 | P2] := ltrP t u. - apply/orP; left; apply/orP; left. - set t' := t / u. - have t'int : 0 <= t' < 1. - apply/andP; split. - rewrite /t'; apply divr_ge0; lra. - rewrite /t' ltr_pdivrMr; lra. - have tt' : t = t' * u by rewrite /t' mulfVK. - have := bezier2_dichotomy_l (f3pt p1 p2 p3) t' u; rewrite -tt' /bzt => ->. - set p2' := p2 <| u |> p1. - set p3' := bezier (f3pt p1 p2 p3) 2 u. - rewrite [bezier _ _ _](_ : _ = (p3' <| t' |> p2') <| t' |> - (p2' <| t' |> p1)); last first. - by rewrite !bezier_step_conv /= -/p2'. - have [-> | t'n0] := eqVneq t' 0; first by rewrite !conv0. - have t'int' : 0 < t' < 1 by lra. - rewrite /strict_inside_closed -andbA; apply/andP; split. - rewrite /point_strictly_under_edge !det_conv. - have sgp1 : sgz (det p1 (left_pt (high c1)) (right_pt (high c1))) = -1. - by apply:ltr0_sgz; move: p1in=> /andP[] /andP[]. - have sgp2' : sgz - ((det p2 (left_pt (high c1)) (right_pt (high c1)) : R ^o) <|u|> - det p1 (left_pt (high c1)) (right_pt (high c1))) = -1. - apply: conv_num_sg=> //. - apply: ltr0_sgz; exact p2belh1. - rewrite -sgz_lt0; set (tmp := sgz _); suff -> : tmp = -1 by []. - rewrite {}/tmp; apply: conv_num_sg => //. - apply: conv_num_sg=> //. - apply: ltr0_sgz; exact bzubelh1. - by apply: conv_num_sg. - apply/andP; split. - rewrite /point_under_edge -ltNge. - rewrite !det_conv. - have sgp1 : sgz (det p1 (left_pt (low c1)) (right_pt (low c1))) = 1. - by apply:gtr0_sgz; move: p1in=> /andP[] /andP[] _; rewrite -ltNge. - have sgp2' : sgz - ((det p2 (left_pt (low c1)) (right_pt (low c1)) : R ^o) <|u|> - det p1 (left_pt (low c1)) (right_pt (low c1))) = 1. - apply: conv_num_sg=> //. - apply: gtr0_sgz; rewrite ltNge; exact p2abol1. - rewrite -sgz_gt0; set (tmp := sgz _); suff -> : tmp = 1 by []. - rewrite {}/tmp; apply: conv_num_sg => //. - apply: conv_num_sg=> //. - apply: gtr0_sgz; rewrite ltNge; exact bzuabol1. - by apply: conv_num_sg. - have vx1 : ve_x vert_e = right_limit c1. - by have /andP[_ /eqP ->] := right_vertical_edge_wrt_high llr1 ok1 v1. - have lp2' : left_limit c1 < p2'.1. - rewrite conv_p1; apply: conv_num_gtl => //. - move: p2in=> /andP[] /eqP -> _. - by rewrite vx1. - by apply: ltW; move: p1in=> /andP[] _ /andP[]. - apply/andP; split. - rewrite conv_p1. - apply: conv_num_gtl=> //. - rewrite conv_p1. - apply: conv_num_gtl=> //; last by apply: ltW. - by move: bzuin; rewrite -/p3'=> /andP[] /eqP -> _; rewrite vx1. - rewrite conv_p1; apply/ltW/conv_num_gtl=> //; apply/ltW. - by move: p1in=> /andP[] _ /andP[]. - have p2'r : p2'.1 < right_limit c1. - rewrite conv_p1 convC. - apply: conv_num_ltr; first by lra. - by move: p1in=> /andP[] _ /andP[]. - by move: p2in=> /andP[] /eqP -> _; rewrite vx1. - apply: conv_num_ltr;[ done | | apply: ltW]. - rewrite conv_p1 convC; apply: conv_num_ltr => //; first by lra. - by move: bzuin=> /andP[] /eqP -> _; rewrite vx1. - apply: conv_num_ltr=> //; apply: ltW. - by move: p1in=> /andP[] _ /andP[]. -apply/orP; left; apply/orP; right. -have {P2}tgtu : u < t by lra. -set t' := (t - u) / (1 - u). -have tt' : t = u + t' * (1 - u) by rewrite /t' mulfVK; [ring | lra]. -have := bezier2_dichotomy_r (f3pt p1 p2 p3) t' u; rewrite -tt' /bzt => ->. -have [t1 | tn1] := eqVneq t 1. - rewrite /t' /= t1 divff; last by lra. - by rewrite subrr !(scale0r, add0r, addr0, scale1r). -have t'int : 0 < t' < 1. - rewrite /t'; apply/andP; split. - apply: divr_gt0; lra. - by rewrite ltr_pdivrMr; lra. -set p1' := bezier (f3pt p1 p2 p3) 2 u. -set p2' := p3 <| u |> p2. -rewrite [bezier _ 2 _](_ : _ = (p3 <| t' |> p2') <| t' |> (p2' <| t' |> p1')); - last first. - by rewrite !bezier_step_conv. -rewrite /strict_inside_closed -andbA; apply/andP; split. -rewrite /point_strictly_under_edge !det_conv. - have sgp3 : sgz (det p3 (left_pt (high c2)) (right_pt (high c2))) = -1. - by apply:ltr0_sgz; move: p3in=> /andP[] /andP[]. - have sgp2' : sgz - ((det p3 (left_pt (high c2)) (right_pt (high c2)) : R ^o) <|u|> - det p2 (left_pt (high c2)) (right_pt (high c2))) = -1. - apply: conv_num_sg=> //. - apply: ltr0_sgz; exact p2belh2. - rewrite -sgz_lt0; set (tmp := sgz _); suff -> : tmp = -1 by []. - rewrite {}/tmp; apply: conv_num_sg => //. - by apply: conv_num_sg. - apply: conv_num_sg=> //. - apply: ltr0_sgz; exact bzubelh2. -apply/andP; split. - rewrite /point_under_edge -ltNge. - rewrite !det_conv. - have sgp3 : sgz (det p3 (left_pt (low c2)) (right_pt (low c2))) = 1. - by apply: gtr0_sgz; move: p3in=> /andP[] /andP[] _; rewrite -ltNge. - have sgp2' : sgz - ((det p3 (left_pt (low c2)) (right_pt (low c2)) : R ^o) <|u|> - det p2 (left_pt (low c2)) (right_pt (low c2))) = 1. - apply: conv_num_sg=> //. - by apply: gtr0_sgz; rewrite ltNge; exact p2abol2. - rewrite -sgz_gt0; set (tmp := sgz _); suff -> : tmp = 1 by []. - rewrite {}/tmp; apply: conv_num_sg => //. - by apply: conv_num_sg. - apply: conv_num_sg=> //. - by apply: gtr0_sgz; rewrite ltNge; exact bzuabol2. -have vx2 : ve_x vert_e = left_limit c2. - have /andP[_ /eqP ->] := left_vertical_edge_wrt_high llr2 ok2 v2. - rewrite /left_limit; apply/eqP. - move: ok2=> /andP[] lc2n0 /andP[]. - move=> /allP /(_ (head dummy_pt (left_pts c2))) + _; apply. - by case : (left_pts c2) lc2n0 => [// | ? ?] _ /=; rewrite inE eqxx. -have p2'r : p2'.1 < right_limit c2. - apply: conv_num_ltr=> //. - by move: p3in=>/andP[] _ /andP[]. - move: p2in=> /andP[] /eqP -> _. - by rewrite vx2; apply: ltW. -apply/andP; split. - have p2'l : left_limit c2 < p2'.1. - apply: conv_num_gtl=> //. - by move: p3in=> /andP[] _ /andP[]. - by move: p2in=> /andP[] /eqP ->; rewrite vx2. - apply: conv_num_gtl;[done | | apply: ltW]. - apply: conv_num_gtl=> //. - by move: p3in=> /andP[] _ /andP[]. - by apply/ltW. - apply: conv_num_gtl=> //. - by move: bzuin=> /andP[] /eqP + _; rewrite -/p1' vx2 => ->. -apply: conv_num_ltr=> //. - apply: conv_num_ltr=> //. - by move: p3in=> /andP[] _ /andP[]. - by apply/ltW. -apply/ltW/conv_num_ltr=> //. -move: bzuin=> /andP[] + _; rewrite -/p1'=> /eqP ->. -by apply/ltW; rewrite vx2. -Qed. - -Definition midpoint (a b : Plane R) := a <| 1/2 |> b. - -Definition mkedge_aux (a b : Plane R) : {e : edge | - forall h : a.1 < b.1, e = Bedge h}. -case (boolP (a.1 < b.1)). -move=> h; exists (Bedge h)=> h0. - by rewrite (bool_irrelevance h h0). -move=> not_edge. -exists (@Bedge (0, 0) (1, 0) (ltr01 : (0,0).1 < (1, 0).1)). -by move=> h; case: (negP not_edge). -Defined. - -Definition mkedge (a b : Plane R) := sval (mkedge_aux a b). - -Lemma mkedgeE (a b : Plane R) (h : a.1 < b.1) : - mkedge a b = Bedge h. -Proof. -rewrite /mkedge; case: (mkedge_aux a b)=> v Pv /=; apply: Pv. -Qed. - -Fixpoint check_bezier_ccw (fuel : nat) (v : vert_edge) - (a b c : Plane R) : - option bool := -match fuel with -| O => None -| S p => - let top_edge := (ve_x v, ve_top v) in - if negb (point_under_edge top_edge (mkedge a c)) then - Some true - else if - point_under_edge top_edge (mkedge a b) || - point_under_edge top_edge (mkedge b c) - then - Some false - else - let b' := midpoint a b in - let b2 := midpoint b c in - let c' := midpoint b' b2 in - if c'.1 < ve_x v then - check_bezier_ccw p v c' b2 c - else if ve_x v < c'.1 then - check_bezier_ccw p v a b' c' - else - if c'.2 < ve_top v then - Some true - else - Some false -end. - -Lemma bezier_on_vertical_line (a b c : Plane R) (v : vert_edge) : - a.1 < b.1 < c.1 -> - {u | u \in `]0, 1[ & (bezier (f3pt a b c) 2 u).1 = b.1}. -Proof. -move=> abc. -set bezierx := - \sum_(i < 3) ((f3pt a b c) i).1 *: bernp 0 1 2 i - b.1%:P. -have bezierxq t : - (bezier (f3pt a b c) 2 t).1 = (bezierx + b.1%:P).[t]. - rewrite bezier_bernstein2 /bezierx. - rewrite addrNK !big_ord_recr /= !big_ord0 /= !add0r. - have expandscale (x y : R) : x *: (y : R^o) = x * y by []. - rewrite 3![in RHS] hornerE !hornerZ !expandscale. - (* Problem with the failure of ring here. *) - Fail ring. - by rewrite (mulrC a.1) (mulrC b.1) (mulrC c.1). -have bz0 : bezier (f3pt a b c) 2 0 = a. - by rewrite !bezier_step_conv /= !conv0. -have bz1 : bezier (f3pt a b c) 2 1 = c. - by rewrite !bezier_step_conv /= !conv1. -have : bezierx.[0] < 0. - move: (bezierxq 0); rewrite bz0 hornerE [X in _ + X]hornerE. - move=> /eqP; rewrite -subr_eq=> /eqP <-. - by rewrite subr_lt0; case/andP: abc. -have : 0 < bezierx.[1]. - move: (bezierxq 1); rewrite bz1 hornerE [X in _ + X]hornerE. - move=> /eqP; rewrite -subr_eq=> /eqP <-. - by rewrite subr_gt0; case/andP: abc. -move=> /gtr0_sg sg1 /ltr0_sg sg0. -have sgM : Num.sg bezierx.[0] * Num.sg bezierx.[1] = -1. - by rewrite sg1 sg0 mulr1. -have [u uint /rootP ur] := ivt_sign ler01 sgM. -exists u=> //. -by rewrite bezierxq hornerE ur add0r hornerE. -Qed. - -(* In triangle p q r, the distance from r to its projection on - line pq is det p q r / (q.1 - p.1) *) -Lemma diff_vert_y (a b c c' : Plane R) : - a.1 != b.1 -> - c' = (c.1, a.2 + (c.1 - a.1) / (b.1 - a.1) * (b.2 - a.2)) -> - (c.2 - c'.2 ) = det a b c / (b.1 - a.1). -Proof. -intros anb c'def. -have dn0 : b.1 - (a.1 : R^o) != 0. - by rewrite subr_eq0 eq_sym. -rewrite c'def /= (mulrAC _ _ (b.2 - a.2)) opprD addrA. -apply: (mulIf dn0); rewrite mulrBl !mulfVK //. -rewrite det_scalar_productE /rotate /scalar_product /= mulrN. -by rewrite mulrC; congr (_ - _); rewrite mulrC. -Qed. - -Lemma height_bezier2 (a b c p : Plane R) t: - a.1 < b.1 < c.1 -> - (* p is the vertical projection of bezier ... t on the straight line ab *) - det a b p = 0 -> - p.1 = (bezier (f3pt a b c) 2 t).1 -> - (bezier (f3pt a b c) 2 t).2 - p.2 = - t ^ 2 * det a b c / (b.1 - a.1). -Proof. -move=> abcdq p1q palign. -(* c' is the vertical projection of c on the straight line ab. *) -set c' := (c.1, a.2 + (c.1 - a.1) / (b.1 - a.1) * (b.2 - a.2)). -have anb : a.1 != b.1 by lra. -rewrite -[RHS]mulrA -(diff_vert_y anb erefl). -move: p1q palign => /eqP. -rewrite vert_projr; last by lra. -move=> /eqP /[dup] palign -> projP. -rewrite (mulrAC _ _ (b.2 - a.2)). -have dba : b.1 - a.1 != 0 by lra. -apply: (mulIf dba). -rewrite mulrBl (mulrDl b.2) mulfVK // projP. -rewrite (mulrBr (t ^ 2)) (mulrBl (b.1 - a.1)). -have tmp1 : t ^ 2 * c'.2 * (b.1 - a.1) = - t ^ 2 * (a.2 * ( b.1 - a.1) + (c.1 - a.1) * (b.2 - a.2)). - rewrite -mulrA; congr (_ * _). - by rewrite /= mulrDl (mulrAC _ _ (b.1 - a.1)) mulfVK. -rewrite !bezier_step_conv /=. -have tmp x (y : R^o) : x *: y = x * y by []. -rewrite !tmp tmp1 /=. -ring. -Qed. - -Lemma safe_bezier_ccw_corner_side (a b c : Plane R) (v : vert_edge) - (u : R): - ccw a b c -> - a.1 < b.1 < c.1 -> - a.1 < ve_x v < c.1 -> - on_vert_edge b v -> - u \in `]0, 1[ -> - (bezier (f3pt a b c) 2 u).1 = ve_x v -> - ve_bot v < (bezier (f3pt a b c) 2 u).2. -Proof. -move=> abc abc1 avc bon uin bzx. -move: (bon) => /andP[] /eqP bx /andP[]bl bh. -apply: (lt_trans bl). -rewrite -subr_gt0. -have abb : det a b b = 0. - by rewrite det_cyclique det_alternate. -have bzxb : b.1 = (bezier (f3pt a b c) 2 u).1 by rewrite bzx. -rewrite (height_bezier2 abc1 abb bzxb). -apply: divr_gt0; last by lra. -apply: mulr_gt0; last by []. -rewrite in_itv /= in uin. -have tmp : 0 < u < 1 by exact uin. -apply: mulr_gt0; lra. -Qed. - -Lemma under_proj e p : - valid_edge e p -> (p <<= e) = (p.2 <= (left_pt e).2 + - (p.1 - (left_pt e).1) * ((right_pt e).2 - (left_pt e).2) / - ((right_pt e).1 - (left_pt e).1)). -Proof. -move=> vep. -rewrite /point_under_edge det_cyclique. -have ecnd := edge_cond e. -have ecnd' : (left_pt e).1 != (right_pt e).1 by lra. -set p' := (p.1, (left_pt e).2 + (p.1 - (left_pt e).1) / - ((right_pt e).1 - (left_pt e).1) * - ((right_pt e).2 - (left_pt e).2)). -have := diff_vert_y ecnd'=> /(_ p p' erefl) /eqP. -rewrite subr_eq=> /eqP ->; rewrite /p' /=. -rewrite addrA (addrC _ (left_pt e).2) -!addrA. -rewrite lerD2. -rewrite addrC -lerBrDl mulrAC addrN. -rewrite pmulr_lle0 // invr_gt0/=. -by rewrite subr_gt0. -Qed. - -Lemma safe_bezier_ccw (a b c : Plane R) (v : vert_edge) (u : R) : - ccw a b c -> - a.1 < b.1 < c.1 -> - a.1 < ve_x v < c.1 -> - ~~((ve_x v, ve_top v) <<= mkedge a c) -> - u \in `]0, 1[ -> - (bezier (f3pt a b c) 2 u).1 = ve_x v -> - ve_bot v < (bezier (f3pt a b c) 2 u).2 -> - on_vert_edge (bezier (f3pt a b c) 2 u) v. -Proof. -move=> abc bint vint topP uin /[dup] bzx /eqP bzxb bzb. -rewrite /on_vert_edge bzxb bzb 2!andTb. -have ac_cond : a.1 < c.1 by lra. -have vav : valid_edge (mkedge a c) (ve_x v, ve_top v). - rewrite/valid_edge mkedgeE [(left_pt _).1]/= [(right_pt _).1]/=. - by rewrite ?ltW //; move: vint=> /andP[]. -move: topP. -rewrite (under_proj vav) -ltNge; apply le_lt_trans. -rewrite (_ : (ve_x v, ve_top v).1 = (bezier (f3pt a b c) 2 u).1); last first. - by rewrite bzx. -rewrite -under_proj; last by rewrite /valid_edge bzx; exact: vav. -rewrite /point_under_edge. -rewrite bezier_step_conv. -have vacp : valid_edge (mkedge a c) (bezier (f3pt a b c) 2 u). - rewrite/valid_edge mkedgeE [(left_pt _).1]/= [(right_pt _).1]/= bzx. - by rewrite ?ltW //; move: vint=> /andP[]. -rewrite det_conv -sgz_le0. -have Cuin : 0 < 1 - u < 1 by rewrite in_itv /= in uin; lra. -set X := (X in X <= 0). -suff : X = -1. - (* TODO : report - Fail Timeout 2 lra. *) - by move=> ->; apply: lerN10. -rewrite {}/X. -apply: conv_num_sg=> //. - apply: ltr0_sgz. - rewrite bezier_step_conv det_conv. - rewrite convC. - apply: conv_num_ltr=> //. - rewrite /=; move: abc; rewrite /ccw mkedgeE /= => abc. - by rewrite det_inverse oppr_lte0 -det_cyclique. - by rewrite /= mkedgeE /= -det_cyclique det_alternate. -apply: ltr0_sgz. -rewrite bezier_step_conv det_conv. -apply: conv_num_ltr=> //. - rewrite /=; move: abc; rewrite /ccw mkedgeE /= => abc. - by rewrite det_inverse oppr_lte0 -det_cyclique. -by rewrite mkedgeE /= det_alternate. -Qed. - -End sandbox. diff --git a/theories/encompass.v b/theories/encompass.v deleted file mode 100644 index ea9c1e7..0000000 --- a/theories/encompass.v +++ /dev/null @@ -1,224 +0,0 @@ -From mathcomp Require Import all_ssreflect all_algebra. -From mathcomp Require Import reals ereal classical_sets. -Require Export preliminaries preliminaries_hull axiomsKnuth. - -(******************************************************************************) -(* encompass oriented s l == oriented is a ternary relation, s and l *) -(* are lists of points such that *) -(* oriented l_i l_i.+1 s_k for all i and k *) -(* encompass_aux oriented l h == h describes an open convex region that *) -(* contains l *) -(* encompass oriented l h == h describes a convex hull for the set of *) -(* points l where the last segment is formed by *) -(* the last and first elements *) -(******************************************************************************) - -Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory. - -Local Open Scope ring_scope. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Section spec. -Variable plane : zmodType. -Variable oriented : plane -> plane -> plane -> bool. - -Definition is_left (p q r : plane) := [|| r == p, r == q | oriented p q r]. -Hint Unfold is_left : core. - -Definition all_left (x y : plane) : seq plane -> bool := all (is_left x y). - -Fixpoint encompass_aux (l h : seq plane) : bool := - match h with - | nil => false - | t1 :: nil => true - | t1 :: ((t2 :: _) as h') => all_left t1 t2 l && encompass_aux l h' - end. - -Definition encompass (s h : seq plane) := - match h with - | nil => false - | t :: h' => encompass_aux s (last t h' :: h) - end. - -Lemma encompassl0 l : encompass l [::] = false. -Proof. by []. Qed. - -Definition convexHullSpec (l h : seq plane) := - uniq h && all (mem l) h && encompass l h. - -(* TOTHINK: replace encompass : seq -> seq -> bool by a predicate - seq -> plane -> bool? *) - -Lemma encompass_auxE (l h : seq plane) : - encompass_aux l h = (h != [::]) && all (fun x => encompass_aux [:: x] h) l. -Proof. -elim: h =>// a'; case=> [ _ | b' l' IHl']. - by elim: l. -rewrite /= -/(encompass_aux l (b' :: l')) IHl' -all_predI; apply eq_all=>x. -by rewrite /= andbT. -Qed. - -Lemma encompassE (s h : seq plane) : - encompass s h = (h != [::]) && all (fun x => encompass [:: x] h) s. -Proof. by case: h =>// a l; rewrite {1}/encompass encompass_auxE. Qed. - -Lemma encompass_aux_all_index (l h : seq plane) : - encompass_aux l h = (h != [::]) && - [forall i : 'I_(size h), (i.+1mod == 0%N :> nat) || all_left h`_i h`_i.+1mod l]. -Proof. -elim: h=>// a; case. - by move=>/= _; apply/esym/forallP => i; rewrite modn1 eq_refl. -move=>b l' IHl' /=; rewrite -/(encompass_aux l (b :: l')) IHl' /=. -apply/idP/idP => [/andP[Habl H]|/forallP H]. - apply/forallP => -[] [//|n/=]. - rewrite ltnS => nlt. - move: H => /forallP/(_ (Ordinal nlt)). - move: nlt (nlt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> mm _|nm nm1]. - by rewrite modnn eqxx. - by rewrite modn_small ?ltnS// modn_small ?ltnS. -apply/andP; split; first by move: H => /(_ ord0). -apply/forallP => -[i ilt]. -move: H => /(_ (lift ord0 (Ordinal ilt))). -move: ilt (ilt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> mm _|ilt ilt1]. - by rewrite modnn eqxx. -by rewrite modn_small ?ltnS// modn_small ?ltnS. -Qed. - -Lemma encompass_all_index (l s : seq plane) : encompass s l = - (l != [::]) && [forall i : 'I_(size l), all_left l`_i l`_i.+1mod s]. -Proof. -case: l => // a l /=. -rewrite -/(encompass_aux s (a :: l)) encompass_aux_all_index. -apply/idP/idP => [H|/forallP H]. - apply/forallP => -[i ilt]. - move: ilt (ilt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> /= _|ilt ilt1]. - by rewrite modnn nth_last /=; move: H => /andP[H _]. - move: H => /andP[_ /andP [_ /forallP]] /(_ (Ordinal ilt1)) /=. - by rewrite modn_small ?ltnS. -apply/andP; split. - by move: H => /(_ ord_max); rewrite /= modnn nth_last. -apply/forallP => -[i ilt]. -move: ilt (ilt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> /= _|ilt ilt1]. - by rewrite modnn. -by move: H => /(_ (Ordinal ilt1))/=; rewrite modn_small ?ltnS. -Qed. - -End spec. - -Module SpecKA (KA : KnuthAxioms). -Section Dummy. -Variable R : realType. -Let plane : vectType _ := (R^o * R^o)%type. - -Let oriented := KA.OT (R:=R). -Let Ax1 := KA.Axiom1 (R:=R). -Let Ax2 := KA.Axiom2 (R:=R). -Let Ax5 := KA.Axiom5 (R:=R). -Let Ax5' := KA.Axiom5' (R:=R). - -Lemma encompassll_spec (l : seq plane) : uniq l -> - encompass oriented l l = - (l != [::]) && - [forall i : 'I_(size l), [forall j : 'I_(size l), [forall k : 'I_(size l), - (i < j < k)%N ==> oriented l`_i l`_j l`_k]]]. -Proof. -move=> /uniqP-/(_ 0%R) lu; apply/idP/idP. - rewrite encompassE => /andP[-> /allP] ll /=. - have sD i j : (i.+1 < size l)%N -> (j < size l)%N -> j != i -> j != i.+1 -> - oriented l`_i l`_i.+1 l`_j. - move=> isl jl ji jis. - have /ll : l`_j \in l by rewrite mem_nth. - have il : (i < size l)%N by rewrite (leq_trans _ isl). - rewrite encompass_all_index => /andP[_] /forallP /(_ (Ordinal il)) /=. - rewrite Zp_succE andbT/= modn_small// => /or3P[| |//] /eqP/lu; rewrite 2!inE. - by move=> /(_ jl il)/eqP; rewrite (negbTE ji). - by move=>/(_ jl isl)/eqP; rewrite (negbTE jis). - apply/'forall_'forall_'forall_implyP => -[i ilt] [j jlt] [k klt] /= /andP[ij jk]. - elim: k => // k IHk in klt jk *. - have {}IHk := IHk (ltnW klt). - move: jk; rewrite leq_eqVlt => /predU1P[[jk]|]. - subst j. - do 2 apply: Ax1. - apply: sD => //; first by rewrite ltn_eqF. - by rewrite ltn_eqF// (leq_trans ij). - rewrite ltnS => jk; have {}IHk := IHk jk. - move: ij; rewrite leq_eqVlt => /predU1P[ij|ij]. - subst j. - apply: sD => //. - by rewrite gtn_eqF// ltnS (leq_trans _ jk)// -addn2 leq_addr. - by rewrite gtn_eqF// (leq_trans jk). - apply: (@Ax5 _ l`_i.+1 _ l`_k). - - apply: sD => //; first by rewrite (leq_trans ij)// ltnW. - by rewrite gtn_eqF// (ltn_trans _ ij). - by rewrite gt_eqF. - - apply: sD; first by rewrite (leq_trans ij)// ltnW. - by rewrite (ltn_trans _ klt). - by rewrite gtn_eqF// (ltn_trans _ jk)// (ltn_trans _ ij). - by rewrite gtn_eqF// (ltn_trans ij). - - apply: sD => //; first by rewrite (leq_trans ij)// ltnW. - rewrite gtn_eqF// ltnS (leq_trans _ (ltnW jk))// (leq_trans _ ij)//. - by rewrite -addn2 leq_addr. - by rewrite gtn_eqF// (leq_trans ij)// (leq_trans (ltnW jk)). - - exact IHk. - - do 2 apply Ax1. - apply: sD => //. - by rewrite ltn_eqF// (ltn_trans _ jk)// (leq_trans _ ij). - by rewrite ltn_eqF// ltnS (leq_trans _ (ltnW jk))// ltnW// (ltn_trans _ ij). -rewrite encompassE => /andP[l0 sD] /=; rewrite l0 /=. -have id x : x \in l -> exists2 n, (n < size l)%N & l`_n = x. - by move=> xl; exists (index x l); [rewrite index_mem|rewrite nth_index]. -apply/allP => _ /id[i il <-]. -rewrite encompass_all_index; rewrite l0; apply/forallP => -[j jlt]. -rewrite /all_left/= /is_left/= andbT. -have [->|ij] := eqVneq i j. - exact/or3P/Or31. -destruct l as [|a l] => //=. -have [ijs|ijs] := eqVneq i (j.+1 %% (size l).+1)%N. - by apply/or3P/Or32; rewrite -ijs. -apply/or3P/Or33; move: jlt; rewrite leq_eqVlt => /predU1P[[je]|jlt]. - subst j; rewrite modnn. - do 2 apply Ax1. - move: sD => /'forall_'forall_'forall_implyP - /(_ ord0 (Ordinal il) (Ordinal (leqnn _))); - apply => /=. - rewrite lt0n. - move: ijs; rewrite modnn => ->/=. - move: il; rewrite leq_eqVlt => /predU1P[[/eqP]|]. - by rewrite (negbTE ij). - by rewrite ltnS. -move:ijs; rewrite modn_small => // ijs. -have [ji|ji] := ltnP j.+1 i. - move: sD => /'forall_'forall_'forall_implyP - /(_ (Ordinal (leq_trans (leqnSn _) jlt)) (Ordinal jlt) (Ordinal il)). - apply => /=. - by rewrite ltnS leqnn. -apply: Ax1. -move: sD => /'forall_'forall_'forall_implyP - /(_ (Ordinal il) (Ordinal (leq_trans (leqnSn _) jlt)) (Ordinal jlt)). -apply => /=. -rewrite ltnS leqnn andbT ltnNge. -rewrite leq_eqVlt eq_sym (negbTE ij)/=. -rewrite leq_eqVlt eq_sym (negbTE ijs)/=. -by rewrite ltnNge ji. -Qed. - -Lemma encompassll_subseq (l l' : seq plane) : uniq l -> - encompass oriented l l -> - subseq l' l -> - l' != [::] -> - encompass oriented l' l'. -Proof. -move=> lu; rewrite (encompassll_spec lu) => ll l'l l'0. -have l'u := subseq_uniq l'l lu; rewrite (encompassll_spec l'u) l'0 /=. -apply/'forall_'forall_'forall_implyP => i j k /andP[ij jk]. -move: l'l => /subseq_incl-/(_ 0%R) [f [fl flt]]. -move: ll => /andP[_] /'forall_'forall_'forall_implyP - /(_ (f i)) /(_ (f j)) /(_ (f k)); rewrite 3!fl; apply. -by apply/andP; split; apply: flt. -Qed. - -End Dummy. -End SpecKA. diff --git a/theories/generic_trajectories.v b/theories/generic_trajectories.v deleted file mode 100644 index b665b3d..0000000 --- a/theories/generic_trajectories.v +++ /dev/null @@ -1,1139 +0,0 @@ -From mathcomp Require Import all_ssreflect. -Require Import ZArith (* List *) String OrderedType OrderedTypeEx FMapAVL. -Require Import shortest_path. - -Notation head := seq.head. -Notation sort := path.sort. - -(* I did not have the courage to understand how to use CoqEAL - this first version uses only vanilla Coq data structures. It could still - use more mathcomp functions, like "has" instead of "existsb" *) - -(* FIRST PART: Vertical cell decomposition. *) -(********************************************) -(* The first data structures and algorithms are taken from - github.com/ybertot/VerticalCells, which was initially a master internship - by Thomas Portet. *) -(* The main function is edges_to_cells. The input should respect - data invariants: - - all edge extremities are inside the box defined by the bottom and - top edge - - all edges should have a left_pt that has a lower x coordinate than the - right_pt - - no two edges should cross. - At the time of writing these lines, the proof of correctness is not - complete, due to the complexity of the function "step". Three important - properties need to be satisfied: - - edges given in the input never collide with the interior of cells, - - points in the left_pts and right_pts sequences are vertically aligned - and are the only potentially colliding points in these segments - - the elements of left_pts have an x coordinate that is strictly smaller than - the elements of right_pts *) - -Notation seq := list. - -Section generic_implementation. - -(* In the original development R has type numFieldType and the various - operations are taken from that structure. *) -Variable R : Type. - -Variables R_eqb R_leb : R -> R -> bool. - -Variables R_add R_sub R_mul R_div : R -> R -> R. - -Definition R_ltb : R -> R -> bool := - fun x y => andb (negb (R_eqb x y)) (R_leb x y). - -Notation "x * y" := (R_mul x y). - -Notation "x - y" := (R_sub x y). - -Notation "x + y" := (R_add x y). - -Notation "x / y" := (R_div x y). - -Variable pt_distance : R -> R -> R -> R -> R. - -Variable R1 : R. - -Let R0 := R_sub R1 R1. - -Let R2 := R_add R1 R1. - -Record pt := Bpt {p_x : R; p_y : R}. -(* In the original development, edge have the data invariant that - the left point has a first coordinate strictly less than the right point. *) - -Variable edge : Type. -Variable Bedge : pt -> pt -> edge. -Variables left_pt right_pt : edge -> pt. - -Definition same_x (p : pt) (v : R) := - R_eqb (p_x p) v. - -Record event := - Bevent {point : pt; outgoing : seq edge}. - -Record cell := Bcell {left_pts : list pt; right_pts : list pt; - low : edge; high : edge}. - -Definition dummy_pt := ({| p_x := R1; p_y := R1|}). - -Definition dummy_edge := Bedge dummy_pt dummy_pt. - -Definition dummy_cell := - {| left_pts := nil; right_pts := nil; low := dummy_edge; high := dummy_edge|}. - -Definition dummy_event := - {| point := dummy_pt; outgoing := nil|}. - -(* In the original development pt, edge, and cell are eq_types *) -Definition pt_eqb (a b : pt) : bool := - let: Bpt a_x a_y := a in - let: Bpt b_x b_y := b in - (R_eqb a_x b_x) && (R_eqb a_y b_y). - -Definition edge_eqb (g1 g2 : edge) : bool := - pt_eqb (left_pt g1) (left_pt g2) && pt_eqb (right_pt g1) (right_pt g2). - -(* The boolean value inc stands for incoming, meaning that we are looking *) -(* at the right extremity of an edge. *) -Fixpoint add_event (p : pt) (e : edge) (inc : bool) (evs : seq event) : - seq event := - match evs with - | nil => if inc then (Bevent p nil :: nil) - else (Bevent p (e :: nil) :: nil) - | ev1 :: evs' => - let p1 := point ev1 in - if pt_eqb p p1 then - if inc then Bevent p1 (outgoing ev1) :: evs' - else Bevent p1 (e :: outgoing ev1) :: evs' else - if R_ltb (p_x p) (p_x p1) then - if inc then - Bevent p nil :: evs else - Bevent p (e :: nil) :: evs - else if R_eqb (p_x p) (p_x p1) && R_ltb (p_y p) (p_y p1) then - if inc then - Bevent p nil :: evs else - Bevent p (e :: nil) :: evs else - ev1 :: add_event p e inc evs' - end. - -Fixpoint edges_to_events (s : seq edge) : seq event := - match s with - | nil => nil - | e :: s' => - add_event (left_pt e) e false - (add_event (right_pt e) e true (edges_to_events s')) - end. - -(* this function removes consecutives duplicates, meaning the seq needs - to be sorted first if we want to remove all duplicates *) -Fixpoint no_dup_seq_aux [A : Type] (eqb : A -> A -> bool) (s : seq A) : (seq A) := - match s with - | nil => nil - | a::q => - match q with - | nil => s - | b::r => - if eqb a b then no_dup_seq_aux eqb q else a::(no_dup_seq_aux eqb q) - end - end. - -Notation no_dup_seq := (no_dup_seq_aux pt_eqb). - -Definition valid_edge e p := (R_leb (p_x (left_pt e)) (p_x p)) && -(R_leb (p_x p) (p_x (right_pt e))). - -(* TODO: check again the mathematical formula after replacing the infix *) -(* operations by prefix function calls. *) -Definition vertical_projection (p : pt) (e : edge) : option pt := - if valid_edge e p then - Some(Bpt (p_x p) (R_add - (R_mul (R_sub (p_x p) (p_x (left_pt e))) - (R_div (R_sub (p_y (right_pt e)) (p_y (left_pt e))) - (R_sub (p_x (right_pt e)) (p_x (left_pt e))))) - (p_y (left_pt e)))) - else None. - -Section area3_def. - -Local Notation "x + y" := (R_add x y). -Local Notation "x - y" := (R_sub x y). -Local Notation "x * y" := (R_mul x y). - -Definition area3' (a : pt) (b : pt) (c : pt) : R := - let: Bpt a_x a_y := a in - let: Bpt b_x b_y := b in - let: Bpt c_x c_y := c in - (((c_x * a_y - a_x * c_y) - - (b_x * a_y - a_x * b_y)) + - b_x * c_y) - c_x * b_y. - -Definition area3 (a : pt) (b : pt) (c : pt) : R := - let: Bpt a_x a_y := a in - let: Bpt b_x b_y := b in - let: Bpt c_x c_y := c in - b_x * c_y + a_x * b_y + c_x * a_y - - b_x * a_y - a_x * c_y - c_x * b_y. - -End area3_def. - -Definition point_under_edge (p : pt) (e : edge) : bool := - R_leb (area3 p (left_pt e) (right_pt e)) R0. - -Notation "p >>> g" := (negb (point_under_edge p g)) - (at level 70, no associativity). - -Definition point_strictly_under_edge (p : pt) (e : edge) : bool := - R_ltb (area3 p (left_pt e) (right_pt e)) R0. - -Notation "p <<< g" := (point_strictly_under_edge p g) - (at level 70, no associativity). - -Definition edge_below (e1 : edge) (e2 : edge) : bool := -(point_under_edge (left_pt e1) e2 && - point_under_edge (right_pt e1) e2) -|| (negb (point_strictly_under_edge (left_pt e2) e1) && - negb (point_strictly_under_edge (right_pt e2) e1)). - -Definition inter_at_extb (e1 e2 : edge) : bool := - (pt_eqb (left_pt e1) (left_pt e2) && - pt_eqb (left_pt e1) (left_pt e2)) || - ((edge_below e1 e2 || edge_below e2 e1) && - ((R_eqb (area3 (left_pt e2) (right_pt e2) (left_pt e1) ) R0 && - valid_edge e2 (left_pt e1)) ==> - (pt_eqb (left_pt e1) (left_pt e2) || pt_eqb (left_pt e1) (right_pt e2))) && - ((R_eqb (area3 (left_pt e2) (right_pt e2) (right_pt e1)) R0 && - valid_edge e2 (right_pt e1)) ==> - (pt_eqb (right_pt e1) (left_pt e2) || pt_eqb (right_pt e1) (right_pt e2))) && - ((R_eqb (area3 (left_pt e1) (right_pt e1) (left_pt e2)) R0 && - valid_edge e1 (left_pt e2)) ==> - (pt_eqb (left_pt e2) (left_pt e1) || pt_eqb (left_pt e2) (right_pt e1))) && - ((R_eqb (area3 (left_pt e1) (right_pt e1) (right_pt e2)) R0 && - valid_edge e1 (right_pt e2)) ==> - (pt_eqb (right_pt e2) (left_pt e1) || pt_eqb (right_pt e2) (right_pt e1)))). - -Fixpoint no_intersections (s : seq edge) : bool := - match s with - | nil => true - | a :: s' => forallb (inter_at_extb a) s' && no_intersections s' - end. - -Definition contains_point (p : pt) (c : cell) : bool := - negb (point_strictly_under_edge p (low c)) && point_under_edge p (high c). - -Definition close_cell (p : pt) (c : cell) := - match vertical_projection p (low c), - vertical_projection p (high c) with - | None, _ | _, None => c - | Some p1, Some p2 => - Bcell (left_pts c) (no_dup_seq (p2 :: p :: p1 :: nil)) (low c) (high c) - end. - -Definition closing_cells (p : pt) (contact_cells: seq cell) : seq cell := - List.map (fun c => close_cell p c) contact_cells. - -Definition pvert_y (p : pt) (e : edge) := - match vertical_projection p e with - Some p' => p_y p' - | None => R0 - end. - -Fixpoint opening_cells_aux (p : pt) (out : seq edge) (low_e high_e : edge) - : seq cell * cell := - match out with - | [::] => - let op0 := vertical_projection p low_e in - let op1 := vertical_projection p high_e in - match (op0,op1) with - | (None,_) | (_,None) => ([::], dummy_cell) - | (Some p0,Some p1) => - ([::] , Bcell (no_dup_seq ([:: p1; p; p0])) [::] low_e high_e) - end - | c::q => - let op0 := vertical_projection p low_e in - let (s, nc) := opening_cells_aux p q c high_e in - match op0 with - | None => ([::], dummy_cell) - | Some p0 => - (Bcell (no_dup_seq [:: p; p0]) [::] low_e c :: s, nc) - end - end. - -Fixpoint open_cells_decomposition_contact open_cells pt : - option (seq cell * seq cell * cell) := -if open_cells is c :: q then - if contains_point pt c then - if open_cells_decomposition_contact q pt is Some(cc, lc, c') then - Some(c :: cc, lc, c') - else - Some([::], q, c) - else - None -else - None. - -Fixpoint open_cells_decomposition_rec open_cells pt : - seq cell * seq cell * cell * seq cell := -if open_cells is c :: q then - if contains_point pt c then - if open_cells_decomposition_contact q pt is Some(cc, lc, c') then - ([::], c :: cc, c', lc) - else - ([::], [::], c, q) - else - let '(fc, cc, c', lc) := open_cells_decomposition_rec q pt in - (c :: fc, cc, c', lc) -else - ([::], [::], dummy_cell, [::]). - -Definition open_cells_decomposition (open_cells : seq cell) (p : pt) : - seq cell * seq cell * cell * seq cell * edge * edge := -let '(fc, cc, c', lc) := open_cells_decomposition_rec open_cells p in -(fc, cc, c', lc, low (head c' cc), high c'). - -Record scan_state := - Bscan {sc_open1 : seq cell; - lst_open : cell; - sc_open2 : seq cell; - sc_closed : seq cell; - lst_closed : cell; - lst_high : edge; - lst_x : R}. - -Definition update_closed_cell (c : cell) (p : pt) : cell := - let ptseq := right_pts c in - let newptseq := seq.head dummy_pt ptseq :: p :: behead ptseq in - Bcell (left_pts c) newptseq (low c) (high c). - -Definition set_left_pts (c : cell) (l : seq pt) := - {| left_pts := l; right_pts := right_pts c; low := low c; high := high c |}. - -Definition set_pts (c : cell) (l1 l2 : seq pt) := - {| left_pts := l1; right_pts := l2; low := low c; high := high c |}. - -(* This function is to be called only when the event is in the middle - of the last opened cell. The point e needs to be added to the left - points of one of the newly created open cells, but the one that receives - the first segment of the last opening cells should keep its existing - left points.*) -Definition update_open_cell (c : cell) (e : event) : seq cell * cell := - let ps := left_pts c in - if outgoing e is [::] then - ([::], set_left_pts c [:: head dummy_pt ps, point e & behead ps]) - else - match - opening_cells_aux (point e) (sort edge_below (outgoing e)) - (low c) (high c) with - | ([::], c') => (* this is an absurd case. *) - ([::], c) - | (c'::tlc', lc') => - (set_left_pts c' (point e :: behead ps) :: tlc', lc') - end. - -Definition update_open_cell_top (c : cell) (new_high : edge) (e : event) := - if outgoing e is [::] then - let newptseq := -(* when function is called, (point e) should alread be in the left points. *) - [:: Bpt (p_x (point e)) (pvert_y (point e) new_high) & - left_pts c] in - ([::], Bcell newptseq (right_pts c) (low c) new_high) - else - match opening_cells_aux (point e) (sort edge_below (outgoing e)) - (low c) new_high with - | ([::], lc) => (* this is not supposed to happen *) ([::], lc) - | (f :: q, lc) => - (set_left_pts f (point e :: behead (left_pts c)) :: q, lc) - end. - -Definition simple_step (fc cc lc : seq cell) (lcc : cell) (le he : edge) - (closed_cells : seq cell) (last_closed : cell) ev := - let new_closed := closing_cells (point ev) cc in - let last_new_closed := close_cell (point ev) lcc in - let closed_cells' := closed_cells ++ last_closed :: new_closed in - let (nos, lno) := - opening_cells_aux (point ev) (sort edge_below (outgoing ev)) le he in - Bscan (fc ++ nos) lno lc closed_cells' last_new_closed he (p_x (point ev)). - -Definition step (st : scan_state) (e : event) : scan_state := - let p := point e in - let '(Bscan op1 lsto op2 cls cl lhigh lx) := st in - if negb (same_x p lx) then - let '(first_cells, contact_cells, last_contact, last_cells, - lower_edge, higher_edge) := - open_cells_decomposition (op1 ++ lsto :: op2) p in - simple_step first_cells contact_cells last_cells last_contact - lower_edge higher_edge cls cl e - else if p >>> lhigh then - let '(fc', contact_cells, last_contact, last_cells, - low_edge, higher_edge) := - open_cells_decomposition op2 p in - let first_cells := op1 ++ lsto :: fc' in - simple_step first_cells contact_cells last_cells last_contact - low_edge higher_edge cls cl e - else if p <<< lhigh then - let new_closed := update_closed_cell cl (point e) in - let (new_opens, new_lopen) := update_open_cell lsto e in - Bscan (op1 ++ new_opens) new_lopen op2 cls new_closed lhigh lx - else (* here p === lhigh *) - let '(fc', contact_cells, last_contact, last_cells, lower_edge, - higher_edge) := - open_cells_decomposition (lsto :: op2) p in - (* we know lsto was just open, so that its left limit is lx - and its right limit is bounded by p_x (right_pt lhigh), which - is necessarily p_x (point e). lsto is necessarily the - first cell of contact_cells. So the first element of - contact_cells should not be closed. It can just be - disregarded. *) - let closed := closing_cells p (seq.behead contact_cells) in - let last_closed := close_cell p last_contact in - let (new_opens, new_lopen) := update_open_cell_top lsto higher_edge e in - Bscan (op1 ++ fc' ++ new_opens) new_lopen last_cells - (closed ++ cl :: cls) last_closed higher_edge lx. - -Definition leftmost_points (bottom top : edge) := - if R_ltb (p_x (left_pt bottom)) (p_x (left_pt top)) then - if vertical_projection (left_pt top) bottom is Some pt then - no_dup_seq [:: left_pt top; pt] - else - [::] - else - if vertical_projection (left_pt bottom) top is Some pt then - no_dup_seq [:: pt; left_pt bottom] - else - [::]. - -Definition rightmost_points (bottom top : edge) := - if R_ltb (p_x (right_pt bottom)) (p_x (right_pt top)) then - if vertical_projection (right_pt bottom) top is Some pt then - [:: pt; right_pt bottom] - else - [::] - else - if vertical_projection (right_pt top) bottom is Some pt then - no_dup_seq [:: right_pt top; pt] - else - [::]. - -Definition complete_last_open (c : cell) := - match c with - | Bcell lpts rpts le he => - Bcell lpts (rightmost_points le he) le he - end. - -Definition midpoint (p1 p2 : pt) : pt := - {| p_x := R_div (R_add (p_x p1) (p_x p2)) R2; - p_y := R_div (R_add (p_y p1) (p_y p2)) R2|}. - - (* The center of the cell is computed using the middle of the high edge - the middle of the low edge, and their middle. *) - -Definition cell_center (c : cell) := - midpoint - (midpoint (seq.last dummy_pt (left_pts c)) - (head dummy_pt (right_pts c))) - (midpoint (head dummy_pt (left_pts c)) - (seq.last dummy_pt (right_pts c))). - -Definition start_open_cell (bottom top : edge) := - Bcell (leftmost_points bottom top) [::] bottom top. - -Definition start (first_event : event) (bottom : edge) (top : edge) : - scan_state := - let (newcells, lastopen) := - opening_cells_aux (point first_event) - (path.sort edge_below (outgoing first_event)) bottom top in - (Bscan newcells lastopen [::] [::] - (close_cell (point first_event) (start_open_cell bottom top)) - top (p_x (point first_event))). - -Definition left_limit (c : cell) := p_x (seq.head dummy_pt (left_pts c)). - -Definition right_limit c := p_x (seq.head dummy_pt (right_pts c)). - -Definition cmp_option := cmp_option _ R_ltb. - -Definition strict_inside_closed p c := - negb (point_under_edge p (low c)) && - point_strictly_under_edge p (high c) && - (R_ltb (left_limit c) (p_x p) && - (R_ltb (p_x p) (right_limit c))). - -Definition bare_closed_cell_side_limit_ok c := - [&& size (left_pts c) != 0%N, - all (fun p : pt => R_eqb (p_x p) (left_limit c)) (left_pts c), - sorted (fun x y => R_ltb y x) [seq p_y p | p <- left_pts c], - (R_eqb - (area3 (head dummy_pt (left_pts c)) (left_pt (high c)) (right_pt (high c))) - R0 && valid_edge (high c) (head dummy_pt (left_pts c))), - (R_eqb - (area3 (seq.last dummy_pt (left_pts c)) (left_pt (low c)) (right_pt (low c))) - R0 && valid_edge (low c) (seq.last dummy_pt (left_pts c))), - size (right_pts c) != 0%N, - all (fun p : pt => R_eqb (p_x p) (right_limit c)) (right_pts c), - sorted (fun x y => R_ltb y x) [seq p_y p | p <- right_pts c], - (R_eqb (area3 (head dummy_pt (right_pts c)) - (left_pt (high c)) (right_pt (high c))) R0 && - valid_edge (high c) (head dummy_pt (right_pts c))) & - (R_eqb (area3 (seq.last dummy_pt (right_pts c)) (left_pt (low c)) - (right_pt (low c))) - R0 && valid_edge (low c) (seq.last dummy_pt (right_pts c)))]. - -Definition check_bounding_box (bottom top : edge) := - let cc := complete_last_open (start_open_cell bottom top) in - edge_below bottom top && - R_ltb (left_limit cc) (right_limit cc) && - bare_closed_cell_side_limit_ok cc && - strict_inside_closed (cell_center cc) cc. - -Definition complete_process (bottom top : edge) (events : seq event) : seq cell := - match events with - | [::] => - if check_bounding_box bottom top then - [:: complete_last_open (start_open_cell bottom top)] - else - [::] - | ev0 :: events => - let start_scan := start ev0 bottom top in - let final_scan := foldl step start_scan events in - map complete_last_open - (sc_open1 final_scan ++ lst_open final_scan :: sc_open2 final_scan) ++ - lst_closed final_scan :: sc_closed final_scan - end. - -(* This is the main function of vertical cell decomposition. *) -Definition edges_to_cells bottom top edges := - complete_process bottom top (edges_to_events edges). - -(* SECOND PART : computing a path in the cell graph *) -(* To compute a path that has reasonable optimzation, we compute a shortest *) -(* path between reference points chosen inside doors. *) - -(* defining the connection relation between adjacent cells. Two cells - are adjacent when it is possible to move from one cell directly to the - other without colliding an obstacle edge. In the data structure, it means - that they share a vertical edge. *) -Record vert_edge := - { ve_x : R; ve_top : R; ve_bot : R}. - -Definition vert_edge_eqb (v1 v2 : vert_edge) := - let: Build_vert_edge v1x v1t v1b := v1 in - let: Build_vert_edge v2x v2t v2b := v2 in - R_eqb v1x v2x && R_eqb v1t v2t && R_eqb v1b v2b. - -(* the lists of points left_pts and right_pts for each cell define the - extremities of the doors, but we wish to have a list of all doors, - obtained by making intervals between two points. *) -Fixpoint seq_to_intervals_aux [A : Type] (a : A) (s : seq A) := -match s with -| nil => nil -| b :: tl => (a, b) :: seq_to_intervals_aux b tl -end. - -Definition seq_to_intervals [A : Type] (s : seq A) := -match s with - nil => nil -| a :: tl => seq_to_intervals_aux a tl -end. - -(* Vertical edges are collected from the left_pts and right_pts sequences. *) -Definition cell_safe_exits_left (c : cell) : seq vert_edge := - let lx := p_x (head dummy_pt (left_pts c)) in - map (fun p => Build_vert_edge lx (p_y (fst p)) (p_y (snd p))) - (seq_to_intervals (left_pts c)). - -Definition cell_safe_exits_right (c : cell) : seq vert_edge := - let lx := p_x (head dummy_pt (right_pts c)) in - map (fun p => Build_vert_edge lx (p_y (fst p)) (p_y (snd p))) - (seq_to_intervals (right_pts c)). - -(* The index_seq function is a trick to circumvent the absence of a mapi - function in Coq code. It makes it possible to build a list of pairs, - where each element is annotated with its position in the list. *) -Definition index_seq {T : Type} (s : list T) : list (nat * T) := - zip (iota 0 (size s)) s. - -(* Given a set of cells (given as a sequence), we wish to construct all - the vertical edges (called doors) connecting two cells, and we wish each - door to contain information about the cells they are connected to, here - their rank in the sequence of cells. *) - -Definition door := (vert_edge * nat * nat)%type. - -Definition cells_to_doors (s : list cell) := - let indexed_s := index_seq s in - let vert_edges_and_right_cell := - flatten (map (fun '(i, c) => - (map (fun v => (v, i))) (cell_safe_exits_left c)) - indexed_s) in - let vert_edges_and_both_cells := - flatten (map (fun '(v, i) => - (map (fun '(i', c') => (v, i, i')) - (filter (fun '(i', c') => - existsb (vert_edge_eqb v) (cell_safe_exits_right c')) - indexed_s))) - vert_edges_and_right_cell) in - vert_edges_and_both_cells. - -Definition on_vert_edge (p : pt) (v : vert_edge) : bool := - R_eqb (p_x p) (ve_x v) && R_ltb (ve_bot v) (p_y p) && - R_ltb (p_y p) (ve_top v). - -Definition vert_edge_midpoint (ve : vert_edge) : pt := - {|p_x := ve_x ve; p_y := R_div ((R_add (ve_top ve) (ve_bot ve))) R2|}. - -(* When a vertical edge contains the source or the target, we wish this - point to be considered as the reference point for that edge. *) -Definition vert_edge_to_reference_point (s t : pt) (v : vert_edge) := - if on_vert_edge s v then s - else if on_vert_edge t v then t - else vert_edge_midpoint v. - -(* Each door has one or two neighboring cells, the neighboring doors - are those doors that share one of these neighboring cells. Here we only - want to know the index of the neighbors. We make sure to avoid including - the current door in the neighbors. *) -Definition one_door_neighbors - (indexed_doors : seq (nat * door)) - (i_d : nat * door) : list nat := - match i_d with - | (j, (v0, i0, i'0)) => - map fst - (filter (fun '(vi, (v, i, i')) => (Nat.eqb i i0 || Nat.eqb i i'0 || - Nat.eqb i' i0 || Nat.eqb i' i'0) && (negb (Nat.eqb j vi))) - indexed_doors) - end. - -(* For each extremity, we check whether it is already inside an existing - door. If it is the case, we need to remember the index of that door. - If the extremity is not inside a door, then we create a fictitious door, - where the neighboring cells both are set to the one cell containing this - point. *) -Definition add_extremity_reference_point - (indexed_cells : seq (nat * cell)) - (p : pt) (doors : seq door) := - let purported_index := - seq.find (fun '(v, _, _) => on_vert_edge p v) doors in - if purported_index < size doors then - (doors, purported_index) - else - let '(i, c) := - head (size indexed_cells, dummy_cell) - (filter (fun '(i', c') => strict_inside_closed p c') indexed_cells) in - (rcons doors ({|ve_x := p_x p; ve_top := p_y p; ve_bot := p_y p|}, i, i), size doors). - -(* This function makes sure that the sequence of doors contains a door - for each of the extremities, adding new doors when needed. It returns - the updated sequence of doors and the indexes for the doors containing - each of the extremities. *) -Definition doors_and_extremities (indexed_cells : seq (nat * cell)) - (doors : seq door) (s t : pt) : seq door * nat * nat := - let '(d_s, i_s) := - add_extremity_reference_point indexed_cells s doors in - let '(d_t, i_t) := - add_extremity_reference_point indexed_cells t d_s in - (d_t, i_s, i_t). - -(* In the end the door adjacency map describes the graph in which we - want to compute paths. *) -Definition door_adjacency_map (doors : seq door) : - seq (seq nat) := - let indexed_doors := index_seq doors in - map (fun i_d => one_door_neighbors indexed_doors i_d) indexed_doors. - -Definition dummy_vert_edge := - {| ve_x := R0; ve_top := R0; ve_bot := R0|}. - -Definition dummy_door := (dummy_vert_edge, 0, 0). - -(* To compute the distance between two doors, we compute the distance - between the reference points. TODO: this computation does not take - into account the added trajectory to go to a safe point inside the - cell where the doors are vertically aligned. *) -Definition distance (doors : seq door) (s t : pt) - (i j : nat) := - let '(v1, _, _) := seq.nth dummy_door doors i in - let '(v2, _, _) := seq.nth dummy_door doors j in - let p1 := vert_edge_to_reference_point s t v1 in - let p2 := vert_edge_to_reference_point s t v2 in - pt_distance (p_x p1) (p_y p1) (p_x p2) (p_y p2). - -(* The function cells_too_doors_graph constructs the graph with - weighted edges. *) -Definition cells_to_doors_graph (cells : seq cell) (s t : pt) := - let regular_doors := cells_to_doors cells in - let indexed_cells := index_seq cells in - let '(full_seq_of_doors, i_s, i_t) := - doors_and_extremities indexed_cells regular_doors s t in - let adj_map := door_adjacency_map full_seq_of_doors in - let neighbors_and_distances := - [seq [seq (j, distance full_seq_of_doors s t i j) | j <- neighbors] - | '(i, neighbors) <- index_seq adj_map] in - (full_seq_of_doors, neighbors_and_distances, i_s, i_t). - -(* We can now call the shortest path algorithm, where the nodes are - door indices. *) -Definition node := nat. - -Definition empty := @nil (node * seq node * option R). - -(* The shortest graph algorithm relies on a priority queue. We implement - such a queue by maintaining a sorted list of nodes. *) -Notation priority_queue := (list (node * seq node * option R)). - -Definition node_eqb := Nat.eqb. - -(* To find a element in the priority queue, we just traverse the list - until we find one node that that the same index. *) -Fixpoint gfind (q : priority_queue) n := - match q with - | nil => None - | (n', p, d) :: tl => if node_eqb n' n then Some (p, d) else gfind tl n - end. - -(* To remove an element, we traverse the list. Note that we only remove - the first instance. *) -Fixpoint remove (q : priority_queue) n := - match q with - | nil => nil - | (n', p', d') :: tl => - if node_eqb n' n then - tl - else - (n', p', d') :: remove tl n - end. - -(* To insert a new association in the priority queue, we are careful to - insert the node in the right place comparing the order. *) -Fixpoint insert (q : priority_queue) n p d := - match q with - | nil => (n, p, d) :: nil - | (n', p', d') :: tl => - if cmp_option d d' then - (n, p, d) :: q - else - (n', p', d') :: insert tl n p d - end. - -Definition update q n p d := - insert (remove q n) n p d. - -Definition pop (q : priority_queue) : - option (node * seq node * option R * priority_queue) := - match q with - | nil => None - | v :: tl => Some (v, tl) - end. - -(* This function takes as input the sequence of cells, the source and - target points. It returns a tuple containing: - - the graph of doors, - this graph is a sequence of pairs, where the first component is - is door, and the second component is the sequence of nodes - - the path, when it exists, - - the index of the doors containing the source and targt points *) -Definition c_shortest_path cells s t := - let '(adj, i_s, i_t) := cells_to_doors_graph cells s t in - (adj, shortest_path R R0 R_ltb R_add node node_eqb - (seq.nth [::] adj.2) i_s i_t _ empty - gfind update pop (iota 0 (size adj.2)), i_s, i_t). - -(* Each point used in the doors is annotated with the doors on which they - are and the cells they connect. The last information may be useless - since we have now door information. *) -Record annotated_point := - Apt { apt_val : pt; door_index : option nat; cell_indices : seq nat}. - -(* This value (1/16) of margin is suitable for the demo environment. In real - life, this should be a parameter of the algorithm. *) -Definition margin := R1 / ((R1 + R1) * - (R1 + R1) * (R1 + R1) * (R1 + R1) * (R1 * R1)). - - -(* Given two points p1 and p2 on a side of a cell, this computes a point - inside the cell that is a sensible intermediate point to move from p1 - to p2 while staying safely inside the cell. *) -Definition safe_intermediate_point_in_cell (p1 p2 : pt) (c : cell) - (ci : nat) := - let new_x := p_x (cell_center c) in - let new_y := R_div (R_add (p_y p1) (p_y p2)) R2 in - if R_ltb new_x (p_x p1) then - let new_pt := {|p_x := p_x p1 - margin; p_y := new_y|} in - if strict_inside_closed new_pt c then - Apt new_pt None (ci :: nil) - else - Apt (cell_center c) None (ci :: nil) - else - let new_pt := {|p_x := p_x p1 + margin; p_y := new_y|} in - if strict_inside_closed new_pt c then - Apt new_pt None (ci :: nil) - else - Apt (cell_center c) None (ci :: nil). - - -(* When two neighbor doors are aligned vertically, they have a neighboring - cell in common. This can be computed by looking at the intersection - between their lists of neighboring cells. *) -Definition intersection (s1 s2 : seq nat) := - [seq x | x <- s1 & existsb (fun y => Nat.eqb x y) s2]. - -Definition common_index (s1 s2 : seq nat) := - let intersect := intersection s1 s2 in - seq.head 0 intersect. - -Definition door_to_annotated_point s t (d : door) - (door_index : nat) := - let p' := vert_edge_to_reference_point s t d.1.1 in - let annot := - if Nat.eqb d.1.2 d.2 then [:: d.2] else [:: d.1.2 ; d.2] in - Apt p' (Some door_index) annot. - -Fixpoint a_shortest_path (cells : seq cell) - (doors : seq door * seq (seq (nat * R))) - s t (p : annotated_point) (path : seq node) := - match path with - | nil => [:: p] - | p'i :: tlpath => - let d' := seq.nth dummy_door doors.1 p'i in - let a_p' := door_to_annotated_point s t d' p'i in - if R_eqb (p_x (apt_val p)) (p_x (apt_val a_p')) then - let ci := common_index (cell_indices p) (cell_indices a_p') in - let p_extra : annotated_point := - safe_intermediate_point_in_cell (apt_val p) (apt_val a_p') - (seq.nth dummy_cell cells ci) ci in - p :: p_extra :: a_shortest_path cells doors s t a_p' tlpath - else - p :: a_shortest_path cells doors s t a_p' tlpath - end. - -Definition path_reverse (s : seq (annotated_point * annotated_point)) := - List.map (fun p => (snd p, fst p)) (List.rev_append s nil). - -Definition intersect_vert_edge (p1 p2 : pt) (ve : vert_edge) : pt := - Bpt (ve_x ve) - (p_y p1 + (ve_x ve - p_x p1) / (p_x p2 - p_x p1) * (p_y p2 - p_y p1)). - -Definition optim_three (doors : seq door) (p1 p2 p3 : annotated_point) := - let p1' := apt_val p1 in - let p3' := apt_val p3 in - if p2 is Apt p2' (Some d_i) cells then - let d := (seq.nth dummy_door doors d_i).1.1 in - if R_ltb (p_x p1') (ve_x d) && R_ltb (ve_x d) (p_x p3') then - if R_ltb R0 (area3 p1' p2' p3') then - if R_ltb R0 (area3 p1' p3' (Bpt (ve_x d) (ve_top d))) then - let p2_2 := intersect_vert_edge p1' p3' d in - Apt p2_2 (Some d_i) cells - else - if R_ltb (ve_bot d) (ve_top d - margin) then - Apt (Bpt (ve_x d) (ve_top d - margin)) (Some d_i) cells - else - p2 - else - if R_ltb (area3 p1' p3' (Bpt (ve_x d) (ve_bot d))) R0 then - let p2_2 := intersect_vert_edge p1' p3' d in - Apt p2_2 (Some d_i) cells - else - if R_ltb (ve_bot d + margin) (ve_top d) then - Apt (Bpt (ve_x d) (ve_bot d + margin)) (Some d_i) cells - else - p2 - else if R_ltb (p_x p3') (ve_x d) && R_ltb (ve_x d) (p_x p1') then - if R_ltb R0 (area3 p1' p2' p3') then - if R_ltb R0 (area3 p1' p3' (Bpt (ve_x d) (ve_bot d))) then - let p2_2 := intersect_vert_edge p1' p3' d in - Apt p2_2 (Some d_i) cells - else - if R_ltb (ve_bot d + margin) (ve_top d) then - Apt (Bpt (ve_x d) (ve_bot d + margin)) (Some d_i) cells - else - p2 - else - if R_ltb (area3 p1' p3' (Bpt (ve_x d) (ve_top d))) R0 then - let p2_2 := intersect_vert_edge p1' p3' d in - Apt p2_2 (Some d_i) cells - else - if R_ltb (ve_bot d) (ve_top d - margin) then - Apt (Bpt (ve_x d) (ve_top d - margin)) (Some d_i) cells - else - p2 - else - p2 - else - p2. - -Fixpoint local_improvements (doors : seq door) - (p : seq (annotated_point * annotated_point)) : - seq (annotated_point * annotated_point) := -match p with -| (p1, p2) :: ((_ , p3) :: _) as tl => - match local_improvements doors tl with - | [::] => p - | (_, p3') :: tl' => - let p2' := optim_three doors p1 p2 p3' in - (p1, p2') :: (p2', p3') :: tl' - end -| _ => p -end. - -Definition source_to_target - (cells : seq cell) (source target : pt) : - option (seq door * - seq (annotated_point * annotated_point)) := - let '(doors, opath, i_s, i_t) := - c_shortest_path cells source target in - if Nat.eqb i_s i_t then - Some (doors.1, [:: (Apt source None [::], Apt target None [::])]) - else - let last_point := - door_to_annotated_point source target - (seq.nth dummy_door doors.1 i_t) i_t in - if opath is Some path then - match a_shortest_path cells doors source target - last_point path with - | nil => None - | a :: tl => - Some(doors.1, - local_improvements doors.1 - (path_reverse (seq_to_intervals_aux a tl))) - end - else - None. - -(* THIRD PART: Producing a smooth trajectory. *) -(* We produce a smooth trajectory by replacing every angle by a Bezier curve. - We first add anchor points in the middle of each straight line segment. - These anchor points only have the constraints to be in a single cell and - the curve will pass through these anchor points no matter what - transformation will happen later. Then broken line paths between - anchor points are replaced by Bezier curves, thus keeping the invariant - that the new smooth path connects the anchor points correctly. *) - -(* The point of this function is to add anchor points in the middle - of each segment. The annotation for these anchor points is the - cell in which they appear, but this information is not going to play - a significant role in the current version of the program. *) -Fixpoint break_segments (s : seq (annotated_point * annotated_point)) : - seq (annotated_point * annotated_point) := - match s with - | (Apt p1 door_index1 a1, Apt p2 door_index2 a2) :: tl => - (Apt p1 door_index1 a1, Apt (midpoint p1 p2) None (intersection a1 a2)) :: - (Apt (midpoint p1 p2) None (intersection a1 a2), Apt p2 door_index2 a2) :: - break_segments tl - | nil => nil - end. - -(* The connection at anchor points is straight (because it comes - from a straight line segment. The connection between two anchor points - is a broken line (an angle). The idea is to replace this broken line - by a bezier curve, which by construction will be tangent with the - initial segment. However, there may be cases where this Bezier curve does - not pass through the authorized door. *) -Variant curve_element := - straight (x y : annotated_point) | bezier (x y z : annotated_point). - -(* This function assumes that every other straight line segment goes into - an angle, and the other go into a straight connection. The angles - (represented by adjacent pairs) are then replace by Bezier curves. - the last element is left as is. *) -(* The input of this function is guaranteed to have b = b' in the second - pattern matching rule below. *) -Fixpoint smoothen_aux (s : seq (annotated_point * annotated_point)) : - seq curve_element := -match s with -| nil => nil -| (a, b) :: nil => straight a b :: nil -(* Here we know the anonymous variable to have the same value as b *) -| (a, b) :: (_ , c) :: tl => bezier a b c :: smoothen_aux tl -end. - -(* Here we move from a sequence of straight line segments given by pairs - of points with anchor points to a sequence of curve elements. - Actually only the first one and the last one are straight, all the rest - are Bezier curve elements. *) -Definition smoothen (s : seq (annotated_point * annotated_point)) : - seq curve_element := -match s with -| (a, b) :: tl => straight a b :: smoothen_aux tl -| nil => nil -end. - -(* The curve produced by smoothen only guarantees to be a continuous - path from the initial point to the last point going through the anchor - points, but now we have lost the guarantee that this path goes through - the doors. The next functions detect collisions and repair the curve. *) - -(* We now have two functions to check whether a Bezier curve does pass - through the door. They implement specialized code and require fuel to - operate. the result is an optional boolean. When the boolean is given - and true, we are sure the curve passes through the door, when the - boolean is given and false, we are sure the curve hits an obstacle, - when the boolean is not given (answer is None), we don't know, but - for this algorithm, this is interpreted as a failure to pass through the - door. In practice, the fuel does not need to be big, because curve size - is divided by 2 at each iteration. - - This function is to be used when p_x a < p_x b < p_x c and - a b c is ccw (counter clockwise). It assumes that there is no need to - check the bottom point. *) -Fixpoint check_bezier_ccw (fuel : nat) (v : vert_edge) - (a b c : pt) : - option bool := -match fuel with -| O => None -| S p => - let top_of_edge := Bpt (ve_x v) (ve_top v) in - if negb (point_under_edge top_of_edge (Bedge a c)) then - Some true - else if - point_under_edge top_of_edge (Bedge a b) || - point_under_edge top_of_edge (Bedge b c) - then - Some false - else - let b' := midpoint a b in - let b2 := midpoint b c in - let c' := midpoint b' b2 in - if R_ltb (p_x c') (ve_x v) then - check_bezier_ccw p v c' b2 c - else if R_ltb (ve_x v) (p_x c') then - check_bezier_ccw p v a b' c' - else - if R_ltb (p_y c') (ve_top v) then - Some true - else - Some false -end. - -(* This function is to be used when p_x a < p_x b < p_x c and - a b c is cw (clockwise). - It assumes that there is no need to check the top point. *) -Fixpoint check_bezier_cw (fuel : nat) (v : vert_edge) - (a b c : pt) : - option bool := -match fuel with -| O => None -| S p => - let bot_of_edge := Bpt (ve_x v) (ve_bot v) in - if point_strictly_under_edge bot_of_edge (Bedge a c) then - Some true - else if - negb (point_strictly_under_edge bot_of_edge (Bedge a b)) || - negb (point_strictly_under_edge bot_of_edge (Bedge b c)) - then - Some false - else - let b' := midpoint a b in - let b2 := midpoint b c in - let c' := midpoint b' b2 in - if R_ltb (p_x c') (ve_x v) then - check_bezier_cw p v c' b2 c - else if R_ltb (ve_x v) (p_x c') then - check_bezier_cw p v a b' c' - else - if R_ltb (ve_bot v) (p_y c') then - Some true - else - Some false -end. - -(* This function verifies that the Bezier curve does pass through the - door that was initially given has a constraint for the broken line. This - is done by performing a dichotomy on the Bezier curve until we either - see explicitely that the condition is met or that the condition is - violated. When the condition is violated, a new Bezier curve is proposed - and by creating two new anchor points half way between the previous - anchor points and the chosen point (normally the middle of the door) and - verification starts again with the new Bezier curve, which is closer to - the broken line trajectory. - This function should normally be based on well-founded recursion, but - for executability we rely on a fuel, which does not need to be enormous - because the size of the bezier curve element is divided by 2 at each - iteration. - This function may replace a faulty curve element with a sequence of - three new elements, so all results have to be concatened later. *) -Definition fuel_constant := 20. - -Fixpoint check_curve_element_and_repair - (fuel : nat) doors (e : curve_element) : - seq curve_element := -match e with -| straight p1 p2 => straight p1 p2 :: nil -| bezier p1 p2 p3 => - if door_index p2 is Some n then - let vedge := - (seq.nth dummy_door doors n).1.1 in - let e' := - (if R_ltb (p_x (apt_val p1)) (p_x (apt_val p2)) then - bezier p1 p2 p3 - else - bezier p3 p2 p1) in - match e' with - |straight _ _ => e' :: nil - | bezier p1' p2' p3' => - let check_function := - if R_ltb R0 - (area3 (apt_val p1') (apt_val p2') (apt_val p3')) then - check_bezier_ccw - else - check_bezier_cw in - match check_function fuel_constant vedge - (apt_val p1')(apt_val p2')(apt_val p3') with - | Some true => bezier p1 p2 p3 :: nil - | _ => - match fuel with - | S p => - straight p1 - (Apt (midpoint (apt_val p1) (apt_val p2)) - None (cell_indices p1)) - :: - check_curve_element_and_repair p doors - (bezier (Apt (midpoint (apt_val p1) (apt_val p2)) None - (cell_indices p1)) - p2 - (Apt (midpoint (apt_val p2) (apt_val p3)) None (cell_indices p3))) - ++ - straight (Apt (midpoint (apt_val p2) (apt_val p3)) - None (cell_indices p3)) p3 :: nil - | _ => - straight p1 p2 :: straight p2 p3 :: nil - end - end - end - else - (bezier p1 p2 p3 :: nil) -end. - -Definition smooth_from_cells (cells : seq cell) - (initial final : pt) : seq curve_element := - match source_to_target cells initial final with - | Some (doors, s) => - List.concat - (List.map (check_curve_element_and_repair fuel_constant doors) - (smoothen (break_segments s))) - | None => nil - end. - -(* This function only computes the piecewise straight line trajectory, - starting from the sequence of edges and the source and target. *) -Definition point_to_point (bottom top : edge) (obstacles : seq edge) - (initial final : pt) : seq curve_element := - let cells := edges_to_cells bottom top obstacles in - match source_to_target cells initial final with - | Some (doors, s) => - List.map (fun '(a, b) => straight a b) s - | None => nil - end. - -(* This function wraps up all operations: - - constructing the cells - - constructing the broken line - - constructing the smooth line - - repairing the faulty bezier elements. *) -Definition smooth_point_to_point (bottom top : edge) (obstacles : seq edge) - (initial final : pt) : seq curve_element := - let cells := edges_to_cells bottom top obstacles in - smooth_from_cells cells initial final. - -End generic_implementation. diff --git a/theories/hulls.v b/theories/hulls.v deleted file mode 100644 index 650a1be..0000000 --- a/theories/hulls.v +++ /dev/null @@ -1,327 +0,0 @@ -Require Export encompass conv. -From mathcomp Require Import all_ssreflect all_algebra vector reals normedtype. -From mathcomp Require Import classical_sets boolp mathcomp_extra. -Require Import counterclockwise. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -From mathcomp.algebra_tactics Require Import ring. -From mathcomp.zify Require Import zify. - -Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory. - -Section hull_def. -Local Open Scope classical_set_scope. -Local Open Scope ring_scope. -Definition hull (R : realType) (T : lmodType R) (X : set T) : set T := - [set p : T | exists n (g : 'I_n -> T) (d : 'I_n -> R), - [/\ (forall i, 0 <= d i)%R, - (\sum_(i < n) d i = 1%R), - g @` setT `<=` X & - p = \sum_(i < n) (d i) *: (g i)] ]. -End hull_def. - -Module Spec := SpecKA(ccw_KA). - -Section spec. -Variable R : realType. -Let Plane := Plane R. - -Open Scope ring_scope. -Open Scope order_scope. - -Section hull_prop. -Local Open Scope classical_set_scope. -Variable A : lmodType R. -Implicit Types X Y : set A. - -Lemma subset_hull X : X `<=` hull X. -Proof. -move=> x xX; rewrite /hull; exists 1%N, (fun=> x), (fun=>1%R). -split=> //. -- by rewrite big_ord_recl big_ord0 addr0. -- by move=> d [i _ <-]. -- by rewrite big_ord_recl big_ord0 scale1r addr0. -Qed. - -Lemma hull0 : hull set0 = set0 :> set A. -Proof. -rewrite funeqE => d; rewrite propeqE; split => //. -move=> [n [g [e [e0 e1 gX ->{d}]]]]. -destruct n as [|n]; first by rewrite big_ord0 in e1; move:(@ltr01 R); rewrite e1 ltxx. -exfalso; apply: (gX (g ord0)); exact/imageP. -Qed. - -Lemma hull_eq0 X : (hull X == set0) = (X == set0). -Proof. -apply/idP/idP=> [/eqP abs|]; last by move=> /eqP ->; rewrite hull0. -apply/negPn/negP => /set0P[/= d] => dX. -move: abs; rewrite funeqE => /(_ d); rewrite propeqE /set0 => -[H _]; apply H. -exact/subset_hull. -Qed. - -Lemma hull_monotone X Y : X `<=` Y -> hull X `<=` hull Y. -Proof. -move=> H a [n [g [d [d0 d1 gX ae]]]]; exists n, g, d; split => //. -by eapply subset_trans; first exact: gX. -Qed. - -Lemma hull2 (x y : A) : - hull [set x; y]%classic = ((fun t => x <| t |> y) @` `[0%R, 1%R])%classic. -Proof. -rewrite eqEsubset; split; last first. - move=> z [t /andP [t0 t1]] <-. - rewrite bnd_simp in t0, t1. - exists 2%N, (fun i => if i == 0 then x else y), - (fun i => if i == 0 then t else `1- t). - split; first by case; case=>//= n _; rewrite subr_ge0. - - by rewrite big_ord_recl big_ord1/= addrCA subrr addr0. - - by move=>a[]; case; case=>/= [|n] _ _ <-; [left|right]. - - by rewrite big_ord_recl big_ord1. -move=>z [n][g][d][d0 d1 gxy ->]. -move:d1=>/esym/eqP; rewrite -subr_eq0 (bigID [pred i | g i == x])//= opprD. -rewrite addrCA addrC subr_eq0=>/eqP/esym=>d1. -exists (\sum_(i < n | g i == x) d i). - rewrite inE; apply/andP; rewrite 2!bnd_simp {2}d1 -[(_<=1)%R]subr_ge0 opprB. - by rewrite addrCA subrr addr0; split; apply sumr_ge0. -rewrite/conv {2}d1 opprB addrCA subrr addr0 [RHS](bigID [pred i | g i == x])//=. -congr (_ + _); rewrite scaler_suml; apply: congr_big=>// i. - by move=> /eqP ->. -have /gxy[->|->//] : range g (g i) by []. -by rewrite eqxx. -Qed. - -Lemma hull_convex X : forall x y, - (hull X) x -> (hull X) y -> hull [set x; y] `<=` hull X. -Proof. -move=> + + [n][g][d][d0 d1 gX->] [m][h][e][e0 e1 hX ->]. -rewrite hull2=>_ _ x [t] /andP. -rewrite !bnd_simp -[(_ <= 1)%R]subr_ge0 => [[t0 t1]] <-. -exists (n + m)%N, (fun i=> match split i with inl i => g i | inr i => h i end), - (fun i=> match split i with inl i => t * (d i) - | inr i => (`1- t) * e i end); split. -- by move=>i; case: (split i)=>j; apply mulr_ge0. -- rewrite big_split_ord/= -{1}(add_onemK t); congr +%R. - rewrite -{3}(mulr1 t) -{1}d1 mulr_sumr; apply congr_big=>// i _. - case: (splitP (lshift m i)). - by move=>j ij; congr (_ * d _); apply val_inj. - by move=> k/= ink; move: (ltn_ord i); rewrite ink -ltn_subRL subnn ltn0. - rewrite -{2}(mulr1 (`1- t)) -{1}e1 mulr_sumr; apply congr_big=>// i _. - case: (splitP (rshift n i))=>/=. - by move=> j/= nij; move: (ltn_ord j); rewrite -nij -ltn_subRL subnn ltn0. - by move=>j /eqP; rewrite eqn_add2l=>/eqP ij; congr (_ * e _); apply val_inj. -- by move=>y/= [i] _; case: split=>j <-; [ apply gX | apply hX ]. -- rewrite big_split_ord /conv; congr +%R; rewrite scaler_sumr; - apply congr_big => // i _; rewrite scalerA. - + case: (splitP (lshift m i)). - by move=> j ij; congr (_ * d _ *: g _); apply val_inj. - by move=> k/= ink; move: (ltn_ord i); rewrite ink -ltn_subRL subnn ltn0. - + case: (splitP (rshift n i)) =>/=. - by move=> j/= nij; move: (ltn_ord j); rewrite -nij -ltn_subRL subnn ltn0. - by move=> j /eqP; rewrite eqn_add2l => /eqP ij; congr (_ * e _ *: h _); apply val_inj. -Qed. - -End hull_prop. - -Let oriented := fun p q r : Plane => 0%:R <= det p q r. - -Lemma is_left_oriented (p q r : Plane) : - encompass.is_left oriented p q r = oriented p q r. -Proof. -apply/idP/idP; last by rewrite/encompass.is_left; move=>->; rewrite !orbT. -by move=>/or3P[| |//] /eqP re; subst r; rewrite /oriented det_cyclique; [ rewrite det_cyclique |]; rewrite det_alternate. -Qed. - -Lemma encompass_correct (l : seq Plane) (p : Plane) : - uniq l -> - (3 <= size l)%N -> - encompass (ccw (R:=R)) l l -> - encompass oriented [:: p] l -> - exists t : 'I_(size l) -> R, - (forall i, 0 <= t i)%R /\ (\sum_i t i = 1%:R) /\ p = \sum_i t i *: l`_i. -Proof. -move: l p. -have orientedW: forall a b c, encompass.is_left oriented a b c -> oriented a b c. - move=>a b c /or3P[| |//] /eqP<-; rewrite /oriented. - by rewrite 2!det_cyclique det_alternate. - by rewrite det_cyclique det_alternate. -have H3 a b c p : uniq [:: a; b; c] -> - encompass (ccw (R:=R)) [:: a; b; c] [:: a; b; c] -> - encompass oriented [::p] [:: a; b; c] -> - exists t : 'I_3 -> R, (forall i, 0 <= t i)%R /\ (\sum_i t i = 1%:R) /\ p = \sum_i t i *: [:: a; b; c]`_i. - rewrite/uniq !in_cons negb_or 2!in_nil 2!orbF=>/andP [/andP[/negPf ab /negPf ac] /andP[/negPf bc _]] /andP[/andP [_ /andP [h _]] _] /= /andP [/andP [/orientedW cap _]] /andP [/andP [/orientedW abp _]] /andP [/andP [/orientedW bcp _] _]. - move: h; rewrite/encompass.is_left bc eq_sym ab =>/= cab. - exists (fun i => [:: det c p b / det c a b; det c a p / det c a b; det p a b / det c a b]`_i); split. - case; case; [| case; [| case=>//]]; move=>/= _; (apply mulr_ge0; [| by rewrite invr_ge0; apply ltW]). - - by rewrite 2!det_cyclique. - - by []. - - by rewrite det_cyclique. - move: cab; rewrite /ccw lt0r=>/andP[cab _]. - split. - by rewrite !big_ord_recr big_ord0 /= add0r -2!mulrDl addrC addrA -decompose_det divff. - rewrite !big_ord_recr big_ord0 /= add0r. - apply (scalerI cab). - rewrite 2!scalerDr 3!scalerA 3!mulrA 3![det c a b * _]mulrC -3!mulrA divff// 3!mulr1. - apply/pair_eqP; apply/andP; split; apply/eqP; rewrite !develop_det /xcoord /ycoord; cbn; ring. -move=> l p. -elim: l=>// a; case=>// b; case=>// c; case. - by move=>IHl abc _; apply H3. -move=>d l IHl lu sl ll lp. -case labp: (oriented b (last d l) p). - move:H3=>/(_ a b (last d l) p); case. - - move: lu; apply subseq_uniq=>/=. - by rewrite eq_refl eq_refl -/(subseq [:: last d l] (c :: d :: l)) sub1seq in_cons mem_last orbT. - - apply (Spec.encompassll_subseq lu)=>//. - by rewrite /= eq_refl /= eq_refl -/(subseq [:: last d l] (c :: d :: l)) sub1seq in_cons mem_last orbT. - - apply/andP; split. - by move:lp=>/andP[lp _]; move:lp. - apply/andP; split. - by move:lp=>/andP[_ /andP[ap _]]. - by rewrite /=/encompass.is_left labp !orbT. - move=>f [f0 [f1 fp]]. - exists (fun i:'I_(size l).+4 => (i == ord0)%:R * f ord0 + (i == lift ord0 ord0)%:R * f (lift ord0 ord0) + (i == ord_max)%:R * f ord_max). - split. - move=>i. - apply addr_ge0; [apply addr_ge0|]; apply mulr_ge0; try apply f0; apply ler0n. - split; rewrite big_ord_recr /= eq_refl mul1r 2!mul0r 2!add0r big_ord_recl /= mul1r 2!mul0r 2!addr0 big_ord_recl /= mul1r 2!mul0r addr0 add0r. - rewrite -f1 ![\sum_i f _]big_ord_recl big_ord0 addr0 -!addrA; congr (_ + (_ + _)). - rewrite -[f (lift _ (lift _ _))]add0r; congr (_ + f _); last by apply val_inj. - rewrite -{3}(mul0r (\sum_(i < (size l).+1) 0)) mulr_sumr. - apply congr_big=>// [[i ilt]] _. - have ->: (widen_ord (leqnSn (size l).+3) (lift ord0 (lift ord0 (Ordinal ilt))) == ord_max) = false. - by apply /negP=>/eqP/(f_equal val)/=; rewrite /bump/= 2!add1n=>/eqP; rewrite 2!eqSS=>/eqP ile; move:ilt; rewrite -ile ltnn. - by rewrite 3!mul0r 2!addr0. - rewrite fp ![\sum_i f _ *: _]big_ord_recl big_ord0 addr0 -!addrA; congr (_ + (_ + _)). - rewrite (nth_last _ (d :: l))/= -[f (lift _ (lift _ _)) *: _]add0r; congr (_ + f _ *: _); last by apply val_inj. - rewrite -{1}(scale0r (\sum_(i < (size l).+1) 0)) scaler_sumr. - apply congr_big=>// [[i ilt]] _. - have ->: (widen_ord (leqnSn (size l).+3) (lift ord0 (lift ord0 (Ordinal ilt))) == ord_max) = false. - by apply /negP=>/eqP/(f_equal val)/=; rewrite /bump/= 2!add1n=>/eqP; rewrite 2!eqSS=>/eqP ile; move:ilt; rewrite -ile ltnn. - by rewrite 2!mul0r 2!addr0 2!scale0r. -case: IHl. - - by move: lu=>/andP[_ lu]. - - by []. - - move: ll=>/Spec.encompassll_subseq; apply=>//; apply subseq_cons. - - apply/andP; split. - 2: by move: lp=>/andP[_ /andP [_ lp]]. - rewrite/= andbT; apply/or3P/Or33. - by rewrite/oriented det_inverse 2!det_cyclique leNgt oppr_lt0; apply/negP=>/ltW; move: labp; rewrite /oriented=>->. -move=>f [f0 [f1 fp]]. -exists (fun i=> - match ord_S_split i with - | inleft j => f (proj1_sig j) - | inright _ => 0%:R - end). -split. - by move=>i; case: (ord_S_split i). -split; rewrite big_ord_recl; (case (ord_S_split ord0); [ by move=>[j H] | move=>_]); [| rewrite scale0r]; rewrite add0r. - rewrite -f1; apply congr_big=>// [[i ilt]] _. - case (ord_S_split _)=>// [[j jlt]] /=; congr (f _); apply val_inj=>/=. - by move:jlt=>/(f_equal val)=>/=/eqP; rewrite /bump/= 2!add1n eqSS=>/eqP. -rewrite fp; apply congr_big=>// [[i ilt]] _. -case (ord_S_split _)=>// [[j jlt]] /=; congr (f _ *: _); apply val_inj=>/=. -by move:jlt=>/(f_equal val)=>/=/eqP; rewrite /bump/= 2!add1n eqSS=>/eqP. -Qed. - -Lemma detD (p q r : Plane) : det 0 p (q+r) = det 0 p q + det 0 p r. -Proof. by rewrite 3!det_scalar_productE /scalar_product/=; ring. Qed. - -Lemma det_sum (p : Plane) (n : nat) (f : 'I_n -> Plane) : - det 0 p (\sum_(i < n) f i) = \sum_(i < n) det 0 p (f i). -Proof. -elim: n f. - by move=>f; rewrite 2!big_ord0 -det_cyclique det_alternate. -move=>n IHn f. -by rewrite 2!big_ord_recl detD IHn. -Qed. - -Lemma encompass_complete (l : seq Plane) (p : Plane) : - uniq l -> - (3 <= size l)%N -> - encompass (ccw (R:=R)) l l -> - (exists t : 'I_(size l) -> R, - (forall i, 0 <= t i)%R /\ - (\sum_i t i = 1%:R) /\ - p = \sum_i t i *: l`_i) -> - encompass oriented [:: p] l. -Proof. -move=>lu ls ll [f [f0 [f1 fp]]]; subst p. -rewrite encompass_all_index; apply/andP; split. - by case: l lu ls ll f f0 f1. -apply/forallP=>[[i ilt]]. -rewrite/= andbT is_left_oriented /oriented. -wlog: l lu ls ll f f0 f1 i ilt / l`_i == 0%R. - move=>h. - set l' := [seq x - l`_i | x <- l]. - have subl': forall a b, (a < size l) -> (b < size l) -> l'`_a - l'`_b = l`_a - l`_b. - by move=>a b al bl; rewrite (nth_map 0)// (nth_map 0)// opprD [-_ - - _]addrC -!addrA; congr GRing.add; rewrite addrA subrr add0r. - suff: (0%:R <= det l'`_i l'`_(Zp_succ (Ordinal ilt)) (\sum_(i0 < size l) f i0 *: l'`_i0))%R. - congr (_ <= _)%R; rewrite 2!det_scalar_productE; congr (scalar_product _ (rotate _)). - - by apply subl'=>//; case: (Zp_succ (Ordinal ilt)). - - rewrite [l'`_i](nth_map 0)// subrr subr0 -[l`_i]scale1r. - have->: (1 = 1%:R)%R by []. - rewrite -f1 scaler_suml -sumrB; apply congr_big=>// [[j jlt]] _. - by rewrite -scalerBr (nth_map 0). - move:h=>/(_ l'); rewrite size_map; apply. - - rewrite map_inj_uniq=>//; apply addIr. - - by []. - - rewrite Spec.encompassll_spec. - 2: by rewrite map_inj_uniq=>//; apply addIr. - apply/andP; split. - by destruct l. - rewrite size_map. - apply/forallP=>[[a alt]]. - apply/forallP=>[[b blt]]. - apply/forallP=>[[c clt]]. - apply/implyP=>abc. - rewrite /ccw_KA.OT /ccw det_scalar_productE subl'// subl'//. - by move:ll; rewrite Spec.encompassll_spec=>// /andP[_] /forallP /(_ (Ordinal alt)) /forallP /(_ (Ordinal blt)) /forallP /(_ (Ordinal clt)) /implyP /(_ abc); rewrite /ccw_KA.OT /ccw det_scalar_productE. - - apply f0. - - exact f1. - - by rewrite (nth_map 0)// subrr. -move=>/eqP li0; rewrite li0 det_sum; apply sumr_ge0=>[[j jlt]] _. -rewrite det_scalar_productE 2!subr0 rotateZ scalar_productZR; apply mulr_ge0. - apply f0. -move:ll; rewrite encompassE =>/andP[_ /allP ll]. -have/ll: l`_(Ordinal jlt) \in l by rewrite mem_nth. -rewrite encompass_all_index=>/andP[_] /forallP /(_ (Ordinal ilt))/=; rewrite andbT. -rewrite li0// => /or3P[/eqP ->|/eqP ->|]. -- by rewrite -{2}(scale0r 0) rotateZ scalar_productZR mul0r. -- by rewrite scalar_product_rotatexx. -- by rewrite /ccw det_scalar_productE 2!subr0=>/ltW. -Qed. - -Lemma encompassP (l : seq Plane) (p : Plane) : - uniq l -> - (3 <= size l)%N -> - encompass (ccw (R:=R)) l l -> - reflect (p \in hull (fun x => x \in l)) (encompass oriented [:: p] l). -Proof. -move=>lu ls ll; apply/(iffP idP). - move=>/(encompass_correct lu ls ll)[f [f0 [f1 ->]]]. - rewrite inE/hull/=; exists (size l), (fun i=> l`_i), f; split => //. - by move =>// x/= [i] _ <-{x}; exact: (@mem_nth Plane). -rewrite inE/hull/= =>[[n [g [d [d0 d1 gl pe]]]]]. -apply encompass_complete=>//. -exists (fun i=> \sum_(j < n | g j == l`_i) d j); split. - by move=>i; apply sumr_ge0. -split. - rewrite -(big_map (fun i: 'I_(size l) => l`_i) xpredT (fun x=> \sum_(j < n | g j == x) d j)). - rewrite (map_comp (fun i : nat => l`_i) (@nat_of_ord (size l))). - move:(val_enum_ord (size l)); rewrite enumT=>->. - rewrite map_nth_iota0// take_size -big_partition//. - by apply/allP=>i _; apply gl. -transitivity (\sum_(i < size l) \sum_(j < n | g j == l`_i) d j *: g j). - rewrite -(big_map (fun i: 'I_(size l) => l`_i) xpredT (fun x=> \sum_(j < n | g j == x) d j *: g j)). - rewrite (map_comp (fun i : nat => l`_i) (@nat_of_ord (size l))). - move:(val_enum_ord (size l)); rewrite enumT=>->. - rewrite map_nth_iota0// take_size -big_partition//. - by apply/allP=>i _; apply gl. -apply congr_big=>//i _. -rewrite scaler_suml. -by apply congr_big=>//j/eqP->. -Qed. - -End spec. diff --git a/theories/intersection.v b/theories/intersection.v deleted file mode 100644 index ea9d5b0..0000000 --- a/theories/intersection.v +++ /dev/null @@ -1,371 +0,0 @@ -Require Export counterclockwise conv encompass preliminaries. -From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals. -From mathcomp Require Import normedtype order boolp classical_sets. -From mathcomp Require Import constructive_ereal. - -(******************************************************************************) -(* separated a b c d == true if a = b or (ab) intersects [c,d] *) -(* intersect a b c d == true if [a, b] and [c, d] intersect *) -(******************************************************************************) - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -From mathcomp.algebra_tactics Require Import ring. -From mathcomp.zify Require Import zify. - -Import GRing Num.Theory Order.POrderTheory Order.TotalTheory. - -Local Open Scope order_scope. -Local Open Scope ring_scope. - -Module Spec := SpecKA(ccw_KA). - -Section Plane. -Variable R : realType. -Let Plane := Plane R. - -Definition separate (a b c d : Plane) := (det a b c * det a b d <= 0) && - ((a == b) ==> between a c d) && - ((det a b c == 0) ==> (det a b d == 0) ==> (a != b) ==> - [|| between a c d, between b c d | (between c a b && between d a b)]). - -Lemma separateCl (a b c d : Plane) : separate a b c d = separate b a c d. -Proof. -rewrite/separate 2![det _ b _]det_inverse mulrN mulNr opprK. -rewrite -2![det a _ _]det_cyclique 2!oppr_eq0 eq_sym. -rewrite orbA (orbC (_ a c d)) -orbA. -congr (_ && _ && (_ ==> _ ==> _ ==> (_ || _))). -- by apply implyb_id2l=>/eqP->. -- by rewrite !(@betweenC _ _ a b). -Qed. - -Lemma separateCr (a b c d : Plane) : separate a b c d = separate a b d c. -Proof. -rewrite/separate mulrC ![_ _ c d]betweenC; congr andb. -by rewrite -Bool.implb_curry andbC Bool.implb_curry andbC. -Qed. - -Definition intersect (a b c d : Plane) := separate a b c d && separate c d a b. - -Lemma intersectCl (a b c d : Plane) : intersect a b c d = intersect b a c d. -Proof. by rewrite/intersect separateCl; congr andb; apply separateCr. Qed. - -Lemma intersectCr (a b c d : Plane) : intersect a b c d = intersect a b d c. -Proof. by rewrite/intersect separateCr; congr andb; apply separateCl. Qed. - -Lemma intersect_correct a b c d : intersect a b c d -> - exists p, between p a b && between p c d. -Proof. -have sm t u : t *: (u : R^o) = t * u by []. -wlog abc0: a b c d / 0 <= det a b c. - move=>h. - case ge0: (0 <= det a b c); first by apply h. - move:ge0=>/negP/negP; rewrite leNgt -oppr_gt0 -det_inverse -det_cyclique negbK intersectCl=>/ltW ge0 bacd. - by move:(h _ _ _ _ ge0 bacd)=>[p]; rewrite betweenC=>pb; exists p. -case ab: (a == b). - by move=>/andP[/andP[/andP[_]]]; rewrite ab/==>acd _ _; exists a; rewrite betweenl. -case cd: (c == d). - by move=>/andP[_]/andP[/andP[_]]; rewrite cd/==>cab _; exists c; rewrite betweenl andbT. -move=>/andP[/andP [/andP[absep _] ab0]] /andP[/andP[cdsep _] cd0]. -move: abc0; rewrite le0r => /orP[|]. - move=>/eqP/det0_aligned; case; first by move=>abe; move:ab; rewrite abe eqxx. - move=>[t] ce; move: cdsep cd0; rewrite cd -ce 2!det_conv -![det _ d _]det_cyclique 2!det_alternate /conv 4!sm 2!mulr0 add0r addr0 det_inverse -det_cyclique mulrN mulNr mulrACA oppr_le0. - case tlt: ((1-t) * t < 0). - rewrite nmulr_rge0// -expr2=>badle. - have-> : (det b a d = 0) by apply/eqP; rewrite -sqrf_eq0; apply/eqP/le_anti/andP; split=>//; apply sqr_ge0. - rewrite 2!mulr0 oppr0 eqxx/= =>/or3P[| |]; last first. - by move=>/andP[acd _]; exists a; rewrite betweenl. - by exists d; rewrite betweenr andbT. - by move=> cdb; exists (a <| t |> b); rewrite betweenl andbT. - move=>_ _; exists (a <| t |> b); rewrite betweenl andbT; apply between_conv. - by exists t; rewrite eqxx andbT in01M_ge0 leNgt mulrC tlt. -move:ab0=> _ abc; move:absep; rewrite pmulr_rle0// =>abd. -set t := det a b d / (det d a b - det c a b). -have denom: det d a b - det c a b != 0 by rewrite 2![det _ a b]det_cyclique subr_eq0; apply/negP=>/eqP detE; move:(le_lt_trans abd abc); rewrite detE ltxx. -have: det a b (c <| t |> d) == 0 by rewrite -det_cyclique det_conv convrl sm -opprB mulrN /t -mulrA [_^-1 * _]mulrC divff// mulr1 det_cyclique subrr. -move=>/eqP /det0_aligned; case; first by move=>/eqP; rewrite ab. -move=>[u utE]. -case u01: (in01 u). - exists (a <| u |> b); apply/andP; split. - apply between_conv. - by exists u; rewrite u01 eqxx. - rewrite utE; apply between_conv. - exists t; rewrite eqxx andbT in01M_ge0 -(divff denom) /t -mulrBl mulrACA addrAC ![det _ a b]det_cyclique subrr add0r mulrN -mulNr -expr2; apply mulr_ge0; last first. - by apply sqr_ge0. - by apply mulr_ge0; [ rewrite oppr_ge0 | apply ltW ]. -move:u01; rewrite in01M_ge0 leNgt=>/negbT; rewrite negbK=>u01. -move:(u01); rewrite -oppr_gt0 lt0r oppr_eq0 mulf_eq0 negb_or=>/andP[/andP [/lregP u0 /lregP u1] _]. -have: det (a <| u |> b) c d == 0 by rewrite utE det_conv -[det d _ _]det_cyclique 2!det_alternate convmm. -rewrite det_conv 2![det _ c d]det_cyclique addr_eq0 2!sm=>/eqP udetE. -move:cdsep; rewrite -(nmulr_rge0 _ u01) mulrACA udetE mulNr oppr_ge0 -expr2=>det2_le0. -have /eqP cdb0: det c d b == 0 by rewrite -(mulrI_eq0 _ u1) -sqrf_eq0; apply/eqP/le_anti/andP; split=>//; apply sqr_ge0. -move:udetE=>/eqP; rewrite cdb0 mulr0 oppr0 mulrI_eq0// =>/eqP cda0. -move:cd0; rewrite cdb0 cda0 eqxx cd/= =>/or3P[cab|dab|]; last first. -- by move=>/andP[acd _]; exists a; rewrite betweenl. -- by exists d; rewrite betweenr andbT. -- by exists c; rewrite betweenl andbT. -Qed. - -Lemma intersect_complete a b c d : - (exists p, between p a b && between p c d) -> intersect a b c d. -Proof. -have sm: forall t u, t *: (u : R^o) = t*u by []. -move:a b c d. -suff: forall a b c d, (exists p : counterclockwise.Plane R, between p a b && between p c d) -> separate a b c d. - move=> h a b c d abcd; apply/andP; split; apply h=>//. - by move:abcd=>[p]; rewrite andbC=>pabcd; exists p. - move=>a b c d [p] /andP[/between_conv] [t] /andP[t01] /eqP pe /between_conv [u] /andP[u01] /eqP pe'; subst p; rewrite/separate -andbA. -apply/andP; split. - have: det (a <| t |> b) a b == 0 by rewrite det_conv -[det b a b]det_cyclique 2!det_alternate convmm. - rewrite pe' det_conv 2![det _ a b]det_cyclique addr_eq0 2!sm=>/eqP detE. - move:u01; rewrite in01M_ge0 le0r =>/orP[|]. - rewrite mulf_eq0 subr_eq0 => /orP[|] /eqP ue; move:detE=>/eqP. - by rewrite ue mul0r subr0 mul1r eq_sym oppr_eq0=>/eqP->; rewrite mulr0. - by rewrite -ue mul1r subrr mul0r oppr0=>/eqP->; rewrite mul0r. - by move=>ui; rewrite -(pmulr_rle0 _ ui) mulrACA detE mulNr oppr_le0 -expr2; apply sqr_ge0. -case ab : (a == b)=>/=. - by move: ab=>/eqP ab; subst b; rewrite 2!det_alternate eqxx/= andbT; apply between_conv; exists u; apply/andP; split=>//; rewrite -pe' convmm. -apply/implyP=>/eqP/det0_aligned[]; first by move=>/eqP; rewrite ab. -move=>[t'] ce; apply/implyP=> /eqP/det0_aligned[]; first by move=>/eqP; rewrite ab. -move=>[u'] de. -wlog: c d u t' u' pe' u01 ce de / t' <= u'. - move=>h. - case tu: (t' <= u'); first by apply (h c d u t' u'). - move:tu; rewrite leNgt=>/negbT; rewrite negbK=>/ltW ut. - by rewrite 2![_ _ c d]betweenC andbC; apply (h d c (1-u) u' t')=>//; rewrite -?in01_onem -?convC. -move=>tu. -move:pe'; rewrite -{1}ce -{1}de /conv 3![(_ - _) *: b]scalerBl scale1r 3![_ *: _ + (_ - _)]addrCA -3!scalerBr 2![_ *: (_ + _ *: _)]scalerDr addrACA -scalerDl [u+(1-u)]addrCA subrr addr0 scale1r 2!scalerA -scalerDl=>/addrI/eqP. -rewrite -subr_eq0 -scalerBl scaler_eq0 2!subr_eq0 ab orbF=>tconv. -case t0: (t' < 0). - apply/or3P/Or32. - apply/between_depl; exists (a-b), t', u'; rewrite -ce -de 2!convrl 2!eqxx 2!andbT nmulr_rle0//. - move:u01 tconv=>/andP[u0]; rewrite -[u<=1]subr_ge0 le0r subr_eq0 -invr_gt0 => /orP[|]. - by move=>/eqP<-; rewrite subrr mul1r mul0r addr0=>/eqP te; move:t01=>/andP[]; rewrite te leNgt t0. - move=>ugt0. - have un0: (1-u)^-1 != 0 by apply/negP=>/eqP ue; move:ugt0; rewrite ue ltxx. - move:un0 (un0); rewrite {1}invr_eq0=>un0 /rregP ureg. - rewrite -subr_eq0 -(mulIr_eq0 _ ureg) opprD addrA mulrBl mulrAC divff// mul1r subr_eq0=>/eqP<-; apply mulr_ge0; last by apply ltW. - apply addr_ge0; first by move:t01=>/andP[t0' _]. - by rewrite -mulrN mulr_ge0 // oppr_ge0 ltW. -move:t0=>/negbT; rewrite -leNgt=>t0. -case u1: (1 < u'). - apply/or3P/Or31. - apply/between_depl; exists (b - a), (1 - t'), (1 - u'); rewrite -2!convlr ce de 2!eqxx 2!andbT. - move:u01 tconv=>/andP; rewrite le0r=>[[/orP[|]]]. - move=>/eqP-> _; rewrite subr0 mul0r mul1r add0r=>/eqP tu'. - by move:t01; rewrite tu'=>/andP[_]/(lt_le_trans u1); rewrite ltxx. - move:u1; rewrite -subr_lt0=>ugt1 u0 u1; rewrite nmulr_lle0//. - have un0 : u != 0 by rewrite gt_eqF. - move:(un0); rewrite -invr_eq0=>/rregP ureg. - rewrite -subr_eq0 -(mulIr_eq0 _ ureg) opprD addrCA addrC mulrBl mulrAC divff// mul1r subr_eq0=>/eqP<-; rewrite -(pmulr_rge0 _ u0) mulrBr mulrCA divff// 2!mulr1 opprB addrA subr_ge0. - move:t01=>/andP[_] t1. - apply (le_trans t1); rewrite -subr_ge0 addrAC -opprB -mulrN1 -mulrDr [-1+_]addrC. - by rewrite mulr_ge0// subr_ge0// -subr_le0 ltW. -move:u1=>/negbT; rewrite -leNgt=>u1. -apply/or3P/Or33. -apply/andP; split; apply between_conv. - by exists t'; rewrite ce eqxx andbT /in01 t0/= (le_trans tu). -by exists u'; rewrite de eqxx andbT /in01 u1 (le_trans t0). -Qed. - -Lemma is_left_oriented (p q r : Plane) : - encompass.is_left (@wccw R) p q r = wccw p q r. -Proof. -apply/idP/idP; last by rewrite/encompass.is_left; move=>->; rewrite !orbT. -by move=>/or3P[| |//] /eqP re; subst r; rewrite /wccw det_cyclique; - [rewrite det_cyclique |]; rewrite det_alternate. -Qed. - -(* We prove that if a segment does not intersect the border of a - convex set C, then either the segment is included in C, or they are - disjoint. - - C is represented by a list of points that generate it (as given by - the output of Jarvis' algorithm). - - We prove the result by contradiction, assuming that one point of - the segment lies inside C and another one is outside. We - immediately reduce to the case where the ends of the segment verify - this property. - - Let [a, b] be the segment, with a in C and b outside. Notice that - t \mapsto b <| t |> a is a continuous curve from a to b, hence we - expect it to cross the border of C. Let I = \{t \in [0, 1], - b <| t |> a \in C\} and t = sup(I). t is well defined because I is not - empty (as 0 \in I) and bounded (by 1). C being defined by a set of - large inequalities, - - we show b <| t |> a \in C. Then we show that at - least one inequality is an equality. Let this constraint being - given by two points x and y of the list defining C. Then b <| t |> a - is on the line (xy) and every other point of the list is strictly - to the left of the line (xy), hence every other inequality is - strict. Then, looking at the inequalities involving x and y, we - show that b <| t |> a is between x and y, which concludes the proof. - *) - -Lemma hull_border_no_intersection (l : seq Plane) (a b : Plane) : - (3 <= size l)%N -> - uniq l -> - encompass (@ccw R) l l -> - (forall i : 'I_(size l), ~~ intersect l`_i l`_i.+1mod a b) -> - (forall t, in01 t -> - encompass (@ccw R) [:: a <| t |> b] l) \/ - (forall t, in01 t -> - ~~ encompass (@wccw R) [:: a <| t |> b] l). -Proof. -have sm t u : t *: (u : R^o) = t * u by []. -move=> ls /uniqP lu ll lab. -have l0 : l != [::] by destruct l. -(* We start the proof by contradiction. *) -apply/or_asboolP/negPn; rewrite negb_or; apply/negP => /andP[/existsp_asboolPn [t /asboolPn]]. -rewrite asbool_imply negb_imply 2!asboolb => /andP[t01 ltab]. -move=> /existsp_asboolPn [u /asboolPn]. -rewrite asbool_imply negb_imply 2!asboolb negbK => /andP[u01 luab]. -(* We have two points, exactly one of them being encompassed by l, - we may assume that they are the ends of the segment. *) -wlog : a b t u lab t01 ltab u01 luab / (t == 0) && (u == 1). - move=> /(_ (a <| u |> b) (a <| t |> b) 0 1); apply. - - move=> i. - apply/negP => /intersect_correct[p]/andP[pl pab]. - move: (lab i) => /negP; apply; apply intersect_complete. - exists p; apply/andP; split=>//; refine (between_trans _ _ pab). - by apply between_conv; exists u; apply/andP; split => //. - by apply between_conv; exists t; apply/andP; split => //. - - by apply in010. - - by rewrite conv0. - - by apply in011. - - by rewrite conv1. - - by apply/andP; split. -move=>/andP[/eqP t0 /eqP u1]; subst t u; clear t01 u01. -move:ltab luab; rewrite conv0 conv1 => lb la. -(* We define I = \{t \in R, b <| t |> a is encompassed by l\}. - We show that I is not empty and bounded. *) -set I := [set t | in01 t && encompass (@wccw R) [:: b <| t |> a] l]%classic. -have I0 : I 0 by apply/andP; split; [apply in010 | rewrite conv0 ]. -have Ib : has_sup I. - split; first by exists 0. - by exists 1 => x /andP[/andP[_]]. -move: la; rewrite encompass_all_index l0/= =>/forallP. -setoid_rewrite andbT. -setoid_rewrite is_left_oriented; rewrite /wccw => la. -(* All constraints being a large inequality, they are all satisfied by sup I. *) -have lt (i : 'I_(size l)) : wccw l`_i l`_i.+1mod (b <| sup I |> a). - rewrite /wccw leNgt -det_cyclique det_conv convrl sm -opprB mulrN. - rewrite subr_lt0; apply/negP=>liI. - have abl0 : 0 < det a l`_i l`_i.+1mod - det b l`_i l`_i.+1mod. - rewrite ltNge; apply/negP => abl. - move: (sup_upper_bound Ib)=>/(_ 0 I0)Ige. - move:(mulr_le0_ge0 abl Ige); rewrite mulrC=>/(lt_le_trans liI). - rewrite ltNge=>/negP; apply. - by rewrite det_cyclique; apply la. - move:abl0 (abl0); rewrite {1}lt0r => /andP[abl0 _]. - rewrite -invr_gt0 => abl_gt0. - move:(liI); rewrite -subr_gt0 -(pmulr_lgt0 _ abl_gt0) mulrBl. - rewrite -mulrA divff// mulr1 => eps0. - move: (sup_adherent eps0 Ib) => [t]/andP[t01]. - rewrite encompass_all_index l0/= => /forallP/(_ i). - rewrite andbT is_left_oriented /wccw -det_cyclique det_conv convrl. - rewrite sm -opprB mulrN -(pmulr_lge0 _ abl_gt0) mulrBl -mulrA. - rewrite divff// mulr1 subr_ge0=>lit. - rewrite opprB addrCA subrr addr0=>/(le_lt_trans lit). - by rewrite ltxx. -have I1 : sup I <= 1. - apply sup_le_ub; first by exists 0. - by move=>x /andP[/andP[_]]. -(* At least one inequality is an equality, otherwise we would find - t > sup I that verifies all of them. *) -have : [exists i : 'I_(size l), det l`_i l`_i.+1mod (b <| sup I |> a) <= 0]. - move:I1; rewrite -subr_ge0 le0r subr_eq0 subr_gt0 => /orP[/eqP<-| I1]. - rewrite conv1; move:lb; rewrite encompass_all_index l0/= =>/forallPn[i]. - rewrite andbT !negb_or -leNgt =>/andP[_] /andP[lb det_le0]. - by apply/existsP; exists i. - rewrite -[_ _ _]negbK; apply/negP =>/existsPn Isubopt. - (* Each inequality defines a quantity by which we may exceed sup I - without falsifying it. The inequalities being strict, these - quantities are all positive, hence their mini too. Alas, R has - no maximum, and hence min has no neutral elemnt, so we work in - \bar R. *) - set t := \meet_(i < size l | 0 < det a l`_i l`_i.+1mod - det b l`_i l`_i.+1mod) - ((det l`_i l`_i.+1mod a) / (det l`_i l`_i.+1mod a - det l`_i l`_i.+1mod b))%:E. - have It : ((sup I)%:E < mine t 1%:E)%E. - rewrite ltxI lte_fin I1 andbT ereal_meets_gt// ?ltey//. - move=>i abl_gt0; move:(abl_gt0); rewrite lt0r=>/andP[abl0 _]. - rewrite lte_fin -subr_gt0 -(pmulr_lgt0 _ abl_gt0) mulrBl mulrAC -mulrA. - rewrite -2![det l`_i _ _]det_cyclique divff// mulr1. - by move:(Isubopt i); rewrite -ltNge -det_cyclique det_conv convrl sm -opprB mulrN. - have tfin : (fine (mine t 1%:E))%:E = mine t 1%:E. - apply/(@fineK R)/fin_numP; split; apply/negP=>/eqP tinf. - suff : (-oo < mine t 1)%E by rewrite tinf ltxx. - rewrite ltxI; apply/andP; split; last by apply: ltNye. - by apply ereal_meets_gt=>// i _; apply ltNye. - suff : (mine t 1 < +oo)%E by rewrite tinf ltxx. - by rewrite ltIx [(1 < +oo)%E]ltey orbT. - move: It; rewrite -tfin lte_fin ltNge=>/negP; apply. - have t01: in01 (fine (mine t 1%E)). - apply/andP; split; rewrite -lee_fin tfin; last by rewrite lteIx le_refl orbT. - rewrite ltexI; apply/andP; split; last by rewrite lee_fin ler01. - apply: Order.TMeetTheory.meets_ge => i abgt; rewrite lee_fin; apply: (mulr_ge0 (la _)). - by apply ltW; rewrite invr_gt0 -2![det l`_i _ _]det_cyclique. - apply: sup_upper_bound => //; apply/andP; split => //. - rewrite encompass_all_index l0/=; apply/forallP => i. - rewrite is_left_oriented andbT /wccw -det_cyclique det_conv convrl sm. - rewrite -opprB mulrN subr_ge0. - have [/[dup]|able0] := ltP 0 (det a l`_i l`_i.+1mod - det b l`_i l`_i.+1mod). - rewrite {1}lt0r -invr_gt0=>/andP[ab0 _] abgt0. - rewrite -subr_ge0 -(pmulr_lge0 _ abgt0) mulrBl subr_ge0 -mulrA divff// mulr1. - rewrite -lee_fin tfin leIx; apply/orP; left. - rewrite ![det _ l`_i _]det_cyclique /t. - by move:abgt0; rewrite invr_gt0=>abgt; exact: Order.TMeetTheory.meets_inf. - rewrite {2}[det a _ _]det_cyclique (le_trans _ (la i))// mulr_ge0_le0 //. - by move:t01 => /andP[]. -move=> /existsP[i] iable0. -(* We want to show that b <| sup I |> a suits. - We show that it is between] a and b and between l`_i and l`_(i+1). - This gives a witness to contradict the hypo (lab i). *) -move: lab =>/(_ i)/negP; apply; apply intersect_complete. -exists (b <| sup I |> a); apply/andP; split; last first. - rewrite betweenC; apply between_conv; exists (sup I); apply/andP; split=>//. - apply/andP; split=>//. - by apply sup_upper_bound. -(* First, b <| sup I |> a, l`_i and l`_(i+1) are aligned. *) -have : det l`_i l`_i.+1mod (b <| sup I |> a) = 0. - by apply: le_anti; apply/andP; split => //; apply: lt. -move=>/det0_aligned[/lu|]. - rewrite 2!inE. - move=>/(_ (ltn_ord i) (ltn_ord i.+1mod)); rewrite Zp_succE. - move:(ltn_ord i); rewrite leq_eqVlt => /predU1P[il|isl]. - rewrite il modnn=>i0; move:il; rewrite i0=>s1; move:ls; rewrite s1=>/ltnW. - by rewrite ltnn. - by rewrite modn_small// => /n_Sn. -move=>[t] tie; apply between_conv; exists t; rewrite tie eqxx andbT. -(* b <| sup I |> a is l`_i <| t |> l`_(i+1) for some t. We show 0 <= t <= 1 - by contradiction by looking at the inequalities - 0 <= det l`_j l`_(j+1) (b <| sup I |> a) for j = i+1 and j = i-1. *) -apply/negPn/negP; rewrite negb_and -2!ltNge => /orP[t0|]. - move:lt=>/(_ (Zp_succ i)); rewrite -tie /wccw -det_cyclique det_conv det_alternate /conv scaler0 addr0 sm nmulr_rge0// =>ile. - move:ll; rewrite encompass_all_index l0/= =>/forallP/(_ i)/allP/(_ l`_(Zp_succ (Zp_succ i))). - have /[swap]/[apply] : l`_i.+1mod.+1mod \in l by apply mem_nth. - rewrite /encompass.is_left /ccw ltNge ile orbF => /orP[|] /eqP/lu; rewrite 2!inE=>/(_ (ltn_ord _) (ltn_ord _)); rewrite !Zp_succE=>/eqP; rewrite -2!addn1 modnDml -addnA addn1. - by rewrite -{2}(modn_small (ltn_ord i)) -{2}(addn0 i) eqn_modDl modn_small// mod0n=>/eqP. - rewrite eqn_modDl modn_small// modn_small; last by apply ltnW. - by move=>/eqP. -rewrite -subr_lt0 => t0. -have predi_ltl : ((i + (size l).-1) %% (size l) < size l)%N by apply/ltn_pmod/ltnW/ltnW. -have succ_predi : Zp_succ (Ordinal predi_ltl) = i. - apply val_inj; rewrite Zp_succE -addn1 modnDml -addnA addn1 prednK; last by do 2 apply ltnW. - by rewrite modnDr modn_small. -move:lt=>/(_ (Ordinal predi_ltl)); rewrite succ_predi -tie /wccw -det_cyclique det_conv -det_cyclique det_alternate /conv scaler0 add0r sm nmulr_rge0// =>ile. -move:ll; rewrite encompass_all_index l0/= =>/forallP/(_ (Ordinal predi_ltl))/allP/(_ l`_(Zp_succ i)). -have /[swap]/[apply] : l`_(Zp_succ i) \in l by apply mem_nth. -rewrite succ_predi /encompass.is_left /ccw ltNge -det_cyclique ile orbF => /orP[|] /eqP/lu; rewrite 2!inE=>/(_ (ltn_ord _) (ltn_ord _)); rewrite !Zp_succE=>/eqP. - rewrite -addn1 eqn_modDl modn_small//; last by apply ltnW. - rewrite modn_small; last by rewrite prednK=>//; do 2 apply ltnW. - rewrite -eqSS prednK; last by do 2 apply ltnW. - by move=>/eqP s2; move:ls; rewrite s2 ltnn. -by rewrite -{2}(modn_small (ltn_ord i)) -addn1 -{2}(addn0 i) eqn_modDl mod0n modn_small; last by apply ltnW. -Qed. - -End Plane. diff --git a/theories/isolate.v b/theories/isolate.v deleted file mode 100644 index 2270bb4..0000000 --- a/theories/isolate.v +++ /dev/null @@ -1,689 +0,0 @@ -From HB Require Import structures. -From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype order. -From mathcomp Require Import div finfun bigop prime binomial ssralg finset fingroup finalg archimedean. -From mathcomp Require Import mxalgebra perm zmodp matrix ssrint. -(*From mathcomp Require Import (*refinements NB(rei) funperm*).*) -From mathcomp Require Import seq rat. -Require Import (*seqpoly*) pol square_free casteljau desc. - -From mathcomp Require Import ssrnum ssrint realalg poly. -Require Import poly_normal. -Import Order.Theory GRing.Theory Num.Theory. - -(* Bernstein coefficients for half intervals can be computed using the - algorithm by de Casteljau. *) -Open Scope ring_scope. - -Fixpoint casteljau (l : seq rat) (n : nat) : nat -> rat := - match n with - O => fun j => nth 0 l j - | S p => fun j => ((casteljau l p j + casteljau l p j.+1)/(1+1))%R - end. - -(* This computes the Bernstein coefficients for the left hand side - half. *) -Definition dicho_l n l := - map (fun i => casteljau l i 0) (iota 0 (S n)). - -Definition dicho_r n l := - map (fun i => casteljau l (n - i) i) (iota 0 (S n)). - -(* -Fixpoint count_root n d (l : seq rat) : option nat := - match n with - 0 => None - | S p => - match qe_rcf_th.changes (seqn0 l) with - 0%N => Some 0%N - | 1%N => Some 1%N - |_ => let l2 := dicho_r d l in - match count_root p d l2, count_root p d (dicho_l d l) with - Some v1, Some v2 => - if head 0 l2 == 0 then Some (v1 + v2 + 1)%N else Some (v1 + v2)%N - | _, _ => None - end - end - end. -*) - -Section dicho_correct. -Variable R : numFieldType. - -Lemma casteljau_correct (l : seq rat) k n : - ratr (casteljau l k n) = - de_casteljau (R:=R) (1/(1+1)) (1/(1+1)) - (fun i => ratr (nth 0 l i)) k n. -Proof. -elim : k n => [ n | k Ik n]; first by []. -rewrite /= rmorphM rmorphD rmorphV; last by rewrite unitf_gt0 //. -by rewrite /= rmorphD !rmorph1 !Ik mulrDl !mul1r !(mulrC (_ ^-1)). -Qed. - -Lemma dicho_l_correct (n : nat) (l : seq rat) (k : nat) : - (size l <= n.+1)%nat -> (k <= n)%nat -> - ratr (nth 0 (dicho_l n l) k) = - dicho' (R := R) (1/(1+1)) (1/(1+1)) (fun i => ratr (nth 0 l i)) k. -Proof. -move => sl kn. -rewrite /dicho_l /dicho'. -have kn' : (k < size (iota 0 n.+1))%nat. - by rewrite size_iota. -rewrite (nth_map 0%nat 0 (fun v => casteljau l v 0)) //. -by rewrite nth_iota // add0n casteljau_correct. -Qed. - -Lemma dicho_r_correct (n : nat) (l : seq rat) (k : nat) : - (size l <= n.+1)%nat -> (k <= n)%nat -> - ratr (nth 0 (dicho_r n l) k) = - dicho (R := R) (1/(1+1)) (1/(1+1)) n (fun i => ratr (nth 0 l i)) k. -Proof. -move => sl kn. -rewrite /dicho_r /dicho. -have kn' : (k < size (iota 0 n.+1))%nat. - by rewrite size_iota. -rewrite (nth_map 0%nat 0 (fun v => casteljau l (n - v) v)) //. -by rewrite nth_iota // add0n casteljau_correct. -Qed. - -End dicho_correct. - -Inductive root_info A : Type := - | Exact (x : A) - | One_in (x y : A) - | Zero_in (x y : A) - | Unknown (x y : A). - -(* -Fixpoint isol_rec n d (a b : rat) (l : seq rat) acc : seq (root_info rat) := - match n with - O => Unknown _ a b::acc - | S p => - match qe_rcf_th.changes (seqn0 l) with - | 0%nat => Zero_in _ a b::acc - | 1%nat => One_in _ a b::acc - | _ => - let c := ((a + b)/(1+1)) in - let l2 := dicho_r d l in - isol_rec p d a c (dicho_l d l) - (if head 0 l2 == 0 then - Exact _ c::isol_rec p d c b l2 acc - else isol_rec p d c b l2 acc) - end - end. -*) - -Definition root_info_eq (R : eqType) - (x y : root_info R) : bool := - match x, y with - Exact a, Exact b => a == b :> R - | Zero_in a1 a2, Zero_in b1 b2 => (a1 == b1 :> R) && (a2 == b2 :> R) - | One_in a1 a2, One_in b1 b2 => (a1 == b1 :> R) && (a2 == b2 :> R) - | Unknown a1 a2, Unknown b1 b2 => (a1 == b1 :> R) && (a2 == b2 :> R) - | _, _ => false - end. - -Lemma root_info_eqP : forall (R : eqType), Equality.axiom (root_info_eq R). -Proof. -by move => R [x|x y|x y|x y] [z |z t|z t|z t]; - (apply: (iffP idP); - first (rewrite //=; try (case/andP=> /eqP -> /eqP -> //); - move=>/eqP ->)) => //; case=> -> //= -> /=; - apply/andP; split. -Qed. - -Section more_on_dicho. - -Lemma dicho_ext : - forall (R : comRingType) (a b : R) n f1 f2 p, (p <= n)%N -> - (forall i, (i <= n)%N -> f1 i = f2 i) -> - dicho a b n f1 p = dicho a b n f2 p. -Proof. -move=> R a b n f1 f2 p pn q; rewrite /dicho; apply: ext_dc => i ci1 ci2. -by apply/q/(leq_trans ci2); rewrite subnKC. -Qed. - -End more_on_dicho. - -Section count_root_correct. - -Variable R : archiFieldType. - -(*TODO(rei, gave up when moving to MathComp 2): Definition R' : archiFieldType := (R : rcfType).*) - -(* -Lemma count_root_correct0 n (l : seq rat) q d (a b: R') : - (0 < d)%N -> a < b -> q != 0 -> size l = d.+1 -> - q = \sum_(i < d.+1) (nth 0 (map ratr l) i) *: - bernp a b d i -> count_root n d l = Some 0%N -> - forall (x : R'), a < x < b -> q.[x]!=0. -Proof. -move=> dgt0; elim: n l a b => [ | n In l a b ab qn0 sl qq]; first by []. -rewrite /=. -have anb : a != b. - by apply/negP => aqb; move: ab; rewrite ltr_neqAle aqb. -have bman0 : b - a != 0 by rewrite subr_eq0 eq_sym. -have twogt0 : (0 < 1 + 1 :> R'). - by apply: addr_gt0; apply: ltr01. -have twon0 : (1 + 1 != 0 :> R'). - by apply/negP => two0; move: twogt0; rewrite ltr_neqAle eq_sym two0. -have twoV : forall a, a = a/(1 + 1) + a/(1+1) :> R'. - by move=> y; rewrite -mulrDl -(mulr1 y) -mulrDr mulrK // mulr1. -have altm : a < (a + b)/(1 + 1). - by rewrite {1}[a]twoV mulrDl ltr_add2l ltr_pM2r // invr_gt0. -have mltb : (a + b)/(1 + 1) < b. - by rewrite {2}[b]twoV mulrDl ltr_add2r ltr_pM2r // invr_gt0. -have mna : (a + b)/(1 + 1) != a. - by apply/negP => ma; move:altm; rewrite ltr_neqAle eq_sym ma. -have mnb : (a + b)/(1 + 1) != b. - by apply/negP => mb; move:mltb; rewrite ltr_neqAle mb. -case ch: (qe_rcf_th.changes (seqn0 l)) => [ | nch]. - move => _; apply: (ch0_correct (d := d) ab qn0 qq) => //. - (* The following proof exactly common with isol_rec_no_root, except for hypothesis - that are discarded at the time of tactic elim *) - elim: {qq sl} l ch => /= [| e l Il]; first by []. - case e0 : (e == 0). - by rewrite (eqP e0) rmorph0 eqxx. - case h : (_ == 0). - move/negbT : e0 => /negP; case. - by rewrite -(fmorph_eq0 (ratr_rmorphism (RealAlg.alg_of_rcfType R))) h. - rewrite /=. - move/eqP; rewrite addn_eq0 => /andP [pe /eqP pl]. - apply/eqP; rewrite addn_eq0; apply/andP; split; last first. - by apply/eqP; apply: Il. - set (u := ratr e). - have sr : (head 0 (seqn0 l) < 0) = - (head 0 (seqn0 [seq ratr i | i <- l]) < 0 :> RealAlg.alg_of_rcfType R). - elim : {Il pl pe} l => [ | e' l' Il']; first by rewrite /= ltrr. - rewrite /=; case he' : (e' == 0) => /=. - by rewrite (eqP he') rmorph0 eqxx /=. - by rewrite fmorph_eq0 he' /= ltrq0. - have sr' : (0 < head 0 (seqn0 l)) = - (0 < head 0 (seqn0 [seq ratr i | i <- l]) :> RealAlg.alg_of_rcfType R). - elim : {Il pl pe sr} l => [ | e' l' Il']; first by rewrite /= ltrr. - rewrite /=; case he' : (e' == 0) => /=. - by rewrite (eqP he') rmorph0 eqxx /=. - by rewrite fmorph_eq0 he' /= ltr0q. - case u0 : (u < 0). - rewrite nmulr_rlt0; last by []. - move: u0; rewrite ltrq0 => u0. - by rewrite -sr' -(nmulr_rlt0 _ u0). - move: u0; rewrite ltrNge ler_eqVlt eq_sym h /= => /negbFE => u0. - rewrite pmulr_rlt0; last by []. - by move: u0; rewrite ltr0q => u0; rewrite -sr -(pmulr_rlt0 _ u0). - (* end of common proof. *) -case: {ch} nch => [| _]; first by []. -case cr1 : (count_root n d (dicho_r d l)) => [ [ | v1] | //]; - case cr2 : (count_root n d (dicho_l d l)) => [ [ | v2] | //]; - case cc : ((casteljau l (d - 0) 0) == 0) => //. -move => _ x axb. -case xm : (x < (a + b) / (1 + 1)). - have axm : (a < x < (a + b)/(1 + 1)). - by case/andP: axb => [ax xb]; rewrite ax xm. - have sl' : size (dicho_l d l) = d.+1 by rewrite /dicho_l size_map size_iota. - have qq' : q = \sum_(i < d.+1) - [seq ratr i | i <- dicho_l d l]`_i *: - bernp (R:=R') a ((a + b) / (1 + 1)) d i. - have sll : (size l <= d.+1)%N by rewrite sl leqnn. - have dlc := fun k => dicho_l_correct (RealAlg.alg_of_rcfType R) d l k sll. - set f := fun i : 'I_d.+1 => - dicho' ((b - (a + b)/(1+1)) / (b - a)) (((a + b)/(1+1) - a) / (b - a)) - [eta nth 0 [seq ratr v | v <- l]] i *: bernp a ((a + b)/(1+1)) d i. - have bodyq : - forall i : 'I_d.+1, true -> - [seq ratr i | i <- dicho_l d l]`_i *: bernp a ((a + b)/(1+1)) d i = f i. - rewrite /f. - have -> : (b - (a + b)/(1 + 1))/(b - a) = 1/(1 + 1). - rewrite (addrC a) {1}[b]twoV !mulrDl opprD mulrBl addrA. - by rewrite mulNr addrK -!mulrBl mulrC mulrA mulVf. - have -> : ((a + b) / (1 + 1) - a) / (b - a) = 1/(1 + 1). - rewrite (addrC a) {2}[a]twoV (mulrDl b) opprD addrA addrK -mulrBl. - by rewrite mulrC mulrA mulVf. - move=> [i id] _; congr (_ *: _). - rewrite /nat_of_ord (nth_map 0 0) ?sl' // dlc /dicho'. - apply: ext_dc => j j0 ji. - by rewrite (nth_map 0 0) // (leq_ltn_trans ji) // sl. - by rewrite -ltnS. - rewrite (eq_bigr f bodyq) /f. - by apply:(dicho'_correct (c :=fun i => [seq ratr v | v <- l]`_i) anb mna qq). - by apply: (In _ _ _ altm qn0 sl' qq' cr2 _ axm). -set f := fun i : 'I_d.+1 => - dicho ((b - (a + b)/(1+1)) / (b - a)) (((a + b)/(1+1) - a) / (b - a)) - d [eta nth 0 [seq ratr v | v <- l]] i *: bernp ((a + b)/(1+1)) b d i. -have sll : (size l <= d.+1)%N by rewrite sl leqnn. -have drc := fun k => dicho_r_correct (RealAlg.alg_of_rcfType R) d l k sll. -have sl' : size (dicho_r d l) = d.+1 by rewrite /dicho_l size_map size_iota. -have bodyq : - forall i : 'I_d.+1, true -> - [seq ratr i | i <- dicho_r d l]`_i *: bernp ((a + b)/(1+1)) b d i = f i. - rewrite /f. - have -> : (b - (a + b)/(1 + 1))/(b - a) = 1/(1 + 1). - rewrite (addrC a) {1}[b]twoV !mulrDl opprD mulrBl addrA. - by rewrite mulNr addrK -!mulrBl mulrC mulrA mulVf. - have -> : ((a + b) / (1 + 1) - a) / (b - a) = 1/(1 + 1). - rewrite (addrC a) {2}[a]twoV (mulrDl b) opprD addrA addrK -mulrBl. - by rewrite mulrC mulrA mulVf. - move=> [i id] _; congr (_ *: _). - rewrite /nat_of_ord (nth_map 0 0) ?sl' // drc /dicho. - apply: ext_dc => j j0 ji. - by rewrite (nth_map 0 0) // sl (leq_ltn_trans ji) // subnKC. - by rewrite -ltnS. -have qq' : q = \sum_(i < d.+1) - [seq ratr i | i <- dicho_r d l]`_i *: - bernp (R:=R') ((a + b) / (1 + 1)) b d i. - rewrite (eq_bigr f bodyq) /f. - apply:(dicho_correct (c :=fun i => [seq ratr v | v <- l]`_i) anb mnb qq). -move/negP/negP: xm ; rewrite -lerNgt ler_eqVlt => /orP [/eqP xm | xm]; last first. - have mxb : ((a + b)/(1 + 1) < x < b). - by case/andP: axb => [ax xb]; rewrite xb xm. - by apply: (In _ _ _ mltb qn0 sl' qq' cr1 _ mxb). -rewrite qq' (big_morph (fun p => horner p x) (fun p q => hornerD p q x) - (horner0 x)). -have b0m := fun i (id : (i <= d)%N) => bern0_a mnb dgt0 id. -have all0 : forall (i : 'I_d), true -> - ([seq ratr i | i <- dicho_r d l]`_(lift ord0 i) *: - bernp (R:=R') x b d (lift ord0 i)).[x] = 0. - move => i _. - have id: (lift ord0 i <= d)%N by case: i => [i id]. - have : (lift ord0 i != 0) by case: {id} i => [i id']. - rewrite -(b0m _ id) xm /R' hornerZ => /eqP ->. - by rewrite mulr0. -rewrite big_ord_recl big1; last by rewrite xm. -rewrite addr0 hornerZ mulf_neq0 //. - by rewrite /= fmorph_eq0 cc. -by rewrite -xm (b0m _ (leq0n d)). -Qed. -*) - -End count_root_correct. - -Section isol_rec_correct. - -Variable R : archiFieldType. - -(*NB(rei): couldn't type Unknown rat a b a few lines below -Lemma isol_rec_acc : forall n d a b l acc, exists l'', - @isol_rec R n d a b l acc = l''++acc. -Proof. -elim => [| n In] d a b l acc. - by rewrite /=; exists [:: Unknown rat a b]. -rewrite /=; case: (qe_rcf_th.changes (seqn0 l)) => [ | n0]; - first by exists [:: Zero_in _ a b]. -case: n0 => [ | n1]; first by exists [:: One_in rat a b]. -case: (In d ((a + b) / (1+1)) b (dicho_r d l) acc) => [l1 l1q]. -case: (casteljau l (d - 0) 0 == 0). - case: (In d a ((a + b) / (1+1)) (dicho_l d l) - (Exact _ ((a + b) / (1+1))::l1++acc)) => [l2 l2q]. - exists (l2++Exact _ ((a + b) / (1+1))::l1). - by rewrite -(cat1s _ l1) l1q l2q -!catA. -case: (In d a ((a + b) / (1+1)) (dicho_l d l) (l1++acc)) => [l2 l2q]. -by exists (l2++l1); rewrite l1q l2q -!catA. -Qed.*) - -HB.instance Definition _ := hasDecEq.Build _ (root_info_eqP R). - -(*Canonical root_info_eqType (R : eqType) := - Eval hnf in EqType (root_info R) (root_info_eqMixin R). - -Arguments root_info_eqP {R x y}. -Prenex Implicits root_info_eqP.*) - - -(* NB(rei): typing issue with {realclosure _} -Lemma isol_rec_no_root n (l : seq rat) q d (a b:rat) a' b' acc : - a < b -> q != 0 -> size l = d.+1 -> - ~~ (Zero_in rat a' b' \in acc) -> - Zero_in rat a' b' \in isol_rec n d a b l acc -> - q = \sum_(i < d.+1) (nth 0 (map ratr l) i) *: - bernp (ratr a) (ratr b) d i -> - forall (x : {realclosure R}), ratr a' < x < ratr b' -> q.[x]!=0. -Proof. -set two := (1 + 1: RealAlg.alg_of_rcfType R); have twon0 : two != 0. - have twogt0' : 0 < two by apply: addr_gt0; apply:ltr01. - by move: twogt0'; rewrite ltr_neqAle eq_sym=>/andP []. -elim: n l q d a b a' b' acc => [ | n In] l q d a b a' b' acc ab qn0 sl nin /=. - by rewrite in_cons =>/orP [ // | ] => in_indeed; move:nin; rewrite in_indeed. -have rcfab : (ratr a < ratr b :> RealAlg.alg_of_rcfType R). - (* could not use directly apply: ltr_rat; obviously I did not understand - that morphism properties are rewriting properties *) - by rewrite ltr_rat. -have rabd : ratr a != ratr b :> RealAlg.alg_of_rcfType R. - apply/negP; move/eqP => rab. - have aqb: a == b by apply/eqP/(fmorph_inj (ratr_rmorphism _) rab). - by move: ab; rewrite ltr_neqAle aqb. -have rbman0 : ratr b - ratr a != 0 :> RealAlg.alg_of_rcfType R. - by rewrite subr_eq0 eq_sym. -have twogt0 : 0 < 1 + 1 :> rat by apply: addr_gt0; rewrite ltr01 . -have a1b1 : (a + b)/(1+1) < b :> rat. - rewrite -(ltr_pM2r twogt0) mulfVK. - by rewrite mulrDr mulr1 ltr_add2r. - by move: twogt0; rewrite ltr_neqAle eq_sym=>/andP; case. -have a2b2 : a < (a + b)/(1+1) :> rat. - rewrite -(ltr_pM2r twogt0) mulfVK. - by rewrite mulrDr mulr1 ltr_add2l. - by move: twogt0; rewrite ltr_neqAle eq_sym=>/andP; case. -have rmbd: (ratr a + ratr b)/(1+1) != ratr b :> RealAlg.alg_of_rcfType R. - apply/negP;move=> /eqP. - rewrite -(rmorph1 ((ratr_rmorphism _))) -!rmorphD -fmorphV -rmorphM => rmb. - have mqb: (a + b)/(1 + 1) == b. - by apply/eqP/(fmorph_inj (ratr_rmorphism _) rmb). - by move: a1b1; rewrite ltr_neqAle mqb. -have ramd: ratr a != (ratr a + ratr b)/(1+1) :> RealAlg.alg_of_rcfType R. - apply/negP;move=> /eqP. - rewrite -(rmorph1 ((ratr_rmorphism _))) -!rmorphD -fmorphV -rmorphM => ram. - have aqm: a == (a + b)/(1 + 1). - by apply/eqP/(fmorph_inj (ratr_rmorphism _) ram). - by move: a2b2; rewrite ltr_neqAle aqm. -have sd : size (dicho_r d l) = d.+1 by rewrite /dicho_r size_map size_iota. - have sl' : (size l <= d.+1)%N by rewrite leq_eqVlt sl eqxx. -have sd' : size (dicho_l d l) = d.+1 by rewrite /dicho_l size_map size_iota. -case ch: (qe_rcf_th.changes (seqn0 l)) => [ | nch]. - rewrite in_cons=> /orP [ /eqP[-> ->] | abs] qq x intx. - apply: (ch0_correct (d := d) rcfab qn0 qq) => //. - elim: {qq sl sd sd' sl'} l ch => /= [| e l Il]; first by []. - case e0 : (e == 0). - by rewrite (eqP e0) rmorph0 eqxx. - case h : (_ == 0). - move/negbT : e0 => /negP; case. - by rewrite -(fmorph_eq0 (ratr_rmorphism (RealAlg.alg_of_rcfType R))) h. - rewrite /=. - move/eqP; rewrite addn_eq0 => /andP [pe /eqP pl]. - apply/eqP; rewrite addn_eq0; apply/andP; split; last first. - by apply/eqP; apply: Il. - set (u := ratr e). - have sr : (head 0 (seqn0 l) < 0) = - (head 0 (seqn0 [seq ratr i | i <- l]) < 0 :> RealAlg.alg_of_rcfType R). - elim : {Il pl pe} l => [ | e' l' Il']; first by rewrite /= ltrr. - rewrite /=; case he' : (e' == 0) => /=. - by rewrite (eqP he') rmorph0 eqxx /=. - by rewrite fmorph_eq0 he' /= ltrq0. - have sr' : (0 < head 0 (seqn0 l)) = - (0 < head 0 (seqn0 [seq ratr i | i <- l]) :> RealAlg.alg_of_rcfType R). - elim : {Il pl pe sr} l => [ | e' l' Il']; first by rewrite /= ltrr. - rewrite /=; case he' : (e' == 0) => /=. - by rewrite (eqP he') rmorph0 eqxx /=. - by rewrite fmorph_eq0 he' /= ltr0q. - case u0 : (u < 0). - rewrite nmulr_rlt0; last by []. - move: u0; rewrite ltrq0 => u0. - by rewrite -sr' -(nmulr_rlt0 _ u0). - move: u0; rewrite ltrNge ler_eqVlt eq_sym h /= => /negbFE => u0. - rewrite pmulr_rlt0; last by []. - by move: u0; rewrite ltr0q => u0; rewrite -sr -(pmulr_rlt0 _ u0). - by case/negP: nin. -case: {ch} nch. - rewrite in_cons; case/orP; last by move=>abs; move:nin; rewrite abs. - by move/eqP. -case zac1: (Zero_in rat a' b' \in - (if casteljau l (d - 0) 0 == 0 - then - Exact rat ((a + b) / (1 + 1)) - :: isol_rec n d ((a + b) / (1 + 1)) b (dicho_r d l) acc - else isol_rec n d ((a + b) / (1 + 1)) b (dicho_r d l) acc)). - move => _ _ qq. - have zac2 : Zero_in rat a' b' \in - isol_rec n d ((a + b) / (1 + 1)) b (dicho_r d l) acc. - move: zac1; case: (casteljau l (d - 0) 0 == 0); last by []. - by rewrite in_cons; case/orP => [/eqP | ]. - apply: (In _ q d _ _ a' b' acc a1b1 qn0 sd nin zac2). - move=> {zac1 In zac2}. - have drc := fun k => dicho_r_correct (RealAlg.alg_of_rcfType R) d l k sl'. - have bodyq : - forall i : 'I_d.+1, - [seq ratr i | i <- dicho_r d l]`_i *: - bernp (ratr ((a + b)/(1+1))) (ratr b) d i = - dicho ((ratr b - (ratr a + ratr b)/(1+1)) / (ratr b - ratr a)) - (((ratr a + ratr b)/(1+1) - ratr a) / (ratr b - ratr a)) d - [eta nth 0 [seq ratr v | v <- l]] i *: - bernp (R:=RealAlg.alg_of_rcfType R) ((ratr a + ratr b)/(1+1)) (ratr b) d i. - (* TODO : find the politically correct way to do "simpl nat_of_ord" without simplifying everywhere *) - move=> [i id]; simpl nat_of_ord. - move: (id); rewrite ltnS => id'. - rewrite -[X in X - _/_](mulfVK twon0) mulrDr mulr1 -mulrDl -mulrBl opprD. - rewrite addrA (addrC _ (- ratr b)) !addrA addNr add0r (mulrC ((_ - _) / _)). - rewrite mulrA mulVr //. - rewrite -[X in _/_ - X](mulfVK twon0) mulrDr mulr1 -mulrDl -mulrBl opprD. - rewrite !addrA (addrC (_ + _) (- ratr a)) !addrA addNr add0r. - rewrite -mulrA (mulrC (_^-1)) mulrA mulrV //. - rewrite rmorphM rmorphD rmorphV // rmorphD rmorph1. - congr (_ *: _); rewrite (nth_map 0 0); last by rewrite sd. - rewrite drc //; apply: (dicho_ext _ (1/two)) => //. - by move => j jc; rewrite (nth_map 0 0) // sl ltnS. - rewrite (eq_bigr (fun i : 'I_d.+1 => - dicho (R:=RealAlg.alg_of_rcfType R) - ((ratr b - (ratr a + ratr b) / (1 + 1)) / (ratr b - ratr a)) - (((ratr a + ratr b) / (1 + 1) - ratr a) / (ratr b - ratr a)) d - [eta nth 0 [seq ratr v | v <- l]] i *: - bernp (R:=RealAlg.alg_of_rcfType R) ((ratr a + ratr b) / (1 + 1)) - (ratr b) d i)); last by move => i _; apply bodyq. - by apply: (dicho_correct (c := fun i => [seq ratr v | v <- l]`_i) rabd rmbd qq). -move: zac1; set acc' := (if casteljau _ _ _ == 0 then _ else _). -move/negP/negP=> zac1 _ zac2 qq. - apply: (In _ q d _ _ a' b' acc' a2b2 qn0 sd' zac1 zac2). - have dlc := fun k => dicho_l_correct (RealAlg.alg_of_rcfType R) d l k sl'. - have bodyq : - forall i : 'I_d.+1, - [seq ratr i | i <- dicho_l d l]`_i *: - bernp (ratr a) (ratr ((a + b)/(1+1))) d i = - dicho' ((ratr b - (ratr a + ratr b)/(1+1)) / (ratr b - ratr a)) - (((ratr a + ratr b)/(1+1) - ratr a) / (ratr b - ratr a)) - [eta nth 0 [seq ratr v | v <- l]] i *: - bernp (R:=RealAlg.alg_of_rcfType R) (ratr a) ((ratr a + ratr b)/(1+1)) d i. - move=> [i id]; simpl nat_of_ord. (* TODO : same as above *) - move: (id); rewrite ltnS => id'. - rewrite -[X in X - _/_](mulfVK twon0) mulrDr mulr1 -mulrDl -mulrBl opprD. - rewrite (addrC (-ratr a)) addrA addrK (mulrC ((_ - _) / _)) mulrA mulVr //. - rewrite -[X in _/_ - X](mulfVK twon0) mulrDr mulr1 -mulrDl -mulrBl opprD. - rewrite !addrA (addrC (_ + _) (- ratr a)) !addrA addNr add0r. - rewrite -mulrA (mulrC (_^-1)) mulrA mulrV //. - rewrite rmorphM rmorphD rmorphV // rmorphD rmorph1. - congr (_ *: _); rewrite (nth_map 0 0); last by rewrite sd'. - rewrite dlc //; rewrite /dicho'; apply ext_dc. - by move => j j0 ji; rewrite (nth_map 0 0) // sl (leq_ltn_trans ji) //. -move: ramd; rewrite eq_sym => ramd. -rewrite (eq_bigr (fun i : 'I_d.+1 => - dicho' (R:=RealAlg.alg_of_rcfType R) - ((ratr b - (ratr a + ratr b) / (1 + 1)) / (ratr b - ratr a)) - (((ratr a + ratr b) / (1 + 1) - ratr a) / (ratr b - ratr a)) - [eta nth 0 [seq ratr v | v <- l]] i *: - bernp (R:=RealAlg.alg_of_rcfType R) (ratr a) ((ratr a + ratr b) / (1 + 1)) - d i)); last by move => i _ ; apply bodyq. -by apply: (dicho'_correct (c := fun i => [seq ratr v | v <- l]`_i) rabd ramd). -Qed. -*) - -End isol_rec_correct. - -Definition big_num := 500%nat. - -(* Returns the last element of the sequence of coefficients, i.e. - the lead coefficient if the sequence is normal. *) -(*NB(rei): it looks like this has to do with evaluation, rm? -Definition lead_coef p := last 0%bigQ p. -*) - -(* To be used with a monic divisor d, of degree dd *) - -(* -Fixpoint divp_r (p d : seq bigQ) (dd : nat) : seq bigQ * seq bigQ := - if NPeano.Nat.leb (size p) dd - then ([::], p) - else - match p with - [::] => ([::], p) - | a::p' => let (q, r) := divp_r p' d dd in - let y := nth a (a::r) dd in - (y::q, addp (a::r) (scal ((-1) * y) d)) - end. - -Definition divp p d := - let d' := normalize d in - let dd := (size d').-1 in - let lc := lead_coef d' in - match d' with - [::] => ([::], p) - | _::_ => let (q, r) := divp_r p (map (fun x => x/lc)%bigQ d') dd in - (map (fun x => x/lc)%bigQ q, normalize r) - end. -*) - -(* Correctness proof. *) - -(* Definition repr (l : list bigQ) : poly rat := *) - -(* - -Definition clean_divp p d := - let (a, b) := divp p d in (map red (normalize a), map red (normalize b)). - -Fixpoint gcd_r n (p q : seq bigQ) : seq bigQ := - match n with - O => p - | S n' => - let (_, r) := clean_divp p q in - match r with nil => q | _ => gcd_r n' q r end - end. - -Definition gcd (p q : seq bigQ) := - let r := gcd_r (maxn (size p) (size q)).+1 p q in - let lc := lead_coef r in - map (fun x => red (x/lc)) r. - -Compute (clean_divp [::3;1] [::4;1])%bigQ. -Compute (clean_divp [::3;2;1] [::1])%bigQ. -Compute (gcd_r 4 [::3;1] [::4;1])%bigQ. - -Fixpoint bigQ_of_nat (n : nat) := - match n with 0%nat => 0%bigQ | S p => (1 + bigQ_of_nat p)%bigQ end. - -Definition derive p := - match product (map bigQ_of_nat (iota 0 (size p))) p with - _::p' => p' | _ => nil - end. - -Definition no_square p := - fst (clean_divp p (gcd p (derive p))). - -Definition isolate a b p : seq (root_info bigQ) := - let l := no_square p in - let deg := (size l).-1 in - let coefs := b_coefs deg a b l in - let b_is_root := - if eq_bool (last 0%bigQ coefs) 0 then [:: Exact _ b] else [::] in - let result := isol_rec big_num deg a b coefs b_is_root in - if eq_bool (head 0%bigQ l) 0 then Exact _ a::result else result. - -Fixpoint horner x p := - match p with - nil => 0%bigQ - | a::p' => (a + x * horner x p')%bigQ - end. - -Fixpoint ref_rec n a b pol := - match n with - O => One_in _ (red a) (red b) - | S p => - let c := ((a + b)/2)%bigQ in - let v := horner c pol in - match (v ?= 0)%bigQ with - Lt => ref_rec p c b pol - | Gt => ref_rec p a c pol - | Eq => Exact _ (red c) - end - end. - -Fixpoint first_sign l := - match l with - nil => 1%bigQ - | a::tl => - match (a ?= 0) with Eq => first_sign tl | Lt => -1 | Gt => 1 end%bigQ - end. - -Definition refine n a b p := - let deg := (List.length p).-1 in - let coefs := b_coefs deg a b p in - ref_rec n a b (scal (-1 * first_sign coefs) p). - -(* This polynomial has 1,2, and 3 as roots. *) -Definition pol2 : list bigQ := ((-6)::11::(-6)::1::nil)%bigQ. - -(* This polynomial as 1 and 2 as roots, with respective multiplicities - 1 and 2. *) - -Definition pol3 : list bigQ := ((-4)::8::(-5)::1::nil)%bigQ. - -Fixpoint no_root (l : list (root_info bigQ)) : bool := - match l with - nil => true - | Zero_in a b::l' => no_root l' - | _ => false - end. - -(* this polynomial has only one root, but the curve comes close to - the x axis around 2.5: this forces the dichotomy process a few times. *) -Definition mypol : list bigQ := ((-28/5)::11::(-6)::1::nil)%bigQ. - -Compute mypol. -Compute clean_divp mypol [::1]%bigQ. -Compute no_square mypol. -Compute b_coefs 3 0 4 (no_square mypol). - -(* The following isolates the single root of mypol in (0,4) *) -Compute isolate 0 4 mypol. - -(* The following computation proves that mypol has no roots in (2,4) *) -Compute no_root (isolate 2 4 mypol). - -Compute b_coefs 3 2 4 mypol. -Compute map (fun p => p.1 ?= p.2)%bigQ - (zip (dicho_r 3 (b_coefs 3 2 4 mypol)) (b_coefs 3 3 4 mypol)). -Compute let l := b_coefs 3 3 4 mypol in (changes l, l). -Compute isol_rec big_num 3 2 3 (b_coefs 3 2 3 mypol) [::]. -Compute isol_rec big_num 3 0 4 (b_coefs 3 0 4 mypol) [::]. - -Compute isolate 2 4 mypol. - -Time Compute refine 20 0 2 mypol. - -Compute (horner (110139 # 131072) mypol). -Compute (horner (440557 # 524288) mypol). - -(* Polynomial pol2 actually has roots in 1, 2, and 3 *) -Compute isolate 0 4 pol2. - -Compute isolate 0 4 pol3. - -(* When the path of computation touches the roots, they are recognized - as such. *) -Compute isolate 1 3 pol2. - -Compute refine 10 (11#10) 3 pol2. - -Compute ((10000 * 20479 / 10240)%bigZ, (10000 * 10249 / 5120)%bigZ). - -(* Without type information, this gives an error message that looks like a - bug. *) - -Compute clean_divp ((-2)::1::1::nil)%bigQ (4::2::nil)%bigQ. - -Compute let p := ((-2)::1::1::nil)%bigQ in - let d := (2::1::nil)%bigQ in - let (q, r) := divp p d in - (q, r, normalize (addp p (scal (-1) (addp (mulp q d) r)))). - -Compute let p := ((-2)::1::1::nil)%bigQ in - let q := ((-1)::3::(-3)::1::nil)%bigQ in - gcd p q. - -Compute derive ((-1)::3::(-3)::1::nil)%bigQ. - -Compute gcd ((-1)::3::(-3)::1::nil)%bigQ (derive ((-1)::3::(-3)::1::nil)%bigQ). - -Compute clean_divp ((-1)::3::(-3)::1::nil)%bigQ - (1::(-2)::1::nil)%bigQ. - -Time Compute no_square ((-1)::3::(-3)::1::nil)%bigQ. - -(* This is a poor man's correctness proof for the decision procedure, - but it should actually be extended to be used in any real-closed field. *) - -*) diff --git a/theories/math_comp_complements.v b/theories/math_comp_complements.v deleted file mode 100644 index 0e11e80..0000000 --- a/theories/math_comp_complements.v +++ /dev/null @@ -1,346 +0,0 @@ -From mathcomp Require Import all_ssreflect all_algebra. -Require Export Field. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Require Import NArithRing. -Import Order.TTheory GRing.Theory Num.Theory Num.ExtraDef Num. - -Open Scope ring_scope. - -Definition seq_subst {A : eqType} (l : seq A) (b c : A) : seq A := - map [eta id with b |-> c] l. - -Lemma mem_seq_subst {A : eqType} (l : seq A) b c x : - x \in (seq_subst l b c) -> (x \in l) || (x == c). -Proof. -elim: l => [// | a l Ih]. -rewrite /=. -by case: ifP => [] ?; rewrite !inE=> /orP[ | /Ih /orP[] ] ->; rewrite ?orbT. -Qed. - -(* Using == [::] to express emptyness of a list is only for eqTypes *) -Lemma map_nilp {A B : Type} (f : A -> B) (l : seq A) : - nilp [seq f x | x <- l] = nilp l. -Proof. by case: l. Qed. - -Lemma map_eq0 {A B : eqType} (f : A -> B) (l : seq A) : - ([seq f x | x <- l] == [::]) = (l == [::]). -Proof. by case: l. Qed. - -Lemma seq_subst_eq0 {A : eqType} (l : seq A) b c : - (seq_subst l b c == [::]) = (l == [::]). -Proof. exact: map_eq0. Qed. - -Lemma seq_subst_cat {A : eqType} (l1 l2 : seq A) b c : - seq_subst (l1 ++ l2) b c = seq_subst l1 b c ++ seq_subst l2 b c. -Proof. exact: map_cat. Qed. - -Lemma last_in_not_nil (A : eqType) (e : A) (s : seq A) : -s != [::] -> last e s \in s. -Proof. -case : s => [//= | c q ] /= _. -by rewrite mem_last. -Qed. - -Lemma head_in_not_nil (A : eqType) (e : A) (s : seq A) : -s != [::] -> head e s \in s. -Proof. -case : s => [//= | c q ] /= _. -by rewrite inE eqxx. -Qed. - -Lemma middle_seq_not_nil (A : eqType) (a b c : seq A) : -b != [::] -> -a ++ b ++ c != [::]. -Proof. by rewrite -!nilpE !cat_nilp=> /negbTE ->; rewrite andbF. Qed. - -Lemma rcons_neq0 (A : Type) (z : A) (s : seq A) : (rcons s z) <> nil. -Proof. -by case : s. -Qed. - -Lemma head_rcons (A : Type) (d l : A) (s : seq A) : - head d (rcons s l) = head l s. -Proof. by case: s. Qed. - -Lemma allcons [T : predArgType] - (f : T -> bool) a q' : all f (a :: q') = f a && all f q'. -Proof. by []. Qed. - -Definition cutlast (T : Type) (s : seq T) := -match s with | a :: s => belast a s | [::] => [::] end. - -Lemma last_seq2 (T : Type) (def a : T) (s : seq T) : - s <> nil -> last def (a :: s) = last def s. -Proof. -by case: s => [// | b s] _ /=. -Qed. - -Lemma behead_cutlasteq (T : Type) a (s : seq T) : - (1 < size s)%N -> s = head a s :: rcons (cutlast (behead s)) (last a s). -Proof. -by case: s => [ | b [ | c s]] //= _; congr (_ :: _); rewrite -lastI. -Qed. - -Lemma cutlast_subset (T : eqType) (s : seq T) : {subset cutlast s <= s}. -Proof. -rewrite /cutlast; case: s => [// | a s]. -elim: s a => [ // | b s Ih /=] a e; rewrite inE=> /orP[/eqP -> | ein]. - by rewrite inE eqxx. -by rewrite inE Ih ?orbT. -Qed. - -Lemma behead_subset (T : eqType) (s : seq T) : {subset behead s <= s}. -Proof. by case: s => [ | a s] // e /=; rewrite inE orbC => ->. Qed. - -Lemma sorted_catW (T : Type) (r : rel T) s s' : - (sorted r (s ++ s')) -> sorted r s && sorted r s'. -Proof. -case: s => [// | a s] /=. -by rewrite cat_path => /andP[] ->; apply: path_sorted. -Qed. - -Lemma sorted_rconsE (T : Type) (leT : rel T) s y: - transitive leT -> sorted leT (rcons s y) -> all (leT^~ y) s. -Proof. -move=> tr; elim: s=> [ | init s Ih] //=. -by rewrite (path_sortedE tr) all_rcons => /andP[] /andP[] -> _. -Qed. - -Lemma sorted_last {T : eqType} (r : rel T) (x0 x : T) (s : seq T): - transitive r -> sorted r s -> - x \in s -> (x == last x0 s) || r x (last x0 s). -Proof. -move=> rtr. -case s => [ | a tl] //=. -elim: tl a x => [ | b tl Ih] a x; first by rewrite /= inE => _ ->. -rewrite /= => /andP [rab stl]. -rewrite inE => /orP[/eqP xa | xin]; last by apply: Ih. -apply/orP; right. -move: (Ih b b stl); rewrite inE eqxx => /(_ isT). -move=> /orP[/eqP <- | ]. - by rewrite xa. -apply: rtr; by rewrite xa. -Qed. - -Lemma uniq_map_injective (T T' : eqType) (f : T -> T') (s : seq T) : - uniq [seq f x | x <- s] -> {in s &, injective f}. -Proof. -elim: s => [ // | a s Ih] /= /andP[fan uns]. -move=> e1 e2; rewrite !inE => /orP[/eqP -> | e1s ] /orP[/eqP -> | e2s] feq //. - by move: fan; rewrite feq; case/negP; apply/mapP; exists e2. - by move: fan; rewrite -feq; case/negP; apply/mapP; exists e1. -by apply: Ih. -Qed. - -Lemma mem_seq_split (T : eqType) (x : T) (s : seq T) : - x \in s -> exists s1 s2, s = s1 ++ x :: s2. -Proof. -by move=> /splitPr [s1 s2]; exists s1, s2. -Qed. - -(* TODO : propose for inclusion in math-comp *) -Lemma uniq_index (T : eqType) (x : T) l1 l2 : - uniq (l1 ++ x :: l2) -> index x (l1 ++ x :: l2) = size l1. -Proof. -elim: l1 => [/= | a l1 Ih]; first by rewrite eqxx. -rewrite /= => /andP[]. -case: ifP => [/eqP -> | _ _ /Ih -> //]. -by rewrite mem_cat inE eqxx orbT. -Qed. - -Lemma index_map_in (T1 T2 : eqType) (f : T1 -> T2) (s : seq T1) : - {in s &, injective f} -> - {in s, forall x, index (f x) [seq f i | i <- s] = index x s}. -Proof. -elim: s => [ // | a s Ih] inj x xin /=. -case: ifP => [/eqP/inj| fanfx]. - rewrite inE eqxx; move=> /(_ isT xin) => ->. - by rewrite eqxx. -case: ifP=> [/eqP ax | xna ]; first by rewrite ax eqxx in fanfx. -congr (_.+1). -apply: Ih=> //. - by move=> x1 x2 x1in x2in; apply: inj; rewrite !inE ?x1in ?x2in ?orbT. -by move: xin; rewrite inE eq_sym xna. -Qed. - -Lemma pairwise_subst {T : Type} [leT : rel T] (os ns s1 s2 : seq T) : - pairwise leT (s1 ++ os ++ s2) -> - pairwise leT ns -> - allrel leT s1 ns -> - allrel leT ns s2 -> - pairwise leT (s1 ++ ns ++ s2). -Proof. -rewrite !pairwise_cat !allrel_catr => /andP[] /andP[] _ -> /andP[] ->. -by move=>/andP[] _ /andP[] _ -> -> -> ->. -Qed. - -Lemma pairwise_subst1 {T : eqType} [leT : rel T] (oc nc : T)(s1 s2 : seq T) : - leT nc =1 leT oc -> leT^~ nc =1 leT^~ oc -> - pairwise leT (s1 ++ oc :: s2) = pairwise leT (s1 ++ nc :: s2). -Proof. -move=> l r. -by rewrite !(pairwise_cat, pairwise_cons, allrel_consr) (eq_all l) (eq_all r). -Qed. - -Section transitivity_proof. - -Variables (T : eqType) (r : rel T) (s1 s2 : mem_pred T). - -Hypothesis s1tr : {in s1 & &, transitive r}. -Hypothesis s2tr : {in s2 & &, transitive r}. -Hypothesis s1s2 : {in s1 & s2, forall x y, r x y && ~~ r y x}. - -Lemma two_part_trans : {in predU s1 s2 & &, transitive r}. -Proof. -move=> x2 x1 x3 /orP[x2ins1 | x2ins2] /orP[x1ins1 | x1ins2] - /orP[x3ins1 | x3ins2]; - try solve[move=> ?; apply:s1tr=> // | - move=> ?; apply: s2tr => // | - move=> ? ?; apply: (proj1 (andP (s1s2 _ _))) => //]. -- by move=> r12 r23; move: (s1s2 x2ins1 x1ins2); rewrite r12 andbF. -- by move=> r12 r23; move: (s1s2 x2ins1 x1ins2); rewrite r12 andbF. -- by move=> r12 r23; move: (s1s2 x3ins1 x2ins2); rewrite r23 andbF. -- by move=> r12 r23; move: (s1s2 x3ins1 x2ins2); rewrite r23 andbF. -Qed. - -End transitivity_proof. - -Section abstract_subsets_and_partition. - -Variable cell : eqType. -Variable sub : cell -> cell -> Prop. -Variable exclude : cell -> cell -> Prop. - -Variable close : cell -> cell. - -Hypothesis excludeC : forall c1 c2, exclude c1 c2 -> exclude c2 c1. -Hypothesis exclude_sub : - forall c1 c2 c3, exclude c1 c2 -> sub c3 c1 -> exclude c3 c2. - -Lemma add_map (s1 : pred cell) (s2 : seq cell) : - all (predC s1) s2 -> - {in s2, forall c, sub (close c) c} -> - {in predU s1 (mem s2) &, forall c1 c2, c1 = c2 \/ exclude c1 c2} -> - {in predU s1 (mem [seq close c | c <- s2]) &, - forall c1 c2, c1 = c2 \/ exclude c1 c2}. -Proof. -have symcase : forall (s : pred cell) (s' : seq cell), - all (predC s) s' -> - {in s', forall c, sub (close c) c} -> - {in predU s (mem s') &, forall c1 c2, c1 = c2 \/ exclude c1 c2} -> - forall c1 c2, s c1 -> c2 \in s' -> exclude c1 (close c2). - move=> s s' dif clsub exc c1 c2 sc1 c2s'. - apply/excludeC/(exclude_sub _ (clsub _ _)); last by []. - have := exc c2 c1; rewrite 2!inE c2s' orbT inE sc1 => /(_ isT isT). - by move=> -[abs | //]; have := allP dif _ c2s'; rewrite inE abs sc1. -move=> s1nots2 clsub oldx g1 g2. -rewrite inE => /orP[g1old | /mapP[co1 co1in g1c]]; - rewrite inE => /orP[g2old |/mapP[co2 co2in g2c ]]. -- by apply: oldx; rewrite inE ?g1old ?g2old. -- by right; rewrite g2c; apply: (symcase _ _ s1nots2 clsub oldx). -- by right; rewrite g1c; apply excludeC; apply: (symcase _ _ s1nots2 clsub oldx). -have [/eqP co1co2 | co1nco2] := boolP(co1 == co2). - by left; rewrite g1c g2c co1co2. -right; rewrite g1c; apply/(exclude_sub _ (clsub _ _)); last by []. -rewrite g2c; apply/excludeC/(exclude_sub _ (clsub _ _)); last by []. -have := oldx co2 co1; rewrite !inE co2in co1in !orbT=> /(_ isT isT). -by case=> [abs | //]; case/negP: co1nco2; rewrite abs eqxx. -Qed. - -Lemma add_new (s s2 : pred cell) : - {in s &, forall c1 c2, c1 = c2 \/ exclude c1 c2} -> - {in s & s2, forall c1 c2, exclude c1 c2} -> - {in s2 &, forall c1 c2, c1 = c2 \/ exclude c1 c2} -> - {in predU s s2 &, forall c1 c2, c1 = c2 \/ exclude c1 c2}. -Proof. -move=> oldx bipart newx c1 c2. -rewrite inE=> /orP[c1old | c1new] /orP[c2old | c2new]. -- by apply: oldx. -- by right; apply: bipart. -- by right; apply/excludeC/bipart. -by apply: newx. -Qed. - -End abstract_subsets_and_partition. - -Section subset_tactic. - -Lemma all_sub [T : eqType] [p : pred T] [s1 s2 : seq T] : - {subset s1 <= s2} -> all p s2 -> all p s1. -Proof. by move=> subs as2; apply/allP=> x xin; apply/(allP as2)/subs. Qed. - -Lemma subset_consl [T : eqType] (x : T) (s s': seq T) : - x \in s' -> {subset s <= s'} -> {subset (x :: s) <= s'}. -Proof. -by move=> xin ssub g; rewrite inE=> /orP[/eqP -> // | ]; apply: ssub. -Qed. - -Lemma subset_catl [T : eqType] (s1 s2 s' : seq T) : - {subset s1 <= s'} -> {subset s2 <= s'} -> {subset s1 ++ s2 <= s'}. -Proof. -move=> s1sub s2sub g; rewrite mem_cat=>/orP[];[apply: s1sub | apply s2sub]. -Qed. - -Lemma subset_catrl [T : eqType] [s s1 s2 : seq T] : - {subset s <= s1} -> {subset s <= s1 ++ s2}. -Proof. by move=> ssub g gn; rewrite mem_cat ssub. Qed. - -Lemma subset_catrr [T : eqType] [s s1 s2 : seq T] : - {subset s <= s2} -> {subset s <= s1 ++ s2}. -Proof. by move=> ssub g gn; rewrite mem_cat ssub ?orbT. Qed. - -Lemma subset_id [T : eqType] [s : seq T] : {subset s <= s}. -Proof. by move=> x. Qed. - -Lemma subset_head [T : eqType] [s1 s2 : seq T] [x : T] : - {subset (x :: s1) <= s2} -> head x s1 \in s2. -Proof. -by move=> Sub; apply: Sub; case: s1=> [ | a ?] /=; rewrite !inE eqxx ?orbT. -Qed. - -End subset_tactic. - -Ltac subset_tac := - trivial; - match goal with - | |- {subset ?x <= ?x} => apply: subset_id - | |- {subset (_ :: _) <= _} => apply: subset_consl; subset_tac - | |- {subset (_ ++ _) <= _} => apply: subset_catl; subset_tac - | |- {subset _ <= _ ++ _} => - solve[(apply: subset_catrl; subset_tac)] || - (apply: subset_catrr; subset_tac) - | |- {subset _ <= _} => - let g := fresh "g" in let gin := fresh "gin" in - move=> g gin; rewrite !(mem_cat, inE, cat_rcons); - rewrite ?eqxx ?gin ?orbT //; subset_tac - | |- is_true (?x \in (?x :: _)) => rewrite inE eqxx; done - | |- is_true (head _ (rcons _ _) \in _) => rewrite head_rcons; subset_tac - | |- is_true (head _ _ \in _) => apply: subset_head; subset_tac - | |- is_true (_ \in (_ :: _)) => rewrite inE; apply/orP; right; subset_tac - | |- is_true (_ \in (_ ++ _)) => rewrite mem_cat; apply/orP; - (solve [left; subset_tac] || (right; subset_tac)) - end. - -Section mapi. - -(* TODO: This might be useful one day, because it is used intensively in the - trajectory computation, but not so much in cell decomposition. *) -Definition mapi [T U : Type] (f : T -> Datatypes.nat -> U) (s : seq T) := - map (fun p => f p.1 p.2) (zip s (iota 0 (size s))). - -Lemma nth_mapi [T U : Type] (f : T -> Datatypes.nat -> U) (s : seq T) n d d' : - (n < size s)%N -> - nth d' (mapi f s) n = f (nth d s n) n. -Proof. -rewrite /mapi. -rewrite -[X in f _ X]addn0. -elim: s n 0%N => [ | el s Ih] [ | n] m //=. - rewrite ltnS=> nlt. -by rewrite addSn -addnS; apply: Ih. -Qed. - -End mapi. diff --git a/theories/pol.v b/theories/pol.v deleted file mode 100644 index 38d585e..0000000 --- a/theories/pol.v +++ /dev/null @@ -1,1158 +0,0 @@ -From HB Require Import structures. -From mathcomp Require Import all_ssreflect archimedean. -From mathcomp Require Import ssralg poly ssrnum ssrint rat archimedean polyrcf. -From mathcomp Require Import polyorder polydiv. - -(** * Descartes. - polynomials link with the ssr library *) -(* -Copyright INRIA (20112012) Marelle Team (Jose Grimm; Yves Bertot; Assia Mahboubi). -$Id: pol.v,v 1.35 2012/12/14 11:59:35 grimm Exp $ -*) - -Set Implicit Arguments. -Unset Strict Implicit. -Import Prenex Implicits. - -(* A technical binomial identity for the proof of de Casteljau *) - -Lemma binom_exchange j k q : - 'C(j + k + q, j + k) * 'C(j + k, j) = 'C(k + q, k) * 'C(j + k + q, j). -Proof. -have bin_fact1: forall n m, 'C(n+m,m) * (m`! * n`!) = (n+m)`!. - by move => n m; move: (bin_fact (leq_addl n m)); rewrite addnK. -move: (bin_fact1 (k+q) j) (bin_fact1 q (j+k)). -rewrite (mulnC j`!) (addnC k)(addnC j) - (bin_fact1 q k) - (bin_fact1 k j). -rewrite (mulnAC _ _ j`!) !mulnA - (addnA q) (addnC q) => <-. -move /eqP; rewrite !eqn_pmul2r ? fact_gt0 //;move /eqP ->; apply: mulnC. -Qed. - -Lemma util_C (n i j : nat) : (i <= j) -> (j <= n) -> - ('C(n-i, j-i) * 'C(n, i) = 'C(n, j) * 'C(j, i)). -Proof. -move => ij jn. -move: (binom_exchange i (j - i) (n - j)). -by rewrite (subnKC ij)(subnKC jn) (addnC (j-i)) (addnBA _ ij) (subnK jn). -Qed. - -Import Order.Theory. -Import GRing.Theory. -Import Num.Theory. - -Local Open Scope ring_scope. - -(** ** Properties of ordered fields *) - -Section MoreRealField. - -(** True on characteristic zero *) - -Lemma size_deriv (R:numDomainType) (p: {poly R}): size p^`() = (size p).-1. -Proof. -have [lep1|lt1p] := leqP (size p) 1. - by rewrite {1}[p]size1_polyC // derivC size_poly0 -subn1 (eqnP lep1). -rewrite size_poly_eq // mulrn_eq0 -subn2 -subSn // subn2. -by rewrite lead_coef_eq0 -size_poly_eq0 -(subnKC lt1p). -Qed. - -Variable R : realFieldType. -Implicit Types (x y : R). - -Definition half x := (x / 2%:R). - -Lemma two_unit: (2%:R \is a @GRing.unit R). -Proof. by rewrite unitfE// pnatr_eq0. Qed. - -Lemma half_gt0 x : 0 < x -> 0 < half x. -Proof. by move=> lta; rewrite mulr_gt0 // invr_gt0 ltr0n. Qed. - -Lemma half_ltx x: 0 < x -> half x < x. -Proof. -by move=>lta; rewrite ltr_pdivrMr ?ltr0n // mulr_natr mulr2n ltrDr. -Qed. - -Lemma double_half x : half x + half x = x. -Proof. -by rewrite /half -splitr. -Qed. - -Lemma half_inj (x y : R) : half x = half y -> x = y. -Proof. by move => eq; rewrite - (double_half x) - (double_half y) eq. Qed. - -Lemma half_lin (x y : R) : (half x) + (half y) = half (x + y). -Proof. by rewrite /half mulrDl. Qed. - -Lemma half_lin1 (x y : R) : (half x) - (half y) = half (x - y). -Proof. by rewrite /half mulrBl. Qed. - -Lemma mid_between (a b: R): a < b -> a < half (a + b) < b. -Proof. -move => h. rewrite - half_lin - {1} (double_half a) - {3} (double_half b). -by rewrite ltrD2l ltrD2r ltr_pM2r ?h //invr_gt0 ltr0n. -Qed. - -Lemma maxS (x y: R) (z := (Num.max x y) +1) : (x u < v + 1. - by move=> u v h; rewrite (le_lt_trans h) // ltrDl ltr01. -by rewrite !p1// ?le_max// lexx // orbT. -Qed. - -Lemma pmul2w1 (a b c d : R) : 0 <= a -> 0 <= d -> a <= b -> c <= d -> - a * c <= b * d. -Proof. -move => a0 d0 ab cd. -apply: (le_trans (ler_wpM2l a0 cd)). -by apply: (le_trans (ler_wpM2r d0 ab)). -Qed. - -Lemma inv_comp x y: 0 < x -> 0 < y -> (x < y^-1) = (y < x^-1). -Proof. -move=> xp yp. -rewrite -(ltr_pM2r yp) - [y < _](ltr_pM2l xp). -by rewrite mulVf ?(gt_eqF yp) // mulfV // (gt_eqF xp). -Qed. - -Lemma inv_compr x y: 0 < x -> 0 < y -> (y^-1 < x) = (x^-1 < y). -Proof. -move=> xp yp. -rewrite -(ltr_pM2r yp) - [_ < y](ltr_pM2l xp). -by rewrite mulVf ?(gt_eqF yp) // mulfV // (gt_eqF xp). -Qed. - -End MoreRealField. - -(** ** Big Max on ordered structures *) - -Notation "\max_ ( i <- r | P ) F" := - (\big[Num.max/0%R]_(i <- r | P%B) F%R) : ring_scope. - -Notation "\max_ ( i <- r ) F" := - (\big[Num.max/0%R]_(i <- r) F%R) : ring_scope. -Notation "\max_ ( i < n ) F" := - (\big[Num.max/0%R]_(i < n) F%R) : ring_scope. - -(* NB: ce n'est pas des choses qu'on a dans mathcomp-analysis? *) -Section BigMax. -Variable R : realDomainType. - -Implicit Types (F: R -> R) (s: seq R) (f g : nat -> R). - -Lemma bigmaxr_ge0 s F: 0 <= \max_(i <- s) F i. -Proof. -elim: s; first by rewrite big_nil. -by move=> s IHs Hri0; rewrite big_cons le_max Hri0 orbT. -Qed. - -Lemma bigmaxr_le s F j: - j \in s -> F j <= \max_(i <- s) F i. -Proof. -elim: s; first by rewrite in_nil. -move=> i s IHs Hri0; rewrite big_cons. -case Hi: (j == i); first by rewrite (eqP Hi) le_max lexx. -move: Hri0; rewrite in_cons Hi orFb => ins. -by apply: le_trans (IHs ins) _; rewrite le_max lexx orbT. -Qed. - -Lemma bigmaxr_le0 s F: - \max_(i <- s) F i <= 0 -> forall i, i \in s -> F i <= 0. -Proof. -elim: s; first by move=> _ i;rewrite in_nil. -move=> k s IHs; rewrite big_cons ge_max; case /andP => Fk Hr1 i. -rewrite in_cons; case /orP; [ move /eqP ->; apply: Fk | by apply: IHs]. -Qed. - - -Lemma bigmaxr_gt0 s F: - \max_(i <- s) F i > 0 -> { i | i \in s & F i > 0}. -Proof. -elim :s => [| a l Hrec]; first by rewrite big_nil ltxx. -rewrite big_cons lt_max. -case (ltrP 0 (F a)); first by exists a => //; rewrite in_cons eqxx. -rewrite leNgt => /negbTE ->; rewrite orFb => /Hrec [b bl fp0]. -by exists b => //;rewrite in_cons bl orbT. -Qed. - -Lemma bigmaxr_arg s F: - {j | j \in s & 0 <= F j} -> {j | j \in s & \max_(i <- s) F i = F j}. -Proof. -elim:s; first by case => w ;rewrite in_nil. -move => a l Hrec ew; rewrite big_cons. -case (lerP (\max_(i <- l) F i) (F a)) => cmpm. - by exists a; [ rewrite in_cons eqxx | apply /eqP; rewrite eq_maxl]. -move: (ltW cmpm); rewrite - eq_maxr; move /eqP => ->. -suff aux: { w : R | w \in l & 0 <= F w}. - move: (Hrec aux) => [j jl jm]; exists j =>//; rewrite in_cons jl orbT//. -move: ew => [w]; rewrite in_cons => h1 h2. -case e: (w == a); last first. - exists w => //; move: h1; case /orP => //; rewrite e //. -rewrite (eqP e) in h2; move: (le_lt_trans h2 cmpm) => aux. -by move: (bigmaxr_gt0 aux) =>[j ja jb]; exists j =>//; apply: ltW. -Qed. - -Lemma bigmaxr_lerP s F m: - m >= 0 -> reflect (forall i, i \in s -> F i <= m) (\max_(i <- s) F i <= m). -Proof. -move=> h; apply: (iffP idP) => leFm => [i ir | ]. - by apply: le_trans leFm; apply: bigmaxr_le. -rewrite big_seq_cond; elim /big_ind:_ => //. - by move=> x y xm ym; rewrite ge_max; apply /andP. -by move=> i; rewrite andbT; apply: leFm. -Qed. - -Lemma bigmaxr_arg1 s F j: - j \in s -> 0 <= F j -> (forall i, i \in s -> F i <= F j) -> - \max_(i <- s) F i = F j. -Proof. -move => js fjp; move / (bigmaxr_lerP s F fjp) => le1. -by apply /eqP; rewrite eq_le le1 (bigmaxr_le _ js). -Qed. - -Lemma bigmaxf_nil f: \max_(i< 0) (f i) = 0. -Proof. by rewrite big_ord0. Qed. - -Lemma bigmaxf_rec f n : - \max_(i < n.+1) f i = Num.max (f n) (\max_(i < n) f i). -Proof. -move: f. -elim: n => [ f /=|s Hrec f]; first by rewrite big_ord_recl big_ord0 big_ord0. -symmetry; rewrite big_ord_recl maxCA big_ord_recl. -pose g i := f i.+1. -have aux: forall k, \max_(i < k) f (lift ord0 i) = (\max_(i < k) g i). - move=> k; apply: eq_big => // i. -by rewrite aux aux Hrec. -Qed. - -Lemma bigmaxf_ge0 f n: 0 <= \max_(i < n) f i. -Proof. -elim: n => [| n IHn]; first by rewrite big_ord0. -by rewrite bigmaxf_rec le_max IHn orbT. -Qed. - -Lemma bigmaxf_le f n j: (j < n)%N -> f j <= \max_(i < n) f i. -Proof. -elim: n => [ //| n IHn]; rewrite bigmaxf_rec. -case Hi: (j == n); first by rewrite (eqP Hi) le_max lexx. -rewrite ltnS leq_eqVlt Hi orFb => aux;apply: (le_trans (IHn aux)). -by rewrite le_max lexx orbT. -Qed. - -Lemma bigmaxf_le0 f n: \max_(i < n) f i <= 0 -> - forall i, (i f i <= 0. -Proof. -elim: n => [_ i //| n Hr]; rewrite bigmaxf_rec ge_max; case /andP => Fk H i. -rewrite ltnS leq_eqVlt; case /orP; [ move /eqP ->; apply: Fk | by apply: Hr]. -Qed. - -Lemma bigmaxf_gt0 f n: \max_(i < n ) f i > 0 -> { i | (i 0}. -Proof. -elim :n => [| a IH]; first by rewrite big_ord0 ltxx. -case (ltrP 0 (f a)); first by exists a. -rewrite bigmaxf_rec lt_max leNgt; move /negbTE => ->; rewrite orFb => aux. -by move: (IH aux) => [b bl fp0]; exists b => //; apply:ltn_trans (ltnSn a). -Qed. - -Lemma bigmaxf_arg f n : - {j | (j {j | (j [ [j] // | n Hr Hf]; rewrite bigmaxf_rec. -case (lerP (\max_(i < n) f i) (f n)) => cmpm. - by exists n => //; apply /eqP; rewrite eqr_maxl. -move: (ltW cmpm); rewrite - eq_maxr/=; move /eqP => <-. -suff aux: { j | (j < n)%N & 0 <= f j}. - move: (Hr aux) => [j jl jm]; exists j. - by rewrite ltnS ltnW. - rewrite /Num.max/= jm; case: ifPn => //. - by rewrite -jm cmpm. -move: Hf => [j]; rewrite ltnS leq_eqVlt. -case e: (j == n); last by rewrite orFb; exists j => //. -rewrite (eqP e) => _ h2; move: (le_lt_trans h2 cmpm) => aux. -by move: (bigmaxf_gt0 aux) =>[k ja jb]; exists k =>//; apply: ltW. -Qed. - -Lemma bigmaxf_lerP f n m: - m >= 0 -> reflect (forall i, (i < n)%N -> f i <= m) (\max_(i h; apply: (iffP idP) => leFm => [i ir | ]. - by apply: le_trans leFm; apply: bigmaxf_le. -rewrite big_seq_cond; elim /big_ind:_ => //. - by move=> x y xm ym; rewrite ge_max; apply /andP. -by move=> [i hi] _; apply: leFm. -Qed. - -Lemma bigmaxf_arg1 f n j: - (j < n)%N -> 0 <= f j -> (forall i, (i < n)%N -> f i <= f j) -> - \max_(i < n) f i = f j. -Proof. -move => js fjp; move / (bigmaxf_lerP f n fjp) => le1. -by apply /eqP; rewrite eq_le le1 (bigmaxf_le _ js). -Qed. - -Lemma normr_sumprod f g n : - `| \sum_(i< n) (f i * g i) | - <= (\max_(i< n) `|f i|) * \sum_ (i: \sum_(i < n) `|f i * g i| = \sum_(i < n) `|f i| * `|g i|. - by apply: eq_big => // i; rewrite normrM. -rewrite mulr_sumr; apply: ler_sum => i _; apply: ler_wpM2r. - by rewrite normr_ge0. -by apply: (bigmaxf_le (fun i => `|f i|)). -Qed. - -Lemma normr_sumprod1 f g n b: - 0 <= b -> (forall i, (i `|f i| <= b) -> - `| \sum_(i< n) (f i * g i) | <= b * \sum_ (i b0 h; apply: (le_trans (normr_sumprod f g n)). -apply: ler_wpM2r; first by rewrite sumr_ge0 // => i _; rewrite absr_ge0. -exact /(bigmaxf_lerP (fun z => `|f z|) n b0). -Qed. - -End BigMax. - -(** ** bigops *) - -Section BigOps. -Variables (R : comRingType) (idx : R) (op : Monoid.com_law idx). - -Lemma big_ord_rev (n : nat) (P : nat -> bool) (F : nat -> R): - \big[op/idx]_(i < n | P i) F i = - \big[op/idx]_(i < n | P (n - i.+1)%N) F ( n - i.+1)%N. -Proof. by rewrite -big_mkord big_rev_mkord subn0. Qed. - -Lemma bigop_simpl1 (n m : nat) (F : nat -> R): - (forall j, (m <= j)%N -> F j = idx) -> - \big[op/idx]_(j < n) F j = \big[op/idx]_(j < m | (j < n)%N) F j. -Proof. -set s := (n + m)%N => h. -rewrite (big_ord_widen s F (leq_addr m n)). -rewrite (big_ord_widen_cond s (fun j => (j < n)%N) F (leq_addl n m)). -rewrite (bigID (fun i0:ordinal s => (i0 < m)%N) _ F) /=. -rewrite [X in op _ X] big1 ? Monoid.mulm1 //. -by move => j; rewrite -leqNgt; case/andP => _; by apply: h. -Qed. - -Lemma shorten_sum (f: nat -> R) (n m : nat): - (n <= m)%N -> (forall i, (n <= i < m)%N -> f i = idx) -> - \big[op/idx]_(i < m) f i = \big[op/idx]_(i < n) f i. -Proof. -move => nm fz. -rewrite - (big_mkord xpredT) (big_cat_nat _ _ _ (leq0n n) nm) /= big_mkord. -rewrite [X in (op _ X)]big1_seq ? Monoid.mulm1 // => i; case /andP => _. -by rewrite mem_index_iota; apply: fz. -Qed. - -Lemma big_ord1 (F: 'I_1 -> R) : \big[op/idx]_(i < 1) (F i) = F ord0. -Proof. by rewrite big_ord_recl big_ord0 Monoid.mulm1. Qed. - -End BigOps. - -Section RingPoly. -Variable R : ringType. - -Lemma polyd0 (F: nat -> R): \poly_(i < 0) (F i) = 0. -Proof. -apply /eqP;rewrite - size_poly_eq0; rewrite - leqn0; exact: (size_poly 0 F). -Qed. - -Lemma sum_powers_of_x (n: nat) (x:R): - (x-1) * (\sum_(i < n) x^+ i) = x ^+ n - 1. -Proof. -elim: n => [| n Ihn]. - by rewrite big_ord0 expr0 mulr0 subrr. -rewrite (big_ord_recr n) /= mulrDr Ihn mulrBl mul1r - exprS. -by rewrite addrAC addrCA subrr addr0. -Qed. - -Lemma power_monom (c:R) n : - ('X + c%:P) ^+ n = \poly_(i< n.+1) (c^+(n - i)%N *+ 'C(n, i)). -Proof. -rewrite addrC exprDn_comm; last by apply: commr_polyX. -rewrite poly_def; apply: eq_big => // [[i lin]] _ /=. -by rewrite - mul_polyC - polyC_exp polyCMn mulrnAl. -Qed. - -End RingPoly. - -(** ** Shift and scale *) - -Definition shift_poly (R:ringType) (c:R)(p: {poly R}) := p \Po ('X + c%:P). -Definition scaleX_poly (R:ringType) (c:R)(p: {poly R}) := p \Po ('X * c%:P). - -Notation "p \shift c" := (shift_poly c p) (at level 50) : ring_scope. -Notation "p \scale c" := (scaleX_poly c p) (at level 50) : ring_scope. - -Section ComPoly. -Variable R : comRingType. -Implicit Types (p : {poly R}) (c : R). - -Lemma poly_comp_exp (p r: {poly R}) i: - (p ^+i) \Po r = (p \Po r) ^+ i. -Proof. -elim: i => [| i ihi]; first by rewrite !expr0 comp_polyC. -by rewrite !exprS comp_polyM ihi. -Qed. - -Lemma shift_polyD1 (c1 c2 : R): - ('X + c1%:P) \shift c2 = ('X + (c2 + c1)%:P). -Proof. -by rewrite /shift_poly comp_polyD comp_polyX comp_polyC polyCD addrA. -Qed. - -Lemma shift_polyB1 (c1 c2 : R): - (c1%:P - 'X) \shift c2 = (c1 - c2)%:P -'X. -Proof. -rewrite /shift_poly comp_polyB comp_polyC comp_polyX opprD. -by rewrite - addrCA addrC polyCB. -Qed. - -Lemma shift_polyE c p: - p \shift c = - \poly_(i < size p) \sum_(k < size p) p`_k * c ^+ (k - i) *+ 'C(k, i). -Proof. -rewrite /shift_poly comp_polyE poly_def; symmetry. -transitivity (\sum_(i < size p) - \sum_(k < size p) ((p`_k)%:P * (c ^+ (k - i) *+ 'C(k, i) *: 'X^i))). - apply: eq_big => // [[i ip]] _ /=; rewrite - mul_polyC. - rewrite rmorph_sum big_distrl; apply: eq_big => // [[k kp]] _ /=. - rewrite - mulrnAr polyCM -mul_polyC mulrA //. -rewrite exchange_big; apply: eq_big => // [[i ip]] _ /=. -rewrite -big_distrr - mul_polyC; congr (_ * _). -rewrite power_monom poly_def /=. -have aux: forall j, (i < j < size p)%N ->(c ^+ (i - j) *+ 'C(i, j)) *: 'X^j = 0. - move=> j; case /andP => ij js; rewrite bin_small ?mulr0n ? scale0r//. -by rewrite (shorten_sum _ ip aux). -Qed. - -Lemma horner_shift_poly c p x: (p \shift c).[x] = p.[x + c]. -Proof. by rewrite horner_comp !hornerE. Qed. - -Lemma horner_shift_poly1 c p x : p.[x] = (p \shift c).[x - c]. -Proof. by rewrite horner_shift_poly addrNK. Qed. - -Lemma shift_polyC c a: a%:P \shift c = a%:P. -Proof. by rewrite /shift_poly comp_polyC. Qed. - -Lemma shift_poly_is_linear c: linear (shift_poly c). -Proof. by move=> a u v; rewrite /shift_poly comp_polyD comp_polyZ. Qed. - -Lemma shift_poly_multiplicative c: multiplicative (shift_poly c). -Proof. -split. move=> x y; exact: comp_polyM. by rewrite /shift_poly comp_polyC. -Qed. - -HB.instance Definition _ (c : R) := GRing.isLinear.Build _ _ _ _ _ (shift_poly_is_linear c). - -HB.instance Definition _ c := GRing.isMultiplicative.Build _ _ _ (shift_poly_multiplicative c). - -(*HB.instance Definition _ c := GRing.isLinear.Build _ _ _ _ _ (shift_poly_is_linear c). - -Canonical shift_poly_additive c := Additive (shift_poly_is_linear c). -Canonical shift_poly_linear c := Linear (shift_poly_is_linear c). -Canonical shift_poly_rmorphism c := AddRMorphism (shift_poly_multiplicative c).*) - -Lemma shift_polyD c1 c2 p: - p \shift (c2 + c1) = (p\shift c1) \shift c2. -Proof. by rewrite /shift_poly - comp_polyA - shift_polyD1. Qed. - -Lemma shift_poly_scal a b p : - (a%:P * p) \shift b = a%:P * (p \shift b). -Proof. by rewrite shift_poly_multiplicative shift_polyC. Qed. - -Lemma shift_polyDK c p: - p \shift c \shift -c = p. -Proof. -by rewrite - shift_polyD addrC subrr /shift_poly addr0 comp_polyXr. -Qed. - -Lemma shift_polyX c p i: - ((p^+i) \shift c) = (p \shift c) ^+i. -Proof. by rewrite /shift_poly - poly_comp_exp. Qed. - -Lemma shift_polyXn c i: - ('X^i \shift c) = ('X + c%:P)^+i. -Proof. by rewrite (shift_polyX c 'X i) /shift_poly comp_polyX. Qed. - - -Lemma shift_poly_nth p i c: (i < size p)%N -> - (shift_poly c p)`_i = - \sum_(k < size p) p`_k * c^+(k - i) *+ 'C(k, i). -Proof. by move=> ltis; rewrite shift_polyE coef_poly ltis. Qed. - -Lemma shift_poly_nth1 c p i m: (size p <= m)%N -> - (shift_poly c p)`_i = - \sum_(k < m) p`_k * c^+(k - i) *+ 'C(k, i). -Proof. -move=> ltpm; rewrite shift_polyE coef_poly. -case sip: (i < size p)%N; last first. - rewrite big1 => // [[j jm]] _ /=; case (leqP i j) => ij. - move: sip; case (ltnP i (size p)) => // sip1 _. - by move: (leq_trans sip1 ij) => /(nth_default 0) ->; rewrite mul0r mul0rn. - rewrite bin_small //. -have aux: forall k, (size p <= k < m)%N ->p`_k * c ^+ (k - i) *+ 'C(k, i) = 0. - move=> k; case /andP => ij js; move: ij => /(nth_default 0) ->. - by rewrite mul0r mul0rn. -symmetry;apply: (shorten_sum _ ltpm aux). -Qed. - -(* We give here the coefficients of scale and shift *) -Lemma scaleX_polyE c p: - p \scale c = \poly_(i < size p)(p`_i * c ^+i). -Proof. -rewrite /scaleX_poly comp_polyE poly_def; apply: eq_bigr => i _. -by rewrite -scalerA - exprZn - (mul_polyC c) commr_polyX. -Qed. - -Lemma horner_scaleX_poly c p x : (p \scale c).[x] = p.[c * x]. -Proof. by rewrite horner_comp ! hornerE mulrC. Qed. - -End ComPoly. - -(** ** Reciprocal *) - -Definition reciprocal_pol (R:ringType) (p: {poly R}):= - \poly_(i < size p) p`_(size p - i.+1). - -(* The Bernstein coefficients of polynomial l for the interval (a, b) *) - -Definition recip (R : ringType) (deg : nat) (q : {poly R}) : {poly R} := - 'X ^+ (deg.+1 - size q) * reciprocal_pol q. - -Definition Mobius (R:ringType) (deg : nat) (a b : R) (p: {poly R}) : {poly R} := - recip deg ((p \shift a) \scale (b - a)) \shift 1. - -Lemma reciprocal_Xn (R : idomainType) n : reciprocal_pol ('X^n) = (GRing.one R)%:P. -Proof. -rewrite /reciprocal_pol size_polyXn poly_def big_ord_recl. -rewrite subSS subn0 coefXn expr0 eqxx scale1r big1 ?addr0 // => i _. -rewrite lift0 subSS coefXn /=. -have /negbTE -> : (n - i.+1)%N != n. - by rewrite neq_ltn -(ltn_add2r i.+1) subnK// -addSnnS ltn_addr. -by rewrite -mul_polyC mul0r. -Qed. - -Section ReciprocalPoly. - -Variable (R : idomainType). -Implicit Type p : {poly R}. - -Lemma size_scaleX c p : c != 0 -> size (p \scale c) = size p. -Proof. by move=> cu; rewrite size_comp_poly2 // size_XmulC. Qed. - -Lemma reciprocal_size p: p`_0 != 0 -> size (reciprocal_pol p) = size p. -Proof. -rewrite /reciprocal_pol => td0. -apply: size_poly_eq; rewrite prednK ?subnn // size_poly_gt0. -by apply /eqP => pz; case /eqP:td0; rewrite pz coefC. -Qed. - -Lemma reciprocal_idempotent p: p`_0 != 0 -> - reciprocal_pol (reciprocal_pol p) = p. -Proof. -move=> h;rewrite - polyP {1}/reciprocal_pol (reciprocal_size h) => i. -rewrite coef_poly /reciprocal_pol coef_poly. -case: (ltnP i (size p)); last by move => /(nth_default 0). -move => isp; rewrite - (subnKC isp). -by rewrite -subn_gt0 addSn addnC -addnS addnK addKn addnS addnC -addnS addnK. -Qed. - -Lemma size_poly_coef_eq0 : - forall p q : {poly R}, (forall i, (p`_i == 0) = (q`_i == 0)) -> - size p = size q. -Proof. -by move=> p q c; apply/eqP; rewrite eqn_leq;apply/andP; split; - apply/leq_sizeP => j cj; apply/eqP; (rewrite c || rewrite -c); - apply/eqP; move: j cj; apply/leq_sizeP. -Qed. - -(* -Lemma reciprocal_pol_scale_swap : - forall p (c : R), c!= 0 -> p`_0 != 0 -> - reciprocal_pol (p \scale c) = (c ^ (size p).-1)%:P - * (reciprocal_pol p \scale c^-1). -Proof. -(* Without the condition on the first coefficient. -move=> p c cu (* p0 *); rewrite [_ \scale c^-1]/scaleX_poly comp_polyE. -rewrite [_ (_ \scale _)]/reciprocal_pol poly_def size_scaleX //. -have t : (size (reciprocal_pol p) <= size p)%N by apply: size_poly. -rewrite (big_ord_widen _ - (fun i : nat => (reciprocal_pol p)`_i *: ('X * (c^-1)%:P) ^+ i) t). -rewrite (big_mkcond (fun i : 'I_(size p) => (i < _)%N)) big_distrr /=. -apply: eq_bigr; move => [i ci] _ /=. -Search _ nth (_ \scale _). -rewrite scaleX_polyE coef_poly. -have -> : (size p - i.+1 < size p)%N. - move: ci; case h : (size p) => [ | n]; first by rewrite ltn0. - by move=> _; rewrite subSS (leq_ltn_trans _ (ltnSn _)) // leq_subr. -case t' : (i < size (reciprocal_pol p))%N; last first. -*) -rewrite reciprocal_size /reciprocal_pol // size_scaleX // poly_def. -rewrite big_distrr; apply eq_bigr => i _. -rewrite exprMn_comm; last by apply: mulrC. -rewrite coef_poly ltn_ord scaleX_polyE coef_poly /=. -have -> : (size p - i.+1 < size p)%N. - case h' : (size p) i => [ | n] i' //; first by case i'. - by rewrite (leq_ltn_trans _ (ltnSn n)) // subSS // leq_subr. -rewrite -polyC_exp (mulrC 'X^i) !mul_polyC !scalerA; congr (_ *: _). -rewrite mulrAC exprVn -exprnP mulrC; congr (_ * _). -case: i => i ci /=. -case h : (size p == i.+1). - by rewrite (eqP h) subnn expr0 /= mulfV // expf_eq0 (negbTE cu) andbF. -case: (size p) ci h => //= n in1 dif; rewrite subSS expfB //. -by move: in1; rewrite leq_eqVlt eq_sym dif orFb ltnS. -Qed. -*) - -Lemma horner_reciprocal p x : - x \is a GRing.unit -> (reciprocal_pol p).[x] = x ^+ (size p - 1) * p.[x^-1]. -Proof. -move=> xn0; rewrite /reciprocal_pol horner_poly. -case sp : (size p) => [| n]. - rewrite sub0n expr0 mul1r big_ord0; move/eqP: sp; rewrite size_poly_eq0. - by move/eqP->; rewrite horner0. -rewrite horner_coef subn1 /= big_distrr /=. -pose f (j : 'I_n.+1) := Ordinal (leq_subr j n:n - j < n.+1)%N. -have finv: forall j:'I_n.+1, xpredT j -> f (f j) = j. - by move => j _; apply: val_inj => /=; rewrite subKn //; have : (j < n.+1)%N. -rewrite (reindex_onto f f finv) /=. -have tmp :(fun j => f (f j) == j) =1 xpredT. - by move=> j /=; apply/eqP; apply finv. -rewrite (eq_bigl _ _ tmp) {tmp} sp; apply: eq_bigr => [[j hj]] _ /=. -rewrite subSS subKn // -mulrCA; congr (_ * _). -rewrite ltnS in hj; rewrite - {2}(subnK hj) exprD -mulrA exprVn. -by rewrite divrr ? mulr1 // unitrX. -Qed. - -Lemma horner_reciprocal1 p x : - x \is a GRing.unit -> p.[x] = x ^+ (size p - 1) * (reciprocal_pol p).[x^-1]. -Proof. -move=> xz; rewrite horner_reciprocal ?unitrV //. -by rewrite mulrA invrK - exprMn divrr // expr1n mul1r. -Qed. - -Lemma reciprocal_monom (a b: R): a != 0 -> - reciprocal_pol ('X * a%:P + b%:P) = ('X * b%:P + a%:P). -Proof. -move=> /negbTE h; rewrite /reciprocal_pol. -have ->: size ('X * a%:P + b%:P) = 2%N. - by rewrite - commr_polyX size_MXaddC size_polyC polyC_eq0 h. -apply/polyP=> i. -rewrite coef_poly !coefD !coefMC !coefC !coefX. -case :i; first by rewrite mul1r mul0r add0r addr0. -case; first by rewrite mul1r mul0r add0r addr0. -by move=> n /=; rewrite mul0r add0r. -Qed. - -Lemma reciprocalC (c : R) : reciprocal_pol c%:P = c%:P. -Proof. -rewrite /reciprocal_pol - polyP => i; rewrite coef_poly. -case cz: (c==0); first by move /eqP in cz; rewrite cz !coef0 if_same. -rewrite size_polyC cz !coefC; case:i => [| i]//. -Qed. - -Lemma reciprocalM p q : - reciprocal_pol (p * q) = reciprocal_pol p * reciprocal_pol q. -Proof. -move: (reciprocalC 0) => aux. -case (poly0Vpos p); first by move => ->; rewrite mul0r aux mul0r. -case (poly0Vpos q); first by move => -> _; rewrite mulr0 aux mulr0. -set m:= (size p + size q).-1; move=> pa pb. -have mp: (size p + size q)%N = m .+1. - by symmetry;rewrite /m prednK // addn_gt0 pa pb. -have qa: (size p <= m)%N by rewrite /m - (prednK pa) addnS leq_addr. -have qb: (size q <= m)%N by rewrite /m addnC - (prednK pb) addnS leq_addr. -have pnz: p != 0 by rewrite - size_poly_eq0 - lt0n. -have qnz: q != 0 by rewrite - size_poly_eq0 - lt0n. -rewrite /reciprocal_pol size_mul //. -rewrite - polyP => i; rewrite coef_poly coefM coefM. -case: (ltnP i (size p + size q).-1) => ipq; last first. - rewrite big1 // => [] [] j ij _ /=; rewrite ! coef_poly. - case lt1: (j < size p)%N; last by rewrite mul0r. - case lt2: (i - j < size q)%N; last by rewrite mulr0. - move: (leq_add lt1 lt2). - by rewrite addnS addSn mp ltnS subnKC ? ltnS // ltnNge ipq. -set mi:= ((size p + size q).-1 - i.+1)%N. -pose f j := (p`_j * q`_(mi - j)). -have aux1: forall j, (size p <=j) %N -> f j = 0. - by move=> j; rewrite /f; move => /(nth_default 0) => ->; rewrite mul0r. -rewrite (bigop_simpl1 _ mi.+1 aux1). -pose g1 j := (\poly_(i0 < size p) p`_(size p - i0.+1))`_j. -pose g2 j := (\poly_(i0 < size q) q`_(size q - i0.+1))`_j. -pose g j := g1 j * g2 (i - j)%N. -have aux2: forall j : nat, (size p <= j)%N -> g j = 0. - by move => j; rewrite /g/g1 coef_poly ltnNge; move => ->; rewrite mul0r. -rewrite (bigop_simpl1 _ i.+1 aux2). -transitivity (\sum_(j < size p | (j < i.+1)%N) - p`_(size p - j.+1) * g2 (i - j)%N); last first. - by apply: eq_big => // [[j ji]] _ /=; rewrite /g/g1 coef_poly ji. -symmetry; rewrite (big_ord_rev _ (size p) (fun j => (j < i.+1)%N) - (fun j => p`_(size p - j.+1) * g2 (i - j)%N)) /=. -rewrite big_mkcond [X in _ = X] big_mkcond; apply: eq_bigr => [[k kp]] _ /=. -case Ha: ((size p - k.+1) < i.+1)%N; last first. - case Hb: (k < mi.+1)%N => //; rewrite /f. - suff:(size q <= (mi - k))%N by move => /(nth_default 0) => ->; rewrite mulr0. - rewrite ltnS in Hb; rewrite -(leq_add2l k) (subnKC Hb) -(leq_add2l i.+1). - rewrite (subnKC ipq) addSn addnA -ltnS mp /= -mp -addSn -addSn leq_add2r. - by rewrite -addnS -(subnK kp) -addSn leq_add2r ltnNge -ltnS Ha. -rewrite (subnSK kp) (subKn (ltnW kp)) (subnBA _ kp) - addSnnS. -move: Ha; rewrite ltnS leq_subLR addSnnS addnC => Ha. -have ->: (k < mi.+1)%N = (i.+1 + k <= m)%N. - by rewrite /mi ltnS - (leq_add2l (i.+1)) (subnKC ipq) mp. -rewrite /g2 coef_poly; case Hb: (i.+1 + k <= m)%N; last first. - suff: ~~(i.+1 + k - size p < size q)%N by move /negbTE => ->;rewrite mulr0. - by rewrite -ltnNge ltnS - (leq_add2l (size p)) (subnKC Ha) mp ltnNge Hb. -rewrite /f - (ltn_add2l (size p)) (subnKC Ha) mp ltnS Hb; congr (_ * (q`_ _)). -apply /eqP; rewrite - (eqn_add2r (i.+1 + k)%N)- subnDA (subnK Hb). -have m1: m = (size p + (size q).-1)%N by rewrite /m -(ltn_predK pa) addnS. -rewrite addnC -(ltn_predK pa) subSS - {1} (subnK Ha) (addnC _ (size p)). -by rewrite - addnA m1 subnKC // leq_subLR - m1. -Qed. - -Lemma reciprocal_Xn_root0 (p : {poly R}) : - reciprocal_pol p = reciprocal_pol (p %/ 'X^(\mu_0 p)). -Proof. -rewrite -(addr0 'X) -oppr0. -have Hmu0 := root_mu p 0. -rewrite Pdiv.IdomainMonic.dvdp_eq in Hmu0; last first. - by rewrite monic_exp// monicXsubC. -by rewrite {1}(eqP Hmu0) reciprocalM {2}oppr0 addr0 reciprocal_Xn - polyC1 mulr1 polyC0. -Qed. - -Lemma reciprocalX p n : reciprocal_pol (p ^+ n) = (reciprocal_pol p) ^+ n. -Proof. -elim: n=> [| n Hrec]; first rewrite !expr0 reciprocalC //. -by rewrite ! exprS reciprocalM Hrec. -Qed. - -Lemma pdivmu0_0th_neq0 (p : {poly R}) : p != 0 -> (p %/ 'X^(\mu_0 p))`_0 != 0. -Proof. -move=> Hp. -have H0noroot : ~~(root (p %/ 'X^(\mu_0 p)) 0). - rewrite -mu_gt0. - rewrite -eqn0Ngt -(addr0 'X) -(@oppr0 {poly R}) -polyC0 mu_div - ?subn_eq0; by rewrite leqnn. - rewrite Pdiv.CommonIdomain.divp_eq0 negb_or Hp /= negb_or. - rewrite -size_poly_gt0 {1}size_polyXn /= -leqNgt dvdp_leq //. - by rewrite -(addr0 'X) -oppr0 -polyC0 root_mu. -rewrite -horner_coef0. apply: negbT. -by move/rootPf : H0noroot. -Qed. - -Lemma reciprocal_reciprocal (p : {poly R}) : - reciprocal_pol (reciprocal_pol p) = p %/ ('X^(\mu_0 p)). -Proof. -case Hp0 : (p == 0). - move/eqP : Hp0 => ->. - by rewrite !reciprocalC div0p polyC0. -rewrite (@reciprocal_Xn_root0 p) reciprocal_idempotent //. -apply: pdivmu0_0th_neq0. -by apply: negbT. -Qed. - -Lemma reciprocal0 (p : {poly R}) : (reciprocal_pol p == 0) = (p == 0). -Proof. -apply/idP/idP => Hp. - have H : (p %/ ('X^(\mu_0 p)) == 0). - by rewrite -reciprocal_reciprocal -polyC0 -reciprocalC (eqP Hp). - rewrite Pdiv.CommonIdomain.divp_eq0 in H. - move/orP : H; case => [| /orP [] H] //. - by rewrite -size_poly_eq0 size_polyXn -(Bool.negb_involutive (_.+1 == 0%N)) - -lt0n /= in H. - have H2 := (root_mu p 0). - case Hp0 : (p == 0) => //. - rewrite gtNdvdp // in H2. - by apply: negbT. - by rewrite oppr0 addr0. -by rewrite (eqP Hp) -polyC0 reciprocalC. -Qed. - -(* -Lemma reciprocal_nth : forall (p : {poly R}) k, (k < size p)%N -> - (reciprocal_pol p)`_k = p`_((size p) - k.+1). -Proof. -move=> p k Hk. -by rewrite /reciprocal_pol coef_poly Hk. -Qed. -*) - -Lemma reciprocal_nth_2 (p : {poly R}) k : (k < size p)%N -> - (reciprocal_pol p)`_(size p - k.+1) = p`_k. -Proof. -move=> Hk. -rewrite /reciprocal_pol coef_poly. -have Hk2 : (size p - k.+1 < size p)%N. - by rewrite -(ltn_add2r k.+1) subnK // -addSnnS ltn_addr. -rewrite Hk2 !subnS -!subn1 !subnBA; last by rewrite subn_gt0. - by rewrite addn1 -subnDA addn1 addnC addnK. -exact: ltnW. -Qed. - -Lemma reciprocal_eq (p q : {poly R}) : p`_0 != 0 -> q`_0 != 0 -> - (p == q) = (reciprocal_pol p == reciprocal_pol q). -Proof. -move=> p0 q0; apply/idP/idP => [/eqP ->//|/eqP pq]. -apply/eqP/poly_inj. -have Hsize : size p = size q. - by rewrite -reciprocal_size // -(@reciprocal_size q) // pq. -apply: (@eq_from_nth _ 0) => // i ip. -rewrite -reciprocal_nth_2// -(@reciprocal_nth_2 q) //. - by rewrite pq Hsize. -by rewrite -Hsize. -Qed. - -End ReciprocalPoly. - -(** ** Cauchy bound *) - -Section CauchyBound. - -Variable F : realFieldType. - -Variables (n : nat) (E : nat -> F) (x : F). -Hypothesis pnz : E n != 0. -Hypothesis xr: root (\poly_(i < n.+1) E i) x. - -Lemma CauchyBound_aux : x^+n = - \sum_(i < n) ((E i / E n) * x^+ i). -Proof. -move: xr; move /rootP => xr1. -have ->: \sum_(i < n) E i / E n * x ^+ i = \sum_(i < n) (E i * x ^+ i / E n). - by apply: eq_bigr => i _ ; rewrite mulrAC. -rewrite -(mulfK pnz (x ^+ n)); apply /eqP; rewrite -addr_eq0 - mulr_suml. -rewrite - mulrDl mulf_eq0 -{2} xr1; apply /orP; left. -by rewrite horner_poly (big_ord_recr n) //= addrC mulrC. -Qed. - - -Lemma CauchyBound1 : `| x | <= 1 + \max_(i < n) (`|E i / E n|). -Proof. -move: (bigmaxf_ge0 (fun i => `|E i / E n|) n) => cp. -case: (lerP `|x| 1)=> cx1; first by rewrite ler_wpDr //. -rewrite addrC -lerBlDr. -move: (normr_sumprod (fun i => E i / E n) (fun i => x ^+ i) n). -move: CauchyBound_aux => eq; move: (f_equal (fun z => `| z |) eq). -rewrite normrN; move => <-; -have ->: \sum_(i < n) `|x ^+ i| = (\sum_(i < n) `|x| ^+ i). - by apply: eq_big => // i _; rewrite normrX. -move: cp. -case:n => [| m]; first by rewrite big_ord0 mulr0 expr0 normr1 ler10. -move: (sum_powers_of_x (m.+1) `|x|); set aux:= (\sum_(i < m.+1) _) => pa. -set c := \max_(i < m.+1) `|E i / E m.+1| => cp r1. -have a1p: 0 < `|x| - 1 by rewrite subr_gt0. -have r2 : c* aux <= c* ( (`|x| ^+ m.+1) /(`|x| - 1)). - by rewrite (ler_wpM2l cp) // ler_pdivlMr // mulrC pa gerDl lerN10. -move: (le_trans r1 r2); rewrite mulrA ler_pdivlMr // mulrC. -rewrite normrX ler_pM2r //. -by apply:(lt_trans ltr01); rewrite exprn_egt1. -Qed. - -Lemma CauchyBound2 : `| x | <= \sum_(i < n.+1) `|E i / E n|. -Proof. -case: (lerP `|x| 1)=> cx1. - apply: (le_trans cx1). - rewrite big_ord_recr /= divff // normr1 lerDr. - rewrite sumr_ge0 // => i _; rewrite absr_ge0 //. -move: (CauchyBound_aux). -case e: n=> [| m]. - by rewrite expr0 big_ord0 oppr0; move /eqP; rewrite oner_eq0. -case x0 : (x == 0). - by move: cx1; rewrite (eqP x0) normr0 ltr10. -have xmn0 : (x^+m != 0) by rewrite expf_eq0 x0 andbF. -move => h1; have h2 : x = - \sum_(i < m.+1) ( x^-(m - i) *(E i / E m.+1)). - apply: (mulIf xmn0); rewrite mulNr big_distrl /= -exprS h1; congr (- _). - apply: congr_big; [by [] | by [] |] => [[i hi]] _ /=. - have mi : m = (m - i + i)%N by rewrite subnK //. - by rewrite (mulrC (x ^-(m -i)) _) {4} mi exprD -!mulrA mulKf // - expf_eq0 x0 andbF. -rewrite (f_equal (fun z => `| z |) h2) normrN. -apply: le_trans (_: (\sum_(i < m.+1) `|E i / E m.+1|) <= _); last first. - by rewrite (big_ord_recr m.+1) /= lerDl normr_ge0. -have pa: (forall i, (i `| x ^- (m - i) | <= 1). - move => i lin. - have pa: 0 < `|x ^+ (m - i)| by rewrite normr_gt0 expf_eq0 x0 andbF. - rewrite normrV. - rewrite invr_le1 //; last by apply: unitf_gt0. - rewrite normrX; apply:exprn_ege1; exact (ltW cx1). - by apply: unitrX; rewrite unitfE x0. -rewrite - [\sum_(i < m.+1) `|E i / E m.+1| ] mul1r. -exact :(normr_sumprod1 (fun i => E i / E m.+1) ler01 pa). -Qed. - -Lemma CauchyBound : `| x | <= `|E n|^-1 * \sum_(i < n.+1) `|E i|. -Proof. -move: (CauchyBound2). rewrite big_distrr /=. -have -> //: \sum_(i < n.+1) `|E i / E n| = \sum_(i < n.+1) (`|E n|^-1 * `|E i|). -by apply: eq_bigr => i _ ; rewrite normrM normrV ? unitfE // mulrC. -Qed. - -End CauchyBound. - -(** ** Continuity *) - - -Section PolsOnOrderedField. - -Variable R : realFieldType. - -Definition norm_pol (p : {poly R}) := map_poly (fun x => `|x|) p. - -Lemma pow_monotone n (x y : R) : 0 <= x <= y -> 0 <= x ^+ n <= y ^+ n. -Proof. -move => /andP [xp xy]. -by rewrite lerXn2r// ?andbT ?exprn_ge0// nnegrE (le_trans _ xy). -Qed. - -Lemma diff_xn_ub n (z x y: R): -z <= x -> x <= y -> y <= z -> - `| y ^+ n - x ^+ n| <= (z^+(n.-1) *+ n) * (y - x). -Proof. -move => zx xy yz. -rewrite subrXX mulrC normrM [`|_ - _|]ger0_norm ?ler_wpM2r // ?subr_ge0 //. -apply: (le_trans (ler_norm_sum _ _ _)). -rewrite - [n in _*+ n] card_ord - sumr_const ler_sum // => [][i lin] _. -rewrite normrM !normrX. -have l1: 0<=`|x| <=z by rewrite normr_ge0 /= ler_norml zx /= (le_trans xy yz). -have l2: 0<=`|y| <=z by rewrite normr_ge0 /= ler_norml yz /= (le_trans zx xy). -have /andP [pa pb] := pow_monotone i l1. -have /andP [pc pd] := pow_monotone (n.-1 - i)%N l2. -by move: (ler_pM pc pa pd pb); rewrite - exprD subnK //; move: lin; case n. -Qed. - -Lemma pol_lip p (z x y: R): -z <= x -> x <= y -> y <= z -> - `|(p.[y] - p.[x])| <= (norm_pol p^`()).[z] * (y - x). -Proof. -move => zx xy yz. -rewrite horner_poly !horner_coef - sumrB. -apply: (@le_trans _ _ (\sum_(i: aux = ((\sum_(i ->; rewrite deriv0 size_poly0 !big_ord0. - move => s1; rewrite - (prednK s1) size_deriv big_ord_recl mulr0n mulr0 add0r. - apply: eq_bigr => i _; rewrite coef_deriv normrMn mulrnAl mulrnAr //. -rewrite big_distrl /= ler_sum // => i _;rewrite - mulrBr normrM -mulrA. -apply: (ler_wpM2l (normr_ge0 p`_i)); exact: (diff_xn_ub i zx xy yz). -Qed. - -Lemma pol_ucont (p : {poly R}) a b (c := (norm_pol p^`()).[(Num.max (- a) b)]) : - forall x y, a <= x -> x <= y -> y <= b -> `|p.[y] - p.[x]| <= c * (y - x). -Proof. -move => x y ax xy yb. -apply: pol_lip => //. -apply: (le_trans _ ax); by rewrite lerNl le_max lexx. -apply: (le_trans yb); by rewrite le_max lexx orbT. -Qed. - -Lemma pol_cont (p : {poly R}) (x eps :R): 0 < eps -> - { delta | 0 < delta & forall y, `|(y - x)| < delta -> - `|p.[y] - p.[x]| < eps }. -Proof. -move => ep. -move: (pol_ucont p (a:= x-1)(b:=x+1)); set c := _ .[_ ] => /= hc. -have pa: x-1 <= x by move: (lerD2l x (-1) 0); rewrite addr0 lerN10. -have pb: x <= x+1 by move: (lerD2l x 0 1); rewrite ler01 addr0. -have cp: 0<=c. - move: (hc _ _ pa pb (lexx (x+1))). - by rewrite addrAC addrN add0r mulr1; apply: le_trans; rewrite normr_ge0. -exists (Num.min 1 (eps /(c+1))). - rewrite lt_min ltr01 /= divr_gt0 // ? ep //. - by apply: (lt_le_trans ltr01); move: (lerD2r 1 0 c); rewrite add0r cp. -move => y. -rewrite lt_min; case /andP => xy1 xy2. -apply: (@le_lt_trans _ _ (c * `|(y - x)|)); last first. - move: cp; rewrite le0r; case /orP; first by move /eqP => ->; rewrite mul0r. - move => cp. - rewrite -(ltr_pM2l cp) in xy2; apply: (lt_le_trans xy2). - rewrite mulrCA ger_pMr //. - have c1: c <= c + 1 by move: (lerD2l c 0 1); rewrite ler01 addr0. - have c1p := (lt_le_trans cp c1). - by rewrite -(ler_pM2r c1p) mulfVK ? (gt_eqF c1p) // mul1r. -move: (ltW xy1); rewrite ler_distl;case /andP => le1 le2. -case /orP: (le_total x y) => xy. - move: (xy); rewrite - subr_ge0 => xy'. - move: (hc _ _ pa xy le2). - rewrite subr_ge0. - rewrite -subr_ge0 in xy'. - by rewrite (ger0_norm xy'). -move: (xy); rewrite - subr_ge0 => xy'. -move: (hc _ _ le1 xy pb); rewrite distrC (distrC y x). -rewrite subr_ge0. -rewrite -subr_ge0 in xy'. -by rewrite (ger0_norm xy'). -Qed. - -End PolsOnOrderedField. - -Section PolsOnArchiField. - -(** ** Constructive Intermediate value Theorem *) - -Variable R : archiFieldType. -(** We want to prove a simple and contructive approximation of the - middle value theorem: if a polynomial is negative in a and positive in b, - and a < b, then for any positive epsilon, there exists c and d, so that - a <= c < d <= b, the polynomial is negative in c and positive in d, - and the variation between c and d is less than epsilon. - Note: we also add: the distance between c and d is small. -*) - -Definition pol_next_approx (p : {poly R}) (ab : R * R) := - let: (a,b) := ab in let c :=half(a+b) in - if (p.[a] * p.[c] <= 0) then (a,c) else (c,b). - -Fixpoint pol_approx (p : {poly R}) (ab : R * R) (n:nat) := - if n is m.+1 then pol_next_approx p (pol_approx p ab m) else ab. - -Definition pair_in_interval (a x y b : R) := [&& a <= x, x < y & y <= b]. - -Lemma pol_approx_prop (p : {poly R}) (a b: R) n: - p.[a] < 0 -> 0 <= p.[b] -> a < b -> - let:(u,v) := (pol_approx p (a,b) n) in - [&& (v-u) == (b-a) / (2%:R ^+ n), pair_in_interval a u v b, - p.[u] < 0 & 0 <= p.[v] ]. -Proof. -move => pan pbp lab. -elim:n;first by rewrite /= expr0 divr1 eqxx /pair_in_interval pan pbp lab !lexx. -move => n /=; case (pol_approx p (a,b) n) => u v /and4P [/eqP d1 pi pun pvp]. -have aux: half ((b - a) / 2%:R ^+ n) == (b - a) / 2%:R ^+ n.+1. - by rewrite /half exprS -mulrA - invrM // ? unitrX ? two_unit. -rewrite /pol_next_approx /pair_in_interval;case /and3P: pi => [au uv vb]. -case cp:(p.[u] * p.[half (u + v)] <= 0). - case /andP: (mid_between uv) => [h1 h2]. - rewrite -{2}(double_half u) half_lin half_lin1 opprD. - rewrite addrA {1} (addrC u) addrK d1 aux pun - (nmulr_rle0 _ pun) cp. - by rewrite au h1 (ltW (lt_le_trans h2 vb)). -case /andP: (mid_between uv) => [h1 h2]. -rewrite -{1}(double_half v) half_lin half_lin1 opprD - addrA (addrA _ (-u)). -rewrite (addrC _ (-u)) addrK d1 aux pvp h2 vb (ltW (le_lt_trans au h1)). -by rewrite -(nmulr_rgt0 _ pun) ltNge cp. -Qed. - -Lemma constructive_ivt (p : {poly R}) (a b : R) (eps : R) : - a < b -> p.[a] < 0 -> 0 <= p.[b] -> 0 < eps -> - { xy | let:(u,v):= xy in - [&& pair_in_interval (- eps) (p.[u]) (p.[v]) eps, - (pair_in_interval a u v b), - (p.[u] < 0), (0 <= p.[v]) & (v - u) <= eps] }. -Proof. -move=> ab nla plb ep. -move: (pol_ucont p (a:=a) (b:= b)); set c1 := _ .[_ ] => /= pc. -set c := Num.max 1 c1. -have lc1: 1 <= c by rewrite le_max lexx. -have cpos:= (lt_le_trans ltr01 lc1). -set k := Num.bound ((b - a) * c / eps). -move: (upper_nthrootP(leqnn k)) => hh. -exists (pol_approx p (a, b) k); move: (pol_approx_prop k nla plb ab). -case:(pol_approx p (a, b) k) => u v /and4P [/eqP pa eq1 pun pvp]. -case/and3P: (eq1) => [ha hb hc]. -have c2p: 0 < v-u by rewrite subr_gt0. -have hh1: (v-u) * c < eps. - rewrite pa;set x := (X in _ / X). - have xp: 0 < x by rewrite exprn_gt0 // ltr0n. - rewrite mulrAC -(ltr_pM2r xp) (mulrVK (unitf_gt0 xp)). - move: hh. - rewrite -/x. - by rewrite ltr_pdivrMr// (mulrC _ x). -have hh2 : v-u < eps. - by apply: le_lt_trans hh1; rewrite - {1} (mulr1 (v-u)) (ler_pM2l c2p). -have dvp: p.[u] < p.[v] by apply (lt_le_trans pun pvp). -have hh5: p.[v] - p.[u] <= eps. - move: (pc _ _ ha (ltW hb) hc);rewrite gtr0_norm ? subr_gt0 // mulrC => hh4. - apply:(le_trans _ (ltW hh1)); apply: (le_trans hh4). - rewrite (ler_pM2l c2p) le_max lexx orbT //. -rewrite eq1 /pair_in_interval pun pvp dvp (ltW hh2) lerNl. -rewrite (le_trans _ hh5) ?(le_trans _ hh5) //. - by rewrite -{1} (addr0 p.[v]) lerD2l oppr_ge0 ltW. -by rewrite -{1} (add0r (- p.[u])) lerD2r. -Qed. - -Lemma constructive_ivt_bis (p : {poly R})(a b : R) (eps: R): - a < b -> p.[a] < 0 -> 0 <= p.[b] -> 0 < eps -> - { xy | - (- eps <= p.[xy.1]) && (p.[xy.1] < 0) && (0 <= p.[xy.2]) && - (p.[xy.2] <= eps) && (a <= xy.1) && (xy.1 < xy.2) && (xy.2 <= b) }. -Proof. -move=> ab nla plb ep. -move:(constructive_ivt ab nla plb ep) => [xy etc]. -exists xy. -set u := xy.1; set v := xy.2; move: etc. -have ->: xy = (u,v) by rewrite /u /v; case xy. -by case/and5P => [/and3P[-> _ ->] /and3P[-> -> ->] -> -> _]. -Qed. - -Lemma constructive_ivt_ter (p : {poly R})(a b : R) (eps: R): - a < b -> p.[a] < 0 -> 0 <= p.[b] -> 0 < eps -> - { xy | - (- eps <= p.[xy.1]) && (p.[xy.1] < 0) && (0 <= p.[xy.2]) && - (p.[xy.2] <= eps) && (a <= xy.1) && (xy.1 < xy.2) && (xy.2 <= b) }. -Proof. -move=> ab nla plb ep. -have ba' : 0 < b - a by rewrite -(addrN a) ltrD2r. -have evalba : 0 < p.[b] - p.[a] by rewrite subr_gt0; exact: lt_le_trans plb. -move: (pol_ucont p (a:=a) (b:= b)). -set c := _ .[_ ] => /= pc. -have cpos : 0 < c. - rewrite - (ltr_pM2r ba') mul0r. - by apply: lt_le_trans (pc a b _ _ _) => //; rewrite ? ger0_norm // ltW. -have pdiv : (0 < (b - a) * c / eps) by rewrite ltr_pdivlMr // mul0r mulr_gt0. -move: (archi_boundP (ltW pdiv)); set n := Num.bound _ => qn. -have fact1 : (0 : R) < n%:R by exact: lt_trans qn => /=. -case: n qn fact1 => [|n]; rewrite ?ltxx // => qn _. -pose sl := map (fun x => a + (b - a) * (x%:R / (n.+1%:R))) (iota 0 n.+2). -pose a'_index := find (fun x => p.[x] >= 0) sl. -have has_sl : has (fun x => p.[x] >= 0) sl. - rewrite has_map; apply/hasP; exists n.+1. - by rewrite mem_iota add0n ltnSn ltnW. - by rewrite /= divff ? pnatr_eq0 // mulr1 addrCA subrr addr0. -case: {2}a'_index (refl_equal a'_index) => [|ia']. - rewrite /a'_index => ha'; have:= (nth_find 1 has_sl); rewrite ha' /=. - by rewrite mul0r mulr0 addr0 leNgt nla. -set b':= sl`_ia'.+1; set a' := sl`_ia'. -move=> ha'; exists (a', b'); simpl. -have ia's : (ia' < size sl)%N by rewrite -ha' /a'_index find_size. -have ia'iota : (ia' < size (iota 0 n.+2))%N by move: ia's; rewrite size_map. -have:= (nth_find 0 has_sl); rewrite -/a'_index ha' => pb'p. -have:= (ltnSn ia'); rewrite -{2}ha'. -move/(@before_find _ 0 (fun x : R => 0 <= p.[x]) sl); move/negbT. -rewrite -ltNge => pa'n. -move:(ltW ba') => ba'w. -have aa' : a <= a'. - rewrite /a'/sl (nth_map 0%N) // lerDl mulr_ge0 //. - by rewrite mulr_ge0 // ?invr_ge0 ?ler0n. -have ia'_sharp : (ia' < n.+1)%N. - move: ia'iota; rewrite leq_eqVlt; rewrite size_iota; case/orP=> //. - move/eqP; case=> abs. - move: pa'n; rewrite abs (nth_map 0%N) ?size_iota // nth_iota //. - rewrite add0n divff ?mulr1 ?pnatr_eq0 // addrCA subrr addr0 => {} abs. - by move: plb; rewrite leNgt abs. -have b'b : b' <= b. - rewrite /b'/sl (nth_map 0%N) ?size_iota ?ltnS // nth_iota // add0n. - have e : b = a + (b - a) by rewrite addrCA subrr addr0. - rewrite {2}e {e} lerD2l //= -{2}(mulr1 (b -a)) ler_wpM2l //. - rewrite ler_pdivrMr ?ltr0Sn // mul1r -subr_gte0 /=. - have -> : (n.+1 = ia'.+1 + (n.+1 - ia'.+1))%N by rewrite subnKC. - by rewrite mulrnDr addrAC subrr add0r subSS ler0n. -have b'a'_sub : b' - a' = (b - a) / (n.+1)%:R. - have side : (ia' < n.+2)%N by apply: ltn_trans (ltnSn _). - rewrite /b' /a' /sl (nth_map 0%N) ?size_iota // nth_iota // add0n. - rewrite (nth_map 0%N) ?size_iota // nth_iota // add0n. - rewrite opprD addrAC addrA subrr add0r addrC -mulrBr. - by congr (_ * _); rewrite -mulrBl mulrSr addrAC subrr add0r div1r. -have a'b' : a' < b'. - move/eqP: b'a'_sub; rewrite subr_eq; move/eqP->; rewrite ltrDr. - by rewrite mulr_gt0 // invr_gt0 ltr0Sn. -rewrite pa'n a'b' b'b aa' pb'p. -have : `|p.[b'] - p.[a']| <= eps. - have := (pc sl`_ia' sl`_ia'.+1 aa' (ltW a'b') b'b). - rewrite b'a'_sub => hpc; apply: le_trans hpc _ => /=. - rewrite mulrA ler_pdivrMr ?ltr0Sn // mulrC [eps * _]mulrC. - rewrite -ler_pdivrMr //; apply: (ltW qn). -case/ler_normlP => h1 h2. -rewrite lerNl/= !andbT. -rewrite -[in X in X && _](lerD2l p.[b']) (le_trans h2) ? lerDr //. -by rewrite -(lerD2r (- p.[a'])) (le_trans h2) // lerDl oppr_gte0 ltW. -Qed. - -End PolsOnArchiField. diff --git a/theories/poly_normal.v b/theories/poly_normal.v deleted file mode 100644 index 92eb380..0000000 --- a/theories/poly_normal.v +++ /dev/null @@ -1,1832 +0,0 @@ -From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path choice fintype order. -From mathcomp Require Import prime div bigop ssralg poly polydiv polyorder ssrnum zmodp. -From mathcomp Require Import polyrcf qe_rcf_th complex. - -(******************************************************************************) -(* -This file consists of 3 sections: -- introduction of normal polynomials, some lemmas on normal polynomials -- constructions on sequences, such as all_neq0, all_pos, increasing, mid, seqmul, seqn0 -- proof of Proposition 2.44 of [bpr], normal_changes -*) -(******************************************************************************) - -Set Implicit Arguments. -Unset Strict Implicit. - -Import Order.TTheory GRing.Theory Num.Def Num.Theory. -Import Pdiv.Idomain. -Import ComplexField. - -Local Open Scope ring_scope. - -Section normal_sec_def. -Variable (R : numFieldType). - -Definition all_pos := fun (s : seq R) => all (fun x => 0 < x) s. - -Lemma all_posP (s : seq R) : - reflect (forall k, (k < size s)%N -> 0 < s`_k) (all_pos s). -Proof. exact/all_nthP. Qed. - -Fixpoint normal_seq (s : seq R) := - if s is a :: l1 then - if l1 is b :: l2 then - if l2 is c :: l3 then - (normal_seq l1) - && ((0 == a) || ((a * c <= b^+2) && (0 < a) && (0 < b))) - else (0 <= a) && (0 < b) - else 0 < a - else false. - -Definition normal := [qualify p : {poly R} | normal_seq p]. - -Lemma normalE p : p \is normal = normal_seq p. -Proof. by []. Qed. - -Lemma polyseq_deg1 (a b : R) : a != 0 -> (a *: 'X + b%:P) = [::b; a] :> seq R. -Proof. -move=> H. -by rewrite -mul_polyC -cons_poly_def polyseq_cons nil_poly polyC_eq0 polyseqC H. -Qed. - -Lemma polyseq_deg2 (a b c : R) : a != 0 -> - (a *: 'X^2 + b *: 'X + c%:P) = [:: c; b; a] :> seq R. -Proof. -move=> Ha. -rewrite -(mul_polyC a) -(mul_polyC b) expr2 mulrA -mulrDl. -by rewrite -cons_poly_def polyseq_cons mul_polyC polyseq_deg1. -Qed. - -Lemma normal_coef_geq0 (p : {poly R}) : p \is normal -> forall k, 0 <= p`_k. -Proof. -rewrite normalE; case: p=> s /= _. -case: s=> // a []=> [Ha | b l]. - by case=> [ | []] //; rewrite ltW. -elim: l a b=> [a b /andP [Ha Hb] | c l IHl a b]. - by case=> // [][]=> [ | []] //; rewrite ltW. -case/andP=> H1 /orP H2 [] /=. -rewrite le0r eq_sym. -case: H2=> [-> | /andP [/andP [_ ->]]] //. - by rewrite orbT. -exact: (IHl b c H1). -Qed. - -Lemma normal_lead_coef_gt0 (p : {poly R}) : p \is normal -> 0 < lead_coef p. -Proof. -rewrite normalE lead_coefE; case: p=> s /= _. -case: s=> // a [] => [Ha | b l] //. -elim: l a b=> [a b /andP [Ha Hb]| c l IHl a b ] //. -case/andP=> H1 /orP H2. -exact: (IHl b c H1). -Qed. - -End normal_sec_def. - -Section normal_polynomial. -Variable R : rcfType. - -Local Notation C := (complex R). - -Local Notation normal := (normal R). - -Lemma normal_squares (p : {poly R}) : - p \is normal -> (forall k, (1 <= k)%N -> p`_(k.-1) * p`_(k.+1) <= p`_k ^+2). -Proof. -rewrite normalE; case: p=> s /= _. -case: s=> // a [] => [Ha [] // n Hn | b l] //. - by rewrite mulr0; apply: sqr_ge0. -elim: l a b => [a b /andP [Ha Hb] | c l IHl a b]. - by case=> // [][] => [_ | n _]; rewrite mulr0; apply: sqr_ge0. -case/andP=> H1 /orP H2 [] // [] => [_ | n Hn]. - case: H2=> [/eqP <-|/andP [] /andP [] H2 _ _] //. - by rewrite mul0r; apply: sqr_ge0. -exact: (IHl b c H1 n.+1). -Qed. - -Lemma normal_some_coef_gt0 (p : {poly R}) : - p \is normal -> forall i, 0 < p`_i -> - forall j, (i < j)%N -> (j < (size p).-1)%N -> 0 < p`_j. -Proof. -rewrite normalE; case: p=> s /= _. -case: s=> // a []=> [Ha [] // | b l] //. -elim: l a b => [a b /andP [Ha Hb] | c l IHl a b]. - by case=> // [_ |] [] // => [_|] [] // => [_|n _][]. -case/andP =>H1 H2 [] (*i*) => [Ha | i Hi] [] (*j*)// => [|j Hj1 Hj2]. - rewrite (lt_eqF Ha) /= in H2. - have/andP [_ Hb] := H2. - case=> // j _ Hj; first exact: (IHl b c H1 0%N Hb j.+1). -exact: (IHl b c H1 i Hi). -Qed. - -Lemma prop_normal (p : {poly R}) : - [/\ (forall k, 0 <= p`_k), - (0 < lead_coef p), - (forall k, (1 <= k)%N -> p`_(k.-1) * p`_(k.+1) <= (p`_k) ^+2) & - (forall i, 0 < p`_i -> - forall j, (i < j)%N -> (j < (size p).-1)%N -> 0 < p`_j)] -> - p \is normal. -Proof. -case; rewrite normalE lead_coefE; case: p=> s /= _. -case: s => [ | a [] // b l]; first by rewrite ltxx. -elim: l a b=> [a b /(_ 0%N) /= -> -> //| c l IHl a b Hge0 Hlc H2 Hgt0]. -apply/andP; split. - apply: IHl=>[k||[] // k _|k Hk j Hj1 Hj2] //. - + exact: (Hge0 k.+1). - - exact: (H2 k.+2). - + exact: (Hgt0 k.+1 Hk j.+1). -have:= (Hge0 0%N); rewrite le_eqVlt /=. -case/orP=> [-> //| Ha]. -by rewrite (Hgt0 0%N Ha 1%N) // (H2 1%N) // Ha orbT. -Qed. - -Inductive normal_spec (p : {poly R}) := - Normal_spec (_ : forall k, 0 <= p`_k) (_ : 0 < lead_coef p) - (_ : forall k, (1 <= k)%N -> p`_(k.-1) * p`_(k.+1) <= (p`_k) ^+2) - (_ : forall i, 0 < p`_i -> - forall j, (i < j)%N -> (j < (size p).-1)%N -> 0 < p`_j). - -Lemma normalP (p : {poly R}) : reflect (normal_spec p) (p \is normal). -Proof. -apply/(iffP idP) => [H | [] *]. - split. - + exact: normal_coef_geq0. - - exact: normal_lead_coef_gt0. - + exact: normal_squares. - - exact: normal_some_coef_gt0. -exact: prop_normal. -Qed. - -(* Lemma 2.41 *) -Lemma monicXsubC_normal (a : R) : ('X - a%:P) \is normal = (a <= 0). -Proof. -rewrite normalE polyseqXsubC /=. -by case Ha: (a <= 0); rewrite oppr_ge0 Ha // ltr01. -Qed. - -Import complex. - -Definition inB (z : C) := (Re z <= 0) && (Im z ^+2 <= 3%:R * Re z ^+2). - -(* Lemma 2.42 *) - -Lemma quad_monic_normal (z : C) : - (('X^2 + (- 2%:R * Re z) *: 'X + (Re z ^+2 + Im z ^+2)%:P) \is normal) = - inB z. -Proof. -rewrite normalE -(mulr1 'X^2) mulrC mul_polyC polyseq_deg2 ?oner_neq0 //=. -rewrite /inB -(@nmulr_rge0 _ (- 2%:R)) -?oppr_gt0 ?opprK ?ltr0Sn // ltr01 andbT. -apply: andb_id2l => Hrez. -rewrite mulr1. -rewrite exprMn_comm; last first. - rewrite /GRing.comm. - by rewrite -mulNrn mulrC. -rewrite sqrrN. -rewrite -natrX. -rewrite (mulr_natl _ (2 ^ 2)). -rewrite [_ ^+2 *+ _]mulrS lerD2l -mulr_natl -andbA /=. -apply/idP/idP => [/orP [] | H]. - rewrite eq_sym paddr_eq0 ?sqr_ge0 //. - case/andP => /eqP -> /eqP ->. - by rewrite mulr0. - by case/andP. -rewrite le_eqVlt in Hrez. -case/orP : Hrez => [ | Hrez]. - rewrite eq_sym mulf_eq0 oppr_eq0 pnatr_eq0 orFb =>/eqP Hrez. - rewrite Hrez expr0n mulr0 exprn_even_le0 //= in H. - by rewrite Hrez (eqP H) expr0n add0r eqxx. -rewrite Hrez H ltr_pwDl ?orbT // ?lt_def sqr_ge0 // sqrf_eq0. -rewrite lt_def mulf_eq0 oppr_eq0 pnatr_eq0 orFb in Hrez. -by case/andP : Hrez => ->. -Qed. - -Lemma normal_neq0 (p : {poly R}) : p \is normal -> p != 0. -Proof. -move=> /normalP [_ H _ _]; rewrite -lead_coef_eq0. -by case: ltrgtP H. -Qed. - -Lemma normal_MX (p : {poly R}) : p \is normal -> p * 'X \is normal. -Proof. -move=> Hpnormal. -have Hpneq0 := (normal_neq0 Hpnormal). -case : p Hpneq0 Hpnormal => s Hs. -rewrite !normalE /= => Hp Hsnormal. -rewrite polyseqMX //=. -case : s Hs Hp Hsnormal => // a. -case => [Hs Hp Ha | b l]. - by apply/andP. -elim: l a b => [b c Hs Hp Hab | c l Hcl a b Hs Hp Habcl]; -apply/andP; split => //; -apply/orP; by left. -Qed. - -Lemma normal_MXn (p : {poly R}) (n : nat) : p \is normal -> p * 'X^n \is normal. -Proof. -move=> Hpnormal. -elim : n => [ | n Hn]. - by rewrite expr0 mulr1. -by rewrite exprSr mulrA normal_MX. -Qed. - -Lemma normal_MX_2 (p : {poly R}) : p * 'X \is normal -> p \is normal. -Proof. -move=> HpXnormal. -have HpXneq0 := normal_neq0 HpXnormal. -have Hpneq0 : p != 0 by rewrite -lead_coef_eq0 -lead_coefMX lead_coef_eq0. -(* one coef *) -case : p Hpneq0 HpXneq0 HpXnormal => s Hs. -rewrite !normalE /= => Hp HpX Hsnormal. -rewrite polyseqMX // in Hsnormal. -case : s Hs Hp HpX Hsnormal => [Hs Hp HpX H /= | a]. - by rewrite /= ltxx in H. -(* two coeffs *) -case => [Hs Hp HpX Ha /=| b l]. - by rewrite /= lexx /= in Ha. -(* at least 3 coeffs *) -elim: l a b => [b c Hs Hp HpX /andP Hab /= | c l Hcl a b Hs Hp HpX /andP Habcl]. - exact: proj1 Hab. -exact: proj1 Habcl. -Qed. - -Lemma normal_MXn_2 (p : {poly R}) (n : nat) : p * 'X^n \is normal -> p \is normal. -Proof. -elim : n => [| n Hn H]. - by rewrite expr0 mulr1. -rewrite exprSr mulrA in H. -by rewrite Hn // normal_MX_2. -Qed. - -Lemma normal_size_le1 (p : {poly R}) : p \is normal -> - (size p <= 1%N)%N = (size p == 1%N)%N. -Proof. -move=> Hpnormal. -rewrite eqn_leq. -apply/idP/idP => [Hpsize | /andP Hpsize]. - apply/andP; split => //. - by rewrite ltnNge leqn0 size_poly_eq0 normal_neq0. -exact: (proj1 Hpsize). -Qed. - -(* 0 is a root with multiplicity k iff the first k coefs are = 0 *) -Lemma normal_root0 (p : {poly R}) : - root p 0 -> forall k, (k < (\mu_0 p))%N -> p`_k = 0. -Proof. -move=> Hproot k Hkmu. -have H := root_mu p 0. -rewrite subr0 Pdiv.IdomainMonic.dvdp_eq in H. - by rewrite (eqP H) coefMXn Hkmu. -exact: monicXn. -Qed. - -(* for p normal : 0 is not a root iff all coefs are > 0 *) -Lemma normal_0notroot_b (p : {poly R}) : p \is normal -> - (~~(root p 0) = [forall k : 'I_((size p).-1), 0 < p`_k]). -Proof. -move=> Hpnormal. -have/normalP [H1 _ _ H4] := Hpnormal. -have Hp := (normal_neq0 Hpnormal). -apply/idP/idP. -(* => *) - move/rootPf=> H. - rewrite horner_coef0 in H. - have Hp0 : 0 < p`_0 by rewrite lt_def H (H1 0%N). - apply/forallP; case; case=> [ | n Hn] //. - by apply: (H4 0%N Hp0 n.+1 (ltn0Sn n) Hn). -(* <= *) -apply: contraL => /rootPt Hproot0. -rewrite negb_forall; apply/existsP. -have H0 : (0 < (size p).-1)%N. - rewrite -subn1 -(ltn_add2r 1) !addn1 subn1 prednK. - rewrite (root_size_gt1 (a:=0)) //. - rewrite (ltn_trans (n:= 1)) //. - rewrite (root_size_gt1 (a:=0)) //. -exists (Ordinal H0). -rewrite -leNgt le_eqVlt. -apply/orP; left. -by rewrite horner_coef0 in Hproot0. -Qed. - -(* useful version of the previous lemma *) -Lemma normal_0notroot (p : {poly R}) : p \is normal -> - ~~(root p 0) -> (forall k, (k < (size p).-1)%N -> 0 < p`_k). -Proof. -move=> Hpnormal H. -rewrite normal_0notroot_b // in H. -move/forallP : H => H k Hk. -apply: (H (Ordinal Hk)). -Qed. - -(* this is true because of previous lemma and lead_coef > 0 *) -Lemma normal_0notroot_2 (p : {poly R}) : p \is normal -> - ~~ root p 0 -> forall k, (k < (size p))%N -> 0 < p`_k. -Proof. -move=> Hpnormal H k Hk. -have/normalP [_ H2 _ _] := Hpnormal. -case Hk2 : (k < (size p).-1)%N. - by apply: normal_0notroot. -have Hk3 : (k == (size p).-1). - rewrite eqn_leq. - apply/andP; split. - rewrite -ltnS prednK // size_poly_gt0. - by apply: normal_neq0. - by rewrite leqNgt Hk2. -by rewrite (eqP Hk3) -lead_coefE. -Qed. - -(* product of 2 polynomials with coefs >0 has coefs >0 *) -Lemma prod_all_ge0 (p : {poly R}) (q : {poly R}) : - p != 0 -> q != 0 -> - (forall i, (i <= (size p).-1)%N -> 0 < p`_i) -> - (forall j, (j <= (size q).-1)%N -> 0 < q`_j) -> - forall k, (k <= (size (p * q)%R).-1)%N -> 0 < (p * q)`_k. -Proof. -wlog: p q / ((size p).-1 <= (size q).-1)%N => H Hp Hq Hpcoef Hqcoef k Hk. - case/orP : (leq_total (size p).-1 (size q).-1) => H2. - by apply: H. - rewrite mulrC; rewrite mulrC in Hk. - by apply: (H q p H2). -case : (leqP k (size p).-1) => Hk2. - rewrite coefM (bigD1 ord0) //= subn0 (lt_le_trans (y := (p`_0 * q`_k))) //. - rewrite pmulr_lgt0; first by rewrite Hpcoef. - by rewrite Hqcoef // (@leq_trans ((size p).-1)). - rewrite lerDl sumr_ge0 //. - case => /= i Hi Hi2. - rewrite pmulr_rge0. - case Hki : (k - i <= (size q).-1)%N. - by rewrite ltW // Hqcoef. - rewrite le0r -{1}(coefK q) coef_poly /=. - have Hki2 : ((k - i < (size q))%N = false). - by rewrite -[(size q)]prednK ?ltnS // size_poly_gt0. - by rewrite Hki2 eq_refl. - by rewrite Hpcoef // (leq_trans (n:=k)). -rewrite coefM. -have Hk3 : ((size p).-1 < k.+1)%N by apply: (ltn_trans (n:=k)). -rewrite (bigD1 (Ordinal Hk3)) //= - (lt_le_trans (y := (p`_(size p).-1 * q`_(k - (size p).-1)))) //. - have Hk4: (k - (size p).-1 <= (size q).-1)%N. - rewrite leq_subLR. - by rewrite size_mul // -[size p]prednK ?size_poly_gt0 // - -[size q]prednK ?size_poly_gt0 // addSn addnS -!pred_Sn in Hk. - rewrite pmulr_rgt0; first by rewrite Hqcoef. - by apply: Hpcoef. -rewrite lerDl sumr_ge0 //. -case => /= i Hi Hi2. -apply: mulr_ge0. - case Hi3 : (i <= (size p).-1)%N. - by rewrite ltW // Hpcoef. - rewrite le0r -{1}(coefK p) coef_poly /=. - rewrite ifF ?eqxx//. - by rewrite -[(size p)]prednK ?ltnS // size_poly_gt0. -case Hki : (k - i <= (size q).-1)%N. - by rewrite ltW // Hqcoef. -rewrite le0r -{1}(coefK q) coef_poly /=. -rewrite ifF ?eqxx//. -by rewrite -[(size q)]prednK ?ltnS // size_poly_gt0. -Qed. - -(* exchange two sums *) -Lemma xchange : forall (T : Type) (idx : T) (op : Monoid.com_law idx) - (m n : nat) (F : nat -> nat -> T), - \big[op/idx]_(m <= i < n) (\big[op/idx]_(m <= j < i.+1) F i j) = - \big[op/idx]_(m <= h < n) \big[op/idx]_(h <= j < n) (F j h). -Proof. -move=> T idx op m n F. -elim : n => [ | n Hn ]. - case : (leqP 0 m)=> Hm0 //. - by rewrite !big_geq. -case : (ltnP n m) => Hmn. - by rewrite !big_geq. -rewrite (big_cat_nat op (n:=n)) // big_nat1 Hn - [x in (op _ x = _)](big_cat_nat op (n:=n)) // big_nat1 - [x in (op _ _ = x)](big_cat_nat op (n:=n)) // big_nat1 big_nat1 - (Monoid.mulmA op). -congr (op _ _). -rewrite -[LHS]big_split big_nat [x in (_ = x)]big_nat. -apply: eq_bigr => i Hi. -rewrite [x in (_ = x)](big_cat_nat op (n:=n)) // ?big_nat1 // ltnW//. -by case/andP: Hi=> _ ->. -Qed. - -Lemma normal_coef_chain_1 (p : {poly R}) : ~~ root p 0 -> - p \is normal -> forall k, (0 < k)%N -> forall i, - p`_k.-1 * p`_(k.+1 +i) <= p`_(k + i) * p`_k . -Proof. -move=> Hp0notroot Hpnormal k Hk. -have/normalP [H1 _ H3 _] := Hpnormal. -elim => [ |i Hi ] //. - rewrite !addn0 -expr2 H3 //. -rewrite -subr_ge0. -case Hik : (k + i.+1 < size p)%N. - rewrite -(pmulr_lge0 (x:= p`_(k + i.+1))) //. - rewrite mulrDl mulNr subr_ge0. - apply: (le_trans (y:= p`_(k + i) * p`_k * p`_(k.+2 + i))). - rewrite -[x in (x <= _)]mulrA [x in (_ * x)]mulrC !mulrA -!addSnnS - -subr_ge0 -mulNr -mulrDl. - case H : (p`_(k.+2 + i) == 0). - by rewrite (eqP H) mulr0. - by rewrite pmulr_lge0 ?subr_ge0 // lt_def H H1. - have H := (H3 (k + i).+1 (ltn0Sn (k + i))). - rewrite !addnS !addSn [x in (x * _)]mulrC [x in (_ <= x * _)]mulrC - -subr_ge0 -!(mulrA p`_k) -mulrN -mulrDr mulrC pmulr_lge0. - by rewrite subr_ge0 -expr2 //. - apply: normal_0notroot => //. - apply: (leq_ltn_trans (n:=(k + i))). - by apply: leq_addr. - by rewrite -subn1 ltn_subRL addnC addn1 -addnS. - by apply normal_0notroot_2. -have Hik2 : (k + i.+2 < size p)%N = false. - apply: negbTE. - rewrite -leqNgt. - apply: (leq_trans (n := (k + i.+1))). - by rewrite leqNgt Hik. - by rewrite !addnS leqnSn. -by rewrite addSnnS -{4}(coefK p) coef_poly //= Hik2 mulr0 oppr0 - addr0 -{1}(coefK p) coef_poly Hik mul0r. -Qed. - -Lemma normal_coef_chain_2 (p : {poly R}) : ~~ root p 0 -> - p \is normal -> forall k, (0 < k)%N -> forall i, (k <= i)%N -> - p`_k.-1 * p`_(i.+1) <= p`_i * p`_k . -Proof. -move=> Hp0notroot Hpnormal k Hk i Hi. -have H := (normal_coef_chain_1 Hp0notroot Hpnormal Hk (i - k)). -by rewrite !addnBA // addnC (addnC k i) -addnBA // subSnn addn1 addnK in H. -Qed. - -(* Lemma 2.43, restricted version *) -Lemma normal_mulr_r (p q : {poly R}) : ~~ root p 0 -> ~~ root q 0 -> - p \is normal -> q \is normal -> (p * q) \is normal. -Proof. -move=> Hpzero Hqzero Hpnormal Hqnormal. -apply/normalP; split=> [k | |k Hk |i Hpqi j Hij Hj]. -(* first property *) - have/normalP [Hp _ _ _] := Hpnormal. - have/normalP [Hq _ _ _] := Hqnormal. - rewrite coefM sumr_ge0 // => [i _] /=. - by apply: mulr_ge0. -(* second property *) - have/normalP [_ Hp _ _] := Hpnormal. - have/normalP [_ Hq _ _] := Hqnormal. - by rewrite lead_coefM pmulr_lgt0. -(* third property *) - rewrite -subr_ge0 !coefM prednK // expr2 !big_distrlr /=. - (* separate first double sum in 3 parts *) - rewrite -(big_mkord (fun i : nat => true) - (fun i : nat => \sum_(j < k.+1) (p`_i * q`_(k - i) * (p`_j * q`_(k - j))))). - rewrite -(big_mkord (fun i : nat => true) - (fun i : nat => \sum_(j < k.+2) (p`_i * q`_(k.-1 - i) * - (p`_j * q`_(k.+1 - j))))). - rewrite (eq_bigr - (fun i => \sum_(0 <= j < k.+1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)))); - last by move => ? _ ; rewrite big_mkord. - rewrite [x in _ - x](eq_bigr - (fun i => \sum_(0 <= j < k.+2) p`_i * q`_(k.-1 - i) * - (p`_j * q`_(k.+1 - j)))); - last by move => ? _ ; rewrite big_mkord. - have H : \sum_(0 <= i < k.+1) - \sum_(0 <= j < k.+1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)) = - \sum_(2 <= h < k.+1) - \sum_(0 <= j < h.-1) p`_h * q`_(k - h) * (p`_j * q`_(k - j)) + - \sum_(1 <= h < k.+1) - p`_h * q`_(k - h) * (p`_(h.-1) * q`_(k - h.-1)) + - \sum_(0 <= h < k.+1) - \sum_(h <= j < k.+1) p`_h * q`_(k - h) * (p`_j * q`_(k - j)). - have H2: \sum_(0 <= i < k.+1) - \sum_(0 <= j < k.+1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)) = - \sum_(0 <= i < k.+1) - \sum_(0 <= j < i.-1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)) + - \sum_(0 <= i < k.+1) - \sum_(i.-1 <= j < i) p`_i * q`_(k - i) * (p`_j * q`_(k - j)) + - \sum_(0 <= i < k.+1) - \sum_(i <= j < k.+1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)). - rewrite -big_split -big_split. - rewrite big_nat [x in (_ = x)]big_nat; apply: eq_bigr => i Hi. - rewrite -big_cat_nat //. - rewrite -big_cat_nat //. - apply: ltnW; by move/andP : Hi; case=> _ ->. - by apply: leq_pred. - rewrite H2 {H2}. - congr (_ + _). - rewrite big_nat_recl// big_geq ?add0r; last by apply: leq_pred. - rewrite big_nat_recl// (big_geq (m:=0.-1) (n:=0)) // ?add0r. - have H2 : \sum_(0 <= i < k) \sum_(i.+1.-1 <= j < i.+1) - p`_i.+1 * q`_(k - i.+1) * (p`_j * q`_(k - j)) = - \sum_(1 <= h < k.+1) p`_h * q`_(k - h) * (p`_h.-1 * q`_(k - h.-1)). - rewrite big_add1 -pred_Sn big_nat [x in (_ = x)]big_nat. - apply: eq_bigr=> i Hi. - by rewrite -pred_Sn big_nat1. - rewrite H2 {H2}. - congr (_ + _). - by rewrite -{1}(prednK Hk) big_nat_recl// big_geq // add0r - big_add1 big_add1 -pred_Sn. - rewrite H {H}. - (* separate second double sum in 3 parts *) - have H : \sum_(0 <= i < k) - \sum_(0 <= j < k.+2) p`_i * q`_(k.-1 - i) * (p`_j * q`_(k.+1 - j)) = - \sum_(0 <= h < k) - \sum_(0 <= j < h.+1) p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j)) + - \sum_(1 <= i < k.+1) p`_(i.-1) * q`_(k - i) * (p`_i * q`_(k.+1 - i)) + - \sum_(0 <= h < k) - \sum_(h.+2 <= j < k.+2) p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j)). - rewrite big_add1 -pred_Sn -!big_split big_nat [x in (_ = x)]big_nat. - apply: eq_bigr => h Hh. - rewrite (big_cat_nat (n:= h.+1) GRing.add (fun j => true) - (fun j => p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j))) ) //. - rewrite (big_cat_nat (n:= h.+2) (m:=h.+1) GRing.add - (fun j => true) - (fun j => p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j))) ). - rewrite big_nat1 -pred_Sn /= -/(nth 0 _ (h.+1)) !addrA. - congr (_ + _); congr (_ + _). - by rewrite -(addn1 h) (addnC h 1%N) (subnDA 1 k h) subn1. - by rewrite (ltn_trans (n:=h.+1)) // ltnSn. - case/andP: Hh => Hh1 Hh2. - by rewrite (ltn_trans (n:=h.+2)) // ltnSn. - by apply: (ltn_trans (n:=k)). - (* canceling one of the three terms *) - rewrite H {H} - [x in ((x + _) - _)]addrC -[x in (_ - x)]addrA [x in (_ - (_ + x))]addrC - !opprD !addrA addrC -sumrN !addrA -big_split. - have H : \big[GRing.add/0]_(1 <= i < k.+1) - GRing.add - (- (p`_i.-1 * q`_(k - i) * (p`_i * q`_(k.+1 - i)))) - (p`_i * q`_(k - i) * (p`_i.-1 * q`_(k - i.-1))) = 0. - rewrite big_split sumrN /= addrC. - apply/eqP. rewrite subr_eq0. apply/eqP. - rewrite big_nat [x in (_ = x)]big_nat. - apply: eq_bigr => i Hi. - rewrite mulrC -[x in (x = _)]mulrA [x in (_ * x = _)]mulrC - [x in (_ * (x * _) = _)]mulrC !mulrA. - congr (_ * _). - rewrite -subn1 subnBA ?addn1 //. - by case/andP : Hi. - (* rotating sums around and splitting off bits of them *) - rewrite H {H} add0r big_add1 -pred_Sn. - rewrite (eq_big - (F1 := fun i => \sum_(0 <= j < i.+1.-1) p`_i.+1 * q`_(k - i.+1) - * (p`_j * q`_(k - j))) - (P1 := fun i => true) - (fun i => true) - (fun i => \sum_(1 <= l < i.+1) p`_i.+1 * q`_(k - i.+1) - * (p`_(l.-1) * q`_(k - (l.-1))))) // =>[ | i _]. - have H : \sum_(0 <= h < k) - \sum_(h.+2 <= j < k.+2) p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j)) = - \sum_(1 <= i < k.+1) - \sum_(i <= l < k.+1) p`_i.-1 * q`_(k - i) * (p`_l.+1 * q`_(k - l)). - rewrite big_add1 -pred_Sn. - apply: eq_big_nat => i Hi. - rewrite big_add1 -pred_Sn. - apply: eq_big_nat => l Hl. - by rewrite -pred_Sn subSS -(addn1 i) (addnC i 1%N) subnDA -subn1. - rewrite H {H} xchange big_nat_recl//. - have H : \sum_(0 <= i < k) - \sum_(i.+1 <= j < k.+1) p`_i.+1 * q`_(k - i.+1) * (p`_j * q`_(k - j)) = - \sum_(1 <= h < k.+1) - \sum_(h <= j < k.+1) p`_h * q`_(k - h) * (p`_j * q`_(k - j)). - by rewrite big_add1 -pred_Sn. - rewrite H {H} [x in (_ + (_ + _) - x - _)]xchange - -{12}(prednK Hk) [x in (_ + (_ + _) - x - _)]big_nat_recl//. - have H :(\big[GRing.add/0]_(0 <= i < k.-1) - \big[GRing.add/0]_(i.+1 <= j < k) - (p`_j * q`_(k.-1 - j) * (p`_i.+1 * q`_(k.+1 - i.+1))) = - \sum_(1 <= h < k) - \sum_(h <= j < k) p`_h * q`_(k.+1 - h) * (p`_j * q`_(k.-1 - j))). - rewrite big_add1 big_nat [x in (_ = x)]big_nat. - apply: eq_bigr => i Hi. - rewrite big_nat [x in (_ = x)]big_nat. - apply: eq_bigr => j Hj. - by rewrite mulrC. - rewrite H {H}. - have H : \sum_(1 <= i < k.+1) - \sum_(i <= l < k.+1) p`_i.-1 * q`_(k - i) * (p`_l.+1 * q`_(k - l)) = - \sum_(1 <= h < k) - \sum_(h <= j < k) p`_h.-1 * q`_(k - h) * (p`_j.+1 * q`_(k - j)) + - \sum_(1 <= i < k.+1) p`_i.-1 * q`_(k - i) * (p`_k.+1 * q`_0). - rewrite (big_cat_nat GRing.add (n:= k)) // - big_nat1 big_nat1 - [x in (_ = _ + x)](big_cat_nat GRing.add (n:= k)) // - big_nat1 (addnK k 0%N) Monoid.addmA. - congr (_ + _). - rewrite -big_split big_nat [x in (_ = x)]big_nat. - apply: eq_bigr => i Hi. - rewrite (big_cat_nat GRing.add (n:= k)) //. - rewrite big_nat1. - by rewrite (addnK k 0%N). - apply: ltnW. - by case/andP : Hi. - rewrite H {H}. - have H : \sum_(1 <= h < k.+1) - \sum_(h <= j < k.+1) p`_h * q`_(k - h) * (p`_j * q`_(k - j)) = - \sum_(1 <= h < k) - \sum_(h <= j < k) p`_h * q`_(k - h) * (p`_j * q`_(k - j)) + - \sum_(1 <= i < k.+1) p`_i * q`_(k - i) * (p`_k * q`_0). - rewrite (big_cat_nat GRing.add (n:= k)) // - big_nat1 big_nat1 - [x in (_ = _ + x)](big_cat_nat GRing.add (n:= k)) // - big_nat1 (addnK k 0%N) Monoid.addmA. - congr (_ + _). - rewrite -big_split big_nat [x in (_ = x)]big_nat. - apply: eq_bigr => i Hi. - rewrite (big_cat_nat GRing.add (n:= k)) //. - by rewrite big_nat1 (addnK k 0%N). - apply: ltnW. - by case/andP : Hi. - rewrite H {H} !opprD -!sumrN !addrA - -[x in (x + _)]addrA -big_split - -[x in ((((x + _) + _) + _) + _)]addrA - [x in (((((_ + x) + _) + _) + _) + _)]addrC - !addrA -big_split - -addrA [x in (_ + x)]addrC !addrA addrC !addrA -big_split. - have H : \big[GRing.add/0]_(1 <= i < k) - GRing.add - (GRing.add - (- - (\sum_(i <= j < k) p`_i * q`_(k.+1 - i) * (p`_j * q`_(k.-1 - j)))) - (- - (\sum_(i <= j < k) p`_i.-1 * q`_(k - i) * (p`_j.+1 * q`_(k - j))))) - (GRing.add - (\big[GRing.add/0]_(i <= j < k) - (p`_j.+1 * q`_(k - j.+1) * (p`_i.-1 * q`_(k - i.-1)))) - (\sum_(i <= j < k) p`_i * q`_(k - i) * (p`_j * q`_(k - j)))) = - \sum_(1 <= h < k) \sum_(h <= j < k) (p`_h * p`_j - p`_h.-1 * p`_j.+1) * - (q`_(k - h) * q`_(k - j) - q`_(k.+1 - h) * q`_(k.-1 - j)). - rewrite big_nat [x in (_ = x)]big_nat. - apply: eq_bigr => i Hi. - case/andP: Hi => Hi1 Hi2. - rewrite -!sumrN -!big_split big_nat [x in (_ = x)]big_nat. - apply: eq_bigr => j Hj. - case/andP: Hj => Hj1 Hj2. - rewrite /= -/(nth 0 _ j.+1) !addrA addrC. - by rewrite -mulrN -!mulrA !addrA -(mulrDr p`_i) - -mulrN !mulrA (mulrC _ p`_j) (mulrC _ p`_j) -!mulrA - -(mulrDr p`_j) mulrN mulrA - -[x in ((_ * _) + x + _ = _)]mulNr [x in (_ + (_ * x) + _ = _)]mulrA - [x in (_ + (_ * (x * _)) + _ = _)]mulrC !mulrA - [x in (_ + ((x * _) * _) + _ = _)]mulNr - -[x in (_ + _ + (x * _) = _)]mulrA - [x in (_ + _ + (_ * x * _) = _)]mulrC !mulrA - [x in (_ + _ + (x * _ * _) = _)]mulrC - -{2}(opprK (p`_i.-1 * p`_j.+1)) - -[x in (_ + _ + x = _)]mulrA - (mulNr (-(p`_i.-1 * p`_j.+1))) - -[x in (_ + _ + x = _)]mulrN -addrA - -[x in (_ + (x + _) = _)]mulrA - -(mulrDr (- (p`_i.-1 * p`_j.+1))) - [x in (_ + _ * (_ - x) = _)]mulrC - -{2}(subn1 i) subnBA // addn1 -{2}(addn1 j) (addnC j 1%N) - subnDA subn1 -mulrDl. - rewrite H {H} -!addrA. - apply: addr_ge0. - rewrite big_nat; apply: sumr_ge0 => i Hi. - rewrite big_nat; apply: sumr_ge0 => j Hj. - apply: mulr_ge0. - rewrite subr_ge0 [x in (_ <= x)]mulrC. - apply: (normal_coef_chain_2 Hpzero Hpnormal). - by case/andP : Hi. - by case/andP : Hj. - rewrite subr_ge0 [x in (x <= _)]mulrC -subn1 -subnDA addnC addn1 subnS - subSn; last by rewrite ltnW; case/andP : Hi. - apply: (normal_coef_chain_2 Hqzero Hqnormal). - rewrite subn_gt0. - by case/andP : Hj. - rewrite leq_sub //. - by case/andP : Hj. - rewrite addrA [x in (0 <= _ + x)]addrC -!addrA [x in (0 <= _ + x)]addrA - -big_split addrC -!addrA addr_ge0 //. - rewrite big_nat; apply: sumr_ge0 => i Hi. - rewrite /= -/(nth 0 _ (k.+1)) -/(nth 0 _ 0) - [x in (0 <= x * _ - _)]mulrC - [x in (0 <= _ - x * _)]mulrC -!mulrA -mulrBr. - apply: mulr_ge0. - by have/normalP [H _ _ _] := Hqnormal. - rewrite !mulrA -mulrBl. - apply: mulr_ge0. - rewrite subr_ge0 [x in (_ <= x)]mulrC - (normal_coef_chain_2 Hpzero Hpnormal) //. - by case/andP : Hi. - rewrite -ltnS; by case/andP : Hi. - by have/normalP [H _ _ _] := Hqnormal. - rewrite big_nat_recr// addrA -big_split addr_ge0 //. - rewrite big_nat; apply: sumr_ge0 => i Hi. - rewrite /= -/(nth 0 _ (k.+1)) -/(nth 0 _ (i.+1)) -/(nth 0 _ 0) - mulrC addrC -!mulrA -mulrBr mulr_ge0 //. - by have/normalP [H _ _ _] := Hpnormal. - rewrite mulrC mulrA [x in (0 <= x * _ - _)]mulrC -!mulrA -mulrBr - mulr_ge0 //. - by have/normalP [H _ _ _] := Hpnormal. - rewrite subn0 subr_ge0 -subn1 -subnDA addnC subnDA subn1. - apply: (normal_coef_chain_2 Hqzero Hqnormal). - rewrite subn_gt0; by case/andP : Hi. - by rewrite -{2}(subn0 k) leq_sub. - rewrite subn0 (addnK k 0%N). - have/normalP [Hp _ _ _] := Hpnormal. - have/normalP [Hq _ _ _] := Hqnormal. - by apply: mulr_ge0; apply: mulr_ge0; by rewrite ?Hp ?Hq. - rewrite big_add1 -pred_Sn. - apply: eq_bigr => j _. - by rewrite -pred_Sn. -(* fourth property *) -rewrite prod_all_ge0 // ?normal_neq0 // ?normal_neq0// => [k Hk| k Hk| ]. - rewrite normal_0notroot_2 //. - rewrite -ltnS prednK // in Hk. - by rewrite size_poly_gt0 normal_neq0. - rewrite normal_0notroot_2 //. - rewrite -ltnS prednK // in Hk. - by rewrite size_poly_gt0 normal_neq0. -by apply: ltnW. -Qed. - -(* Lemma 2.43 *) -Lemma normal_mulr : forall p q : {poly R}, - p \is normal -> q \is normal -> (p * q) \is normal. -Proof. -move=> p q Hpnormal Hqnormal. -have Hp0 := (root_mu p 0). -have Hq0 := (root_mu q 0). -rewrite Pdiv.Field.dvdp_eq in Hp0. -rewrite Pdiv.Field.dvdp_eq in Hq0. -have Hp0notroot1 : (~~(root (p %/ ('X - 0%:P) ^+ \mu_0 p) 0) ). - rewrite -mu_gt0 ?mu_div //. - by rewrite (addnK (\mu_0 p) 0%N) ltnn. - by rewrite dvdp_div_eq0 ?normal_neq0 // root_mu. -have Hq0notroot1 : (~~(root (q %/ ('X - 0%:P) ^+ \mu_0 q) 0) ). - rewrite -mu_gt0 ?mu_div //. - by rewrite (addnK (\mu_0 q) 0%N) ltnn. - by rewrite dvdp_div_eq0 ?normal_neq0 // root_mu. -rewrite (eqP Hp0) (eqP Hq0) [x in (x * _)]mulrC !mulrA - (mulrC _ (('X - 0%:P) ^+ \mu_0 q)) !mulrA -exprD - {1}oppr0 addr0 -mulrA mulrC normal_MXn //. -apply: normal_mulr_r => //. - rewrite (eqP Hp0) {2}oppr0 addr0 in Hpnormal. - by apply: (normal_MXn_2 (n:=\mu_0 p)). -rewrite (eqP Hq0) {2}oppr0 addr0 in Hqnormal. -by apply: (normal_MXn_2 (n:=\mu_0 q)). -Qed. - -(* begin move - move to complex.v ? *) - -Lemma normc_re_im : forall z : C, - (Normc.normc z) ^+2 = (Re z)^+2 + (Im z)^+2. -Proof. -case=> a b. -rewrite -[x in (_ = x)]sqr_sqrtr // addr_ge0 //; by apply: sqr_ge0. -Qed. - -Local Open Scope complex_scope. -Lemma normC_re_im : forall z : C, - (normr z) ^+2 = ((Re z)^+2 + (Im z)^+2)%:C. -Proof. -case=> a b. -rewrite sqr_normc /=. simpc. -by rewrite -!expr2 mulrC -(addr0 (- (b * a) + b * a)) -addrA (@addKr R _ 0). -Qed. - -Lemma re_conj (z : C) : - 2%:R * (Re z)%:C = z + z^*. -Proof. -by rewrite ReJ_add mulrC mulfVK // pnatr_eq0. -Qed. - -Lemma im_conj (z : C) : - z - z^* = 2%:R * (Im z)%:C * 'i. -Proof. -by rewrite ImJ_sub -!mulrA -expr2 sqr_i (mulrC _ (-1)) (mulrA _ (-1) _) - mulrN1 opprB mulrC mulfVK // pnatr_eq0. -Qed. -(* end move *) -Local Close Scope complex_scope. - -Local Notation toC := (fun (p : {poly R}) => - @map_poly R _ (real_complex R) p). - -Lemma real_complex_conjc : forall p : {poly R}, - map_poly ((@conjc R) \o (real_complex R)) p = - map_poly (real_complex R) p. -Proof. -elim/poly_ind => [ | p c H]. - by rewrite !rmorph0. -by rewrite !rmorphD !rmorphM /= H !map_polyC !map_polyX /= -conjc_real. -Qed. - -Lemma complex_root_conj_polyR (p : {poly R}) (z : C) : - root (toC p) z = root (toC p) z^*. -Proof. -by rewrite -complex_root_conj /= -map_poly_comp_id0 ?real_complex_conjc ?conjc0. -Qed. - -Local Open Scope complex_scope. -Lemma factor_complex_roots (z : C) : - toC ('X^2 + (1 *- 2 * Re z) *: 'X + (Re z ^+ 2 + Im z ^+ 2)%:P) = - ('X - z%:P) * ('X - (z^*)%:P). -Proof. -rewrite mulrBr !mulrBl opprB (addrC (z%:P * (z^*)%:P) _) addrA. -rewrite (mulrC _ (z^*)%:P) -[in RHS](addrA ('X * 'X) _) -expr2. -rewrite -(opprD (z%:P * 'X) ((z^*)%:P * 'X)). -rewrite -(mulrDl z%:P _ 'X) -(polyCD z z^*) -(polyCM z z^*) - -sqr_normc -re_conj normC_re_im mul_polyC - -(opprK (Re z ^+ 2 + Im z ^+ 2)%:P) map_poly_is_additive - -polyCN -mul_polyC map_polyC. -rewrite -(opprK ((1 *- 2 * Re z)%:P * 'X)) map_poly_is_additive map_polyXn - -(opprK (Re z ^+ 2 + Im z ^+ 2)%:C%:P) - -(polyCN (Re z ^+ 2 + Im z ^+ 2)%:C). -have H : (- (Re z ^+ 2 + Im z ^+ 2)%:C) = (- (Re z ^+ 2 + Im z ^+ 2))%:C. - by rewrite -!complexr0 -{2}oppr0. -rewrite H {H} -mulNr -(@polyCN _ (1 *- 2 * Re z)) mul_polyC map_polyZ - map_polyX mulNr opprK. -have H : 2%:R * (Re z)%:C = (2%:R * (Re z))%:C. - rewrite -!complexr0. - by simpc. -by rewrite H. -Qed. -Local Close Scope complex_scope. - -Lemma complex_root_div_poly_deg2 : forall (p : {poly R}) (z : C), - ((Im z) != 0) -> root (toC p) z -> - ('X^2 + (- 2%:R * (Re z)) *: 'X + ((Re z) ^+2 + (Im z)^+2)%:P) %| p. -Proof. -move=> p z Hz Hrootz. -have Hrootzbar : root (toC p) z^*. - by rewrite -complex_root_conj_polyR. -have /= Hp := (factor_complex_roots z). -rewrite -(dvdp_map (real_complex R)) /= Hp. -rewrite Gauss_dvdp. - apply/andP; split; by rewrite -root_factor_theorem. -apply: Pdiv.ClosedField.root_coprimep => x. -rewrite root_XsubC =>/eqP ->. clear x. -rewrite hornerXsubC im_conj eq_complex ReiNIm ImiRe /= !addr0 !mulr0 - subr0 add0r mul0r oppr0. -rewrite eqxx mulrI_eq0 ?negb_and. - apply/orP; by right. -apply/lregP. -by rewrite paddr_eq0 ?ler01 // negb_and oner_neq0. -Qed. - -Local Open Scope complex_scope. -Lemma real_root_div_poly_deg1 (p : {poly R}) (z : C) : - Im z = 0 -> root (toC p) z -> ('X - (Re z)%:P) %| p. -Proof. -move=>Himz Hroot. -rewrite root_factor_theorem (@complexE _ z) Himz mulr0 addr0 in Hroot. -rewrite -(dvdp_map (real_complex R)) /=. -have H : toC ('X - (Re z)%:P) = 'X - ((Re z)%:C)%:P. - by rewrite map_poly_is_additive map_polyC map_polyX. -by rewrite H. -Qed. -Local Close Scope complex_scope. - -(* Proposition 2.40 *) -Lemma normal_root_inB : forall (p : {poly R}), - p \is monic -> - (forall z : C, root (toC p) z -> inB z) -> p \is normal. -Proof. -move=> p Hpmonic. -move: {2}(size p) (leqnn (size p))=> n. -elim: n p Hpmonic=> [p Hpmonic Hpsize Hproot | n IH p Hpmonic Hpsize Hproots]. -(* size p <= 0 *) - rewrite size_poly_leq0 in Hpsize. - rewrite (eqP Hpsize) monicE lead_coef0 in Hpmonic. - by rewrite (eqP Hpsize) normalE polyseq0 /= -(oner_eq0 R) eq_sym. -(* size p <= n.+1 *) -case: (altP (size (toC p) =P 1%N)) => Hpsize2. - (* size p == 1 *) - rewrite monicE in Hpmonic. - rewrite /= size_map_poly_id0 in Hpsize2; - last by rewrite eq_sym negbT // lt_eqF // ltcR (eqP Hpmonic) ltr01. - have Hp := (size1_polyC (eq_leq (Hpsize2))). - rewrite Hp in Hpsize2. - rewrite Hp lead_coefE Hpsize2 -pred_Sn polyseqC in Hpmonic. - rewrite size_polyC in Hpsize2. - rewrite Hpsize2 /= in Hpmonic. - by rewrite Hp /= (eqP Hpmonic) normalE polyseqC oner_neq0 /= ltr01. -(* size p != 1 *) -move/closed_rootP : Hpsize2. -case=> x Hrootx. -case: (altP (Im x =P 0)) => Himx. -(* real root *) - have H := monicXsubC (Re x). - have Hp := real_root_div_poly_deg1 Himx Hrootx. - rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp. - rewrite (eqP Hp) normal_mulr //. - apply: IH => [ | | z Hz]. - + by rewrite monicE -(@lead_coef_Mmonic _ _ ('X - (Re x)%:P)) // - -(eqP Hp) -monicE. - - rewrite size_divp; last by apply: monic_neq0. - by rewrite size_XsubC leq_subLR addnC addn1. - + rewrite Hproots // (eqP Hp) rmorphM rootM. - apply/orP; by left. - rewrite monicXsubC_normal. - rewrite /inB in Hproots. - by have/andP := (Hproots x Hrootx); case => -> _. -(* pair of complex roots *) -have H : 'X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P \is monic. - by rewrite -(mul1r 'X^2) mul_polyC monicE lead_coefE polyseq_deg2 // oner_neq0. -have H2 : size ('X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P) = 3%N. - by rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 // oner_neq0. -have Hp := complex_root_div_poly_deg2 Himx Hrootx. -rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp. -rewrite (eqP Hp) normal_mulr //. - apply: IH => [ | | z Hz]. - + by rewrite monicE -(@lead_coef_Mmonic _ _ ('X^2 + (1 *- 2 * Re x) *: 'X + - (Re x ^+ 2 + Im x ^+ 2)%:P)) // -(eqP Hp) -monicE. - - rewrite size_divp; last by apply: monic_neq0. - by rewrite H2 leq_subLR addnC addn2 (@leq_trans n.+1). - + rewrite Hproots // (eqP Hp) rmorphM rootM. - apply/orP; by left. -by rewrite quad_monic_normal Hproots. -Qed. - -(* not sure if this lemma is really necessary *) -Lemma normal_red_0noroot : forall (p : {poly R}), p \is normal -> - root p 0 -> ~~(root (p %/ 'X^(\mu_0 p)) 0) && ((p %/ 'X^(\mu_0 p)) \is normal). -Proof. -move=> p Hpnormal Hproot0. -have Hpneq0 := (normal_neq0 Hpnormal). -apply/andP; split. -(* 0 is not root of p%/ 'X^(mu_0) *) - rewrite -(@addr0 _ 'X) -oppr0 -mu_gt0. - by rewrite -eqn0Ngt (@mu_div _ _ _ (\mu_0 p)) //= subnn. - rewrite divpN0. - by rewrite dvdp_leq // ?root_mu. - by rewrite -size_poly_gt0 size_exp_XsubC. -(* p %/ 'X^mu_0 is normal *) -have Hcoefs : forall k, ((p %/ 'X^(\mu_0 p))`_k = p`_(k + (\mu_0 p))). - have H := (root_mu p 0). - rewrite oppr0 addr0 Pdiv.IdomainMonic.dvdp_eq in H. - rewrite {3}(eqP H) => k {H}; rewrite coefMXn /=. - have H : ((k + \mu_0 p < \mu_0 p)%N = false). - by rewrite -{2}(add0n (\mu_0 p)) (@ltn_add2r). - by rewrite H addnK. - by apply: monicXn. -have Hsize : ((size (p %/ ('X^(\mu_0 p)))) = ((size p) - (\mu_0 p))%N). - rewrite size_divp. - by rewrite size_polyXn -pred_Sn. - by rewrite -size_poly_gt0 size_polyXn ltn0Sn. -have/normalP [Hp1 Hp2 Hp3 Hp4] := Hpnormal. -apply/normalP; split => [k | |k Hk |i ]. - + by rewrite Hcoefs Hp1. - + rewrite lead_coefE Hcoefs Hsize -subnS addnC addnBA. - by rewrite addnC subnS addnK Hp2. - by rewrite -(size_polyXn R (\mu_0 p)) dvdp_leq // -(addr0 'X) -oppr0 root_mu. - + by rewrite !Hcoefs (@addnC k.+1) addnS (@addnC k.-1) (@addnC k) -subn1 - addnBA // subn1 Hp3 // (ltn_trans Hk) // -{1}(add0n k) ltn_add2r mu_gt0. -rewrite Hcoefs => Hi j Hj1; rewrite Hsize => Hj2; -rewrite Hcoefs (@Hp4 (i + (\mu_0 p))%N) // ?ltn_add2r //. -by rewrite addnC -ltn_subRL -subn1 -subnDA addnC addn1 subnS. -Qed. - -End normal_polynomial. - -Arguments normal_seq {R}. -Arguments normal {R}. - -Section seqn0_and_properties. - -Variable R : ringType. - -(* sequence without 0's : filter (fun x => x != 0) s) *) -Definition seqn0 (s : seq R) := [seq x <- s | x != 0]. - -Lemma seqn0_as_mask (s : seq R) : - seqn0 s = mask (map (fun x => x != 0) s) s. -Proof. by rewrite /seqn0 filter_mask. Qed. - -Lemma seqn0_cons (s : seq R) (a : R) : (a != 0) -> - seqn0 (a :: s) = a :: (seqn0 s). -Proof. move=> Ha; by rewrite /= Ha. Qed. - -Lemma seqn0_size (s: seq R) : (s`_(size s).-1 != 0) -> - (0 < size (seqn0 s))%N. -Proof. -move=> Hs. -have Hssize : (0 < size s)%N. - case: s Hs => [ | ] //=. - by rewrite eqxx. -elim: s Hs Hssize => [|a] //=. -case=> [_ Ha _ | b l IHbl Hln Hablsize ] //=. - by rewrite Ha. -case Ha : (a != 0) => //. -by apply: IHbl. -Qed. - - -Definition all_neq0 := fun (s : seq R) => all (fun x => x != 0) s. - -Lemma all_neq0P (s : seq R) : - reflect (forall k, (k < size s)%N -> s`_k != 0) (all_neq0 s). -Proof. by apply/all_nthP. Qed. - -Lemma seqn0_all_neq0 (s : seq R) : all_neq0 (seqn0 s). -Proof. by apply: filter_all. Qed. - -Lemma seqn0_0 : forall (s : seq R), s`_0 != 0 -> (seqn0 s)`_0 = s`_0. -Proof. -case => [ | a l IHl] //. -by rewrite seqn0_as_mask /= IHl. -Qed. - -Lemma seqn0_n : forall (s : seq R), s`_(size s).-1 != 0 -> - (seqn0 s)`_(size (seqn0 s)).-1 = s`_(size s).-1. -Proof. -move=> s Hs. -have Hssize : (0 < size s)%N. - case: s Hs => //=. - by rewrite eqxx. -elim : s Hs Hssize => [| a] //. -case => [_ Ha _ | b l IHbl Hln Hablsize] //. - by rewrite /= Ha. -have H2 : (size [::a, b & l]).-1 = (size (b ::l)).-1.+1. - by rewrite prednK. -rewrite H2 /= -IHbl //. -case Ha : (a != 0) => //. -have H3 : ((size (a :: (if b != 0 then b :: seqn0 l else seqn0 l))).-1 - = (size (seqn0 (b :: l))).-1.+1). - by rewrite prednK // seqn0_size. -by rewrite H3. -Qed. - -End seqn0_and_properties. - -Section more_on_sequences. - -Variable R : rcfType. - -Lemma seqn0_size_2 (s : seq R) : - (s`_0 < 0) -> (0 < s`_(size s).-1) -> (1 < size (seqn0 s))%N. -Proof. -move=> Hs1 Hs2. -have Hssize : (0 < size s)%N. - case: s Hs1 Hs2 => [ | ] //=. - by rewrite ltxx. -case: s Hs1 Hs2 Hssize => [|a ] //. -case=> [Ha1 Ha2 _ | b l Ha Hln Hablsize] //. - have: false => //. - rewrite -(lt_asym 0 a). - by apply/andP. -rewrite seqn0_cons /=. - rewrite -(addn1 0) -(addn1 (size (seqn0 (b ::l)))) ltn_add2r seqn0_size //. - have H : (size [:: a, b & l]).-1 = (size (b :: l)).-1.+1. - by rewrite /=. - rewrite H lt_def in Hln. - by move/andP : Hln; case => -> _. -rewrite lt_def eq_sym in Ha. -by move/andP : Ha; case => ->. -Qed. - -Lemma normal_all_pos : forall (p : {poly R}), p \is normal -> - ~~(root p 0) -> all_pos p. -Proof. -move=> p Hpnormal H0noroot; apply/all_posP. -by apply: normal_0notroot_2. -Qed. - -Lemma all_pos_subseq : forall (s1 s2 : seq R), (all_pos s2) -> (subseq s1 s2) -> - (all_pos s1). -Proof. -move=> s1 s2 /allP Hs2 /mem_subseq Hsubseq; -by apply/allP=> y /Hsubseq /Hs2 Hy. -Qed. - -Definition increasing := fun (s : seq R) => - sorted (fun x y => x <= y) s. - -Lemma increasingP (s : seq R) : - reflect (forall k, (k < (size s).-1)%N -> s`_k <= s`_k.+1) - (increasing s). -Proof. -apply/(iffP idP) => [H k Hk | H]. - case: s H k Hk => [ | a ] // => l. - elim : l a => [ | b tl IHl a /andP Habtl] //. - case => [_ | n Hn] //=. - exact: (proj1 Habtl). - apply: (IHl b (proj2 Habtl)). - by rewrite -(ltn_add2r 1%N) !addn1 prednK. -case: s H => [ | a] => // => l. -elim : l a => [ | b l IHs a Hk] //. -apply/andP; split. - apply: (Hk 0%N) => //. -apply: (IHs b) => k Hkk. -by rewrite (Hk k.+1) // -(addn1 k) addnC -ltn_subRL subn1. -Qed. - -Lemma increasing_is_increasing3 : forall (s : seq R), (increasing s) -> - (forall k l, (k < (size s))%N -> - (l < (size s))%N -> (k <= l)%N -> s`_k <= s`_l). -Proof. -case=> [ | a ] // => l. -elim : l a => [a Hs k | b tl IHl a /andP Habtl k] [_ _ Hk | l] //. - + rewrite leqn0 in Hk; by rewrite (eqP Hk). - - rewrite leqn0 in Hk; by rewrite (eqP Hk). - + case : k => [Hk Hl Hkl| k Hk Hl Hkl]. - case : l Hl Hkl => [Hl Hkl |l Hl Hkl]. - exact: (proj1 Habtl). - apply: (@le_trans _ _ b). - exact: (proj1 Habtl). - apply: (IHl b (proj2 Habtl) 0%N l.+1) => //. - by apply: (IHl b (proj2 Habtl)). -Qed. - -Lemma subseq_incr (s1 s2 : seq R) : subseq s1 s2 -> - increasing s2 -> increasing s1. -Proof. -rewrite /increasing. -apply: subseq_sorted => //. -exact: le_trans. -Qed. - -Lemma changes_seq_incr_0 : forall (s : seq R), (0 < size s)%N -> - (increasing s) -> (all_neq0 s) -> - ((changes s == 0%N) = (0 < s`_0 * s`_((size s).-1))). -Proof. -elim => [ | a] //. -case => [_ _ _ /= Ha | b l IH Hsize Hincr Hneq0]. - by rewrite /= mulr0 addn0 -expr2 ltxx /= lt_def sqrf_eq0 sqr_ge0 Ha. -have/andP [] := Hneq0 => Ha Hblneq0. -have/andP [] := Hblneq0 => Hb Hlneq0. -have/andP [] := Hincr => Hab Hblincr. -rewrite /= addn_eq0 IH //=. -apply/idP/idP => [/andP [] H1 H2 | H]; case : (ltrgtP a 0) => Ha2. -+ by rewrite nmulr_lgt0 // -(@nmulr_rgt0 _ b) // lt_def eq_sym Hb /= - -(@nmulr_rge0 _ a) // leNgt -eqb0. -- by rewrite pmulr_lgt0 // -(@pmulr_rgt0 _ b) // lt_def Hb /= - -(@pmulr_rge0 _ a) // leNgt -eqb0. -+ by have/eqP := Ha. -- have Hbl : ((b :: l)`_(size l) < 0). - by rewrite -(nmulr_rgt0 _ Ha2). - rewrite eqb0 -leNgt nmulr_rge0 // nmulr_lgt0 //. - rewrite le_eqVlt (negbTE Hb) /= andbb (le_lt_trans _ Hbl) //. - by apply: (@increasing_is_increasing3 _ Hincr 1%N (size [::a, b & l]).-1). -- have Hbl : (0 < (b :: l)`_(size l)). - by rewrite -(pmulr_rgt0 _ Ha2). - rewrite eqb0 -leNgt pmulr_rge0 // pmulr_lgt0 //. - by rewrite le_eqVlt eq_sym (negbTE Hb) /= andbb (lt_le_trans Ha2 Hab). -+ by have/eqP := Ha. -Qed. - -Lemma changes_seq_incr_1 : forall (s : seq R), (1%N < size s)%N -> - (increasing s) -> (all_neq0 s) -> - ((changes s) == 1%N) = (s`_0 < 0) && (0 < s`_((size s).-1)). -Proof. -elim=> [ |a ] //. -case=> [_ _ _ _ | b] //. -case=> [_ _ /andP [] Hab _ /and3P [] Ha Hb _ |c l IH Hsize Hincr Hneq0] //=. - rewrite mulr0 addn0 ltxx /= addn0 eqb1. - case: (ltrP a 0) => Ha2 /=; first by rewrite nmulr_rlt0. - by rewrite ltNge mulr_ge0 // (le_trans Ha2). -have/andP [] := Hneq0 => Ha Hbclneq0. -have/andP [] := Hbclneq0 => Hb Hclneq0. -have/andP [] := Hclneq0 => Hc Hlneq0. -have/andP [] := Hincr => Hab Hbclincr. -have/andP [] := Hbclincr => Hbc Hclincr. -apply/idP/idP; case : (ltrP (a * b) 0) => Hab2 /=. -+case : (ltrgtP a 0) => Ha2 H /=. - have Hb2 : (0 < b). - rewrite -(nmulr_rlt0 _ Ha2) //. - rewrite (lt_le_trans Hb2) //. - by apply: (@increasing_is_increasing3 _ Hincr 1%N (size [::a, b, c & l]).-1). - rewrite -(lt_asym 0 b); apply/andP; split. - by rewrite (lt_le_trans _ Hab). - by rewrite -(pmulr_rlt0 _ Ha2). - by have/eqP := Ha. --rewrite add0n IH //. - case/andP => /= Hb2 Hbl; apply/andP; split => //. - by rewrite (le_lt_trans _ Hb2). -+case/andP => H1 H2. - rewrite addnC addn1. - apply/eqP; apply: eq_S; apply/eqP. - by rewrite (changes_seq_incr_0 (s:=[::b, c & l])) //= pmulr_rgt0 // - -(nmulr_rlt0 _ H1). --case/andP => H1 H2. - rewrite add0n IH //. - apply/andP; split => //=. - rewrite -(nmulr_rgt0 _ H1) lt_def. - apply/andP; split => //. - by apply: mulf_neq0. -Qed. - -Lemma changes_seq_incr : forall (s : seq R), (increasing s) -> (all_neq0 s) -> - (changes s == 1%N) || (changes s == 0%N). -Proof. -case=> [ |a ] //. -case => [_ Ha |b l Hincr Hneq0] //. - apply/orP; right. - rewrite changes_seq_incr_0 //= -expr2 lt_def. - move/andP : Ha; case => Ha _. - by rewrite sqrf_eq0 Ha /= sqr_ge0. -have/andP [] := Hneq0 => Ha Hblneq0. -have/andP [] := Hincr => Hab Hblincr. -have Hlast := ((all_neq0P [::a, b & l] Hneq0) ((size [::a, b & l]).-1) (leqnn _)). -case : (ltrgtP 0 (a * ([::a, b & l]`_(size [::a, b & l]).-1))) => H. -+apply/orP; right. - by rewrite changes_seq_incr_0. --apply/orP; left. - rewrite changes_seq_incr_1 //=. - have H2 := (@increasing_is_increasing3 _ Hincr 0%N (size [:: a, b & l]).-1). - case: (ltrgtP a 0) => Ha2 /=. - by rewrite -(nmulr_rlt0 _ Ha2). - rewrite -(lt_asym 0 [:: a, b & l]`_(size [::a, b & l]).-1). - apply/andP; split. - by rewrite (lt_le_trans Ha2) // H2. - by rewrite -(pmulr_rlt0 _ Ha2). - by have/eqP := Ha. -+move/eqP : H; rewrite eq_sym => /eqP H. - by have/eqP := (mulf_neq0 Ha Hlast). -Qed. - -Lemma changes_size3 : forall (s : seq R), (all_neq0 s) -> (size s = 3)%N -> - (s`_0 < 0) -> (0 < s`_2) -> changes s = 1%N. -Proof. -case => [ | a [| b [| c]]] //. -case => [Hallneq Hsize Ha Hc | ] //=. -rewrite mulr0 ltxx !addn0. -case : (ltrP (a * b) 0) => Hab. - rewrite addnC addn1; apply: eq_S. - apply/eqP. - by rewrite eqb0 -leNgt pmulr_lge0 // -(@nmulr_lle0 _ a b) // ltW // mulrC. -apply/eqP. -rewrite add0n eqb1 pmulr_llt0 // -(@nmulr_rgt0 _ a) // lt_def Hab andbT. -move/and3P : Hallneq => [] Ha2 Hb2 Hc2. -by rewrite mulf_neq0. -Qed. - -(* sequence without first and last element *) -Definition mid := fun (s : seq R) => (drop 1 (take (size s).-1 s)). - -Lemma mid_2 : forall (s : seq R), mid s = (take (size s).-2 (drop 1 s)). -Proof. -elim=> [ |a l IHl ] //=. -case: l IHl => [ |b l IHbl ] //. -rewrite drop0 /mid. -have Hsize : ((size [::a, b & l]).-1 = (size (b :: l)).-1.+1). - by rewrite prednK. -by rewrite Hsize /= drop0. -Qed. - -Lemma mid_size : forall (s : seq R), size (mid s) = (size s).-2. -Proof. -elim => [|a l IHl] => //=. -by rewrite /mid size_drop size_takel //= subn1. -Qed. - -Lemma mid_nil : forall (s : seq R), (mid s == [::]) = - ((s == [:: s`_0 ; s`_1]) || (s == [:: s`_0]) || (s == [::])). -Proof. -case=> [| a [| b]] //=. - by rewrite /mid /= orbF !eqxx orbT. -case=> [ |c l] //=. - by rewrite /mid /= orbF !eqxx orTb. -by rewrite /mid /= orbF -eqseqE /= !andbF orbF. -Qed. - -Lemma mid_cons (s : seq R) (a : R) : - mid (a :: s) = take (size s).-1 s. -Proof. by rewrite mid_2 /= drop0. Qed. - -Lemma mid_coef_1 (s : seq R) k : (k < size (mid s))%N -> - (mid s)`_k = s`_k.+1. -Proof. -move=> Hk. -rewrite /mid nth_drop addnC addn1 nth_take //. -by rewrite -(@addn1 k) addnC -ltn_subRL subn1 -mid_size. -Qed. - -Lemma mid_coef_2 (s : seq R) k: (0%N < k)%N -> (k < (size s).-1)%N -> - (mid s)`_k.-1 = s`_k. -Proof. -move=> Hk1 Hk2. -by rewrite mid_coef_1 prednK // mid_size -(@prednK k) // -(@ltn_add2r 1%N) - !addn1 !prednK // (@ltn_trans k). -Qed. - -Lemma drop1_seqn0_C : forall (s : seq R), (s`_0 != 0) -> - drop 1 (seqn0 s) = seqn0 (drop 1 s). -Proof. -case=> [ | a l Ha] //=. -by rewrite Ha /= !drop0. -Qed. - -Lemma take1_seqn0_C : forall (s : seq R), (s`_(size s).-1 != 0) -> - take (size (seqn0 s)).-1 (seqn0 s) = seqn0 (take (size s).-1 s). -Proof. -elim=> [ | a] //. -case=> [_ Ha | b l IHbl Hln] //. - by rewrite /= Ha. -have H : (size [::a, b & l]).-1 = (size (b :: l)).-1.+1. - by rewrite prednK. -rewrite H take_cons. -case Ha : (a != 0). - rewrite /= Ha -IHbl => //. - have H2 : (size (a :: (if b != 0 then b :: seqn0 l else seqn0 l))).-1 = - (size (seqn0 (b ::l))).-1.+1. - rewrite prednK // (@seqn0_size _ (b :: l)) //. - by rewrite H2 take_cons. -by rewrite /= Ha -IHbl. -Qed. - -Lemma mid_seqn0_C : forall (s : seq R), (s`_0 != 0) -> (s`_(size s).-1 != 0) -> - mid (seqn0 s) = seqn0 (mid s). -Proof. -elim => [ |a] //. -case => [_ Ha _ |b l Hbl Ha Hln] //=. - by rewrite Ha /mid /=. -rewrite Ha /mid -drop1_seqn0_C // -take1_seqn0_C //. -have H : ((size (a :: (if b != 0 then b :: seqn0 l else seqn0 l))).-1 = - (size (seqn0 (b :: l))).-1.+1). - by rewrite prednK // seqn0_size. -by rewrite H take_cons /= drop0 Ha H take_cons /= drop0. -Qed. - -Lemma changes_take : forall (s : seq R) (a b : R), (s != [::]) -> - (all_neq0 [::a, b & s]) -> - (changes (take (size (b :: s)) ([::a, b & s])) = - ((a * b < 0)%R + changes (take (size s) (b :: s)))%N). -Proof. by case. Qed. - -Lemma changes_decomp_sizegt2 : forall (s : seq R), (all_neq0 s) -> - (2 < size s)%N -> - changes s = - ((s`_0 * s`_1 < 0)%R + - (changes (mid s))%R + - (s`_((size s).-2) * s`_((size s).-1) < 0)%R)%N. -Proof. -case=> [|a [| b l]] //. -elim: l a b => [ |c l] //. -case: l c => [c _ a b Habcneq0 _| d l c IHdl a b /andP [] Ha Hneq0 Hsize ]. - by rewrite /= !mulr0 !ltxx !addn0. -have H1 : (changes [:: a, b, c, d & l] = ((a * b < 0)%R + - changes [:: b, c, d & l])%N). - by done. -rewrite H1 (IHdl b c) // -addnA -addnA addnC (@addnC (a * b < 0)%R). -apply/eqP. -rewrite eqn_add2r addnA eqn_add2r (@mid_cons _ a). -have H2 : (size [:: b, c, d & l]).-1 = size [::c, d & l]. - by done. -by rewrite H2 (@changes_take _ b c). -Qed. - -Lemma changes_decomp_size2 : forall (s : seq R), (all_neq0 s) -> - (size s == 2)%N -> - changes s = (s`_0 * s`_1 < 0)%R. -Proof. -case => [ |a [| b [_ _ |]]] //. -by rewrite /= mulr0 ltxx !addn0. -Qed. - -(* pointwise multiplication of two lists *) -Definition seqmul := - (fun s1 s2 : seq R => map (fun x : R * R => x.1 * x.2) (zip s1 s2)). - -Lemma seqmul_size (s1 s2 : seq R) : - size (seqmul s1 s2) = minn (size s1) (size s2). -Proof. -by rewrite /seqmul size_map size_zip. -Qed. - -Lemma seqmul_coef (s1 s2 : seq R) k : (k < minn (size s1) (size s2))%N -> - (seqmul s1 s2)`_k = s1`_k * s2`_k. -Proof. -move=> Hk. -rewrite (nth_map 0); last by rewrite size_zip. -by rewrite nth_zip_cond size_zip Hk /=. -Qed. - -Lemma zip_nil_1 : forall (s : seq R), - zip (@nil R) s = [::]. -Proof. by case. Qed. - -Lemma zip_nil_2 : forall (s : seq R), - zip s (@nil R) = [::]. -Proof. by case. Qed. - -Lemma mask_zip : forall (b : bitseq) (s1 s2 : seq R), - mask b (zip s1 s2) = zip (mask b s1) (mask b s2). -Proof. -elim => [ | a l IHl] //. -case => [s2 |x s1 ] //. - by rewrite /= !zip_nil_1. -case=> [ |y s2 /=] //. - by rewrite zip_nil_2 !mask0 zip_nil_2. -case Ha : a => //. -by rewrite IHl. -Qed. - -Lemma mask_seqmul (b : bitseq) (s1 s2 : seq R) : - mask b (seqmul s1 s2) = seqmul (mask b s1) (mask b s2). -Proof. by rewrite -map_mask mask_zip. Qed. - -Lemma seqmul0 (s : seq R) : seqmul [::] s = [::]. -Proof. by rewrite /seqmul zip_nil_1. Qed. - -Lemma seqmul_cons (s1 s2 : seq R) (a b : R) : - seqmul (a::s1) (b::s2) = (a * b) :: (seqmul s1 s2). -Proof. by rewrite /seqmul. Qed. - -Lemma changes_mult : forall (s c : seq R), all_pos c -> (size s = size c) -> - changes (seqmul s c) = changes s. -Proof. -elim=> [c Hc Hsize |a1 s IHs]. - by rewrite seqmul0. -case=> [ |b1 l Hblpos Hsize] //. -rewrite seqmul_cons /=. -case: s IHs Hsize => [IH Hsize|a2 s IHa2s Hsize]. - by rewrite seqmul0 /= !addn0 !mulr0. -case : l Hblpos Hsize => [ | b2 l /andP [] Hb1 Hb2lpos Hsize] //. -have/andP [Hb2 Hlpos] := Hb2lpos. -rewrite !seqmul_cons -(@IHa2s (b2::l)) //. - by rewrite seqmul_cons -(@pmulr_llt0 _ b1 (a1 * head 0 (a2 :: s ))) // - -(@mulrA _ a1 _ b1) (@mulrC _ (head 0 (a2::s)) b1) (@mulrA _ a1 b1 _) - -(@pmulr_llt0 _ b2 (a1 * b1 * head 0 (a2 :: s ))) // - -!mulrA (@mulrC _ _ b2). -by apply: eq_add_S. -Qed. - -Lemma map_seqmul : forall (s c : seq R), all_pos c -> (size s = size c) -> - map (fun x => x != 0) (seqmul s c) = map (fun x => x != 0) s. -Proof. -elim=> [c Hc Hsize |a s IHs]. - by rewrite seqmul0. -case=> [ | b l Hblpos Hsize] //. -have/andP [Hb Hlpos] := Hblpos. -rewrite seqmul_cons !map_cons mulIr_eq0. - rewrite IHs //. - by apply: eq_add_S. -apply/rregP. -rewrite lt0r in Hb. -by case/andP : Hb. -Qed. - -End more_on_sequences. - -Arguments all_pos {R}. -Arguments mid {R}. -Arguments seqn0 {R}. -Arguments all_neq0 {R}. -Arguments increasing {R}. - -(*****************************) - -Section Proof_Prop_2_44. - -Variables (R : rcfType) (a : R) (p : {poly R}). - -Variables (Ha : 0 < a) (Hpnormal : p \is normal) (Hp0noroot : ~~(root p 0)). - -Local Notation q := (p * ('X - a%:P)). - -Local Notation d := (size q). - -Lemma q_0 : q`_0 = -a * p`_0. -Proof. -rewrite mulrDr coefD -polyCN (mulrC p ((-a)%:P)) mul_polyC coefZ polyseqMX. - by rewrite add0r. -by apply: normal_neq0. -Qed. - -Lemma q_0_lt0 : q`_0 < 0. -Proof. -rewrite q_0 // mulNr oppr_lt0 pmulr_rgt0 //. -case : (ltnP 1%N (size p)) => Hpsize. - apply: (@normal_0notroot _ _ Hpnormal Hp0noroot). - rewrite -(ltn_add2r 1) !addn1 prednK ?Hpsize //. - by apply: (@ltn_trans 1%N). -rewrite normal_size_le1 // in Hpsize. -rewrite (pred_Sn 0) -(eqP Hpsize) -lead_coefE. -by have/normalP [_ H _ _] := Hpnormal. -Qed. - -Lemma q_0_neq0 : q`_0 != 0. -Proof. -by rewrite negbT // lt_eqF // q_0_lt0. -Qed. - -Lemma q_size : d = (size p).+1 . -Proof. -have Hpneq0 := (normal_neq0 Hpnormal). -rewrite mulrDr size_addl. - by rewrite size_mulX. -rewrite mulrC -polyCN mul_polyC size_mulX //. -by rewrite (@leq_ltn_trans (size p)) // size_scale_leq. -Qed. - -Lemma p_size : size p = d.-1. -Proof. -by rewrite (@pred_Sn (size p)) q_size. -Qed. - -Lemma q_n : q`_d.-1 = p`_(d.-2). -Proof. -rewrite -p_size mulrDr coefD -polyCN (mulrC p ((-a)%:P)) mul_polyC coefZ. -rewrite coefMX. -have H : (((size p) == 0%N) = false). - rewrite size_poly_eq0. - apply/eqP/eqP. - by apply: normal_neq0. -by rewrite H /= {H} -{3}(coefK p) coef_poly ltnn mulr0 addr0. -Qed. - -Lemma q_n_gt0 : (0 < q`_d.-1). -Proof. -rewrite q_n -p_size // -lead_coefE. -by have/normalP [_ H _ _] := Hpnormal. -Qed. - -Lemma q_n_neq0 : q`_d.-1 != 0. -Proof. -by rewrite negbT // gt_eqF // q_n_gt0. -Qed. - -Lemma q_k k : (0%N < k)%N -> (k < d.-1)%N -> - q`_k = (p`_k.-1/p`_k - a) * p`_k. -Proof. -move=> Hk1 Hk2. -rewrite mulrDr coefD -polyCN (mulrC p ((-a)%:P)) mul_polyC coefZ coefMX. -have H : ((k==0%N) = false). - apply/eqP/eqP. - by rewrite -lt0n. -by rewrite H /= mulrDl divrK // unitf_gt0 // normal_0notroot_2 // p_size. -Qed. - -Lemma seqn0q_size : (1 < size (seqn0 q))%N. -Proof. -by rewrite seqn0_size_2 // ?q_0_lt0 // ?q_n_gt0. -Qed. - -Definition spseq := map (fun x : R * R => x.1 / x.2 - a) (zip p (drop 1 p)). - -Lemma spseq_size : size spseq = d.-2. -Proof. -by rewrite /spseq size_map size_zip size_drop subn1 -p_size minnE subKn - // leq_pred. -Qed. - -Lemma spseq_coef k : (k < d.-2)%N -> spseq`_k = p`_k / p`_k.+1 - a. -Proof. -move=> Hk. -have H : minn (size p) ((size p) - 1%N) = ((size p) - 1%N)%N. - rewrite minnE subKn // subn1 -{2}(@prednK (size p)). - by rewrite leqnSn. - by rewrite ltnNge leqn0 size_poly_eq0 normal_neq0. -rewrite /spseq (@nth_map _ 0). - rewrite nth_zip_cond /= size_zip !size_drop H subn1 p_size Hk /=. - by rewrite !nth_drop (addnC 1%N) addn1. -by rewrite size_zip !size_drop H subn1 p_size. -Qed. - -Lemma spseq_increasing : increasing spseq. -Proof. -have/normalP [_ _ H3 _] := Hpnormal. -apply/increasingP => k Hk. -rewrite spseq_size in Hk. -rewrite (@spseq_coef k) //. - rewrite (@spseq_coef k.+1) //. - rewrite lerB // ler_pdivrMr. - rewrite mulrC mulrA ler_pdivlMr. - by rewrite -expr2 (H3 k.+1). - rewrite (normal_0notroot_2 Hpnormal Hp0noroot) //. - by rewrite -(@addn2 k) addnC -ltn_subRL p_size subn2. - rewrite (normal_0notroot Hpnormal Hp0noroot) //. - by rewrite -(@addn1 k) addnC -ltn_subRL p_size -subn2 - -subnDA addnC subnDA subn2 subn1. - by rewrite -(@addn1 k) addnC -ltn_subRL -subn2 - -subnDA addnC subnDA subn2 subn1. -by rewrite (leq_trans Hk) // -(@subn2 (size q)) -subn1 leq_subLR addnC addn1. -Qed. - -(* the middle coefficients of q as a product *) -Lemma seqmul_spseq_dropp : mid q = seqmul spseq (drop 1 p). -Proof. -apply: (@eq_from_nth _ 0) => [ | k Hk]. - by rewrite mid_size seqmul_size spseq_size size_drop p_size subn1 minnE subKn. -rewrite mid_coef_1 // q_k //. - rewrite seqmul_coef. - by rewrite nth_drop addnC addn1 spseq_coef // -mid_size. - by rewrite spseq_size size_drop p_size subn1 minnE subKn // -mid_size. -by rewrite -(@addn1 k) addnC -ltn_subRL subn1 -mid_size. -Qed. - -Lemma all_pos_dropp : all_pos (drop 1 p). -Proof. -apply/all_posP => k Hk. -rewrite nth_drop addnC addn1. -apply/all_posP. - by apply: normal_all_pos. -rewrite size_drop in Hk. -by rewrite -(@addn1 k) addnC -ltn_subRL. -Qed. - -(* (mid q)`_k = 0 iff spseq`_k = 0 *) -Lemma map_midq_spseq : -(map (fun x => x != 0) (mid q)) = map (fun x => x != 0) spseq. -Proof. -rewrite seqmul_spseq_dropp map_seqmul // ?all_pos_dropp //. -by rewrite spseq_size size_drop p_size subn1. -Qed. - -Lemma spseq_seqn0 : - (mask (map (fun x => x != 0) (mid q)) spseq) = seqn0 spseq. -Proof. -by rewrite seqn0_as_mask map_midq_spseq. -Qed. - -(* the middle coefficients of q without the 0's are as well a product *) -Lemma mid_seqn0q_decomp : - mid (seqn0 q) = - seqmul (seqn0 spseq) - (mask (map (fun x => x != 0) (mid q)) (drop 1 p)). -Proof. -by rewrite mid_seqn0_C ?q_0_neq0 // ?q_n_neq0 // - {1}seqmul_spseq_dropp {1}seqn0_as_mask mask_seqmul -spseq_seqn0 - seqmul_spseq_dropp. -Qed. - -Lemma mid_seqn0q_size : - size (mid (seqn0 q)) = size (seqn0 spseq). -Proof. -by rewrite mid_seqn0_C ?q_0_neq0 // ?q_n_neq0 // !seqn0_as_mask - !size_mask ?size_map // map_midq_spseq. -Qed. - -Lemma size_seqn0spseq_maskdropp : size (seqn0 spseq) = - size (mask [seq x != 0 | x <- mid q] (drop 1 p)). -Proof. -rewrite -mid_seqn0q_size mid_seqn0_C ?q_0_neq0 // ?q_n_neq0 // - seqn0_as_mask !size_mask //. - by rewrite size_map. -by rewrite size_map size_drop mid_size p_size subn1. -Qed. - -Lemma minn_seqn0spseq_maskdropp : (minn (size (seqn0 spseq)) - (size (mask [seq x != 0 | x <- mid (R:=R) q] (drop 1 p)))) = - (size (seqn0 spseq)). -Proof. -by rewrite -size_seqn0spseq_maskdropp minnE subKn. -Qed. - -(* this is increasing since spseq is increasing *) -Lemma subspseq_increasing : increasing (seqn0 spseq). -Proof. -by rewrite (@subseq_incr R _ spseq) // ?filter_subseq // ?spseq_increasing. -Qed. - -(* this is all positive because p is all positive *) -Lemma subp_all_pos : all_pos (mask (map (fun x => x != 0) (mid q)) (drop 1 p)). -Proof. -rewrite (@all_pos_subseq R _ (drop 1 p)) // ?all_pos_dropp//. -apply/subseqP. -exists [seq x != 0 | x <- mid (R:=R) q] => //. -by rewrite size_map mid_size size_drop p_size subn1. -Qed. - -Lemma seqn0q_1 : (1 < (size (seqn0 q)).-1)%N -> - (seqn0 q)`_1 = (mid (seqn0 q))`_0. -Proof. -by move=> Hk; rewrite -{1}[(seqn0 q)`_1]mid_coef_2. -Qed. - -Lemma seqn0q_n : (0 < (size (seqn0 q)).-2)%N -> - (seqn0 q)`_(size (seqn0 q)).-2 = - (mid (seqn0 q))`_((size (mid (seqn0 q))).-1)%N. -Proof. -move=> Hsize_2. -have Hsize_1 : (0 < (size (seqn0 q)).-1)%N. - rewrite -subn1 ltn_subRL addn0 in Hsize_2. - by rewrite (ltn_trans _ Hsize_2). -have Hsize : (0 < size (seqn0 q))%N. - rewrite -subn1 ltn_subRL addn0 in Hsize_1. - by rewrite (ltn_trans _ Hsize_1). -rewrite mid_coef_2 mid_size //. -by rewrite -(subn1 (size (seqn0 q))) ltn_subRL addnC addn1 subn1 prednK // - {2}(pred_Sn (size (seqn0 q))) -(subn1 (size (seqn0 q)).+1) ltn_subRL - addnC addn1 prednK. -Qed. - -(* Proposition 2.44 *) -Lemma normal_changes : changes (seqn0 q) = 1%N. -Proof. -case : (ltngtP 3 (size (seqn0 q))) => Hsizeseqn0q. -(* 3 < size (seqn0 q) *) - have Hincreasing1 := spseq_increasing; - have Hincreasing2 := subspseq_increasing; - have Hallpos := (subp_all_pos); - have Hseqn0q := (seqn0_all_neq0 q); - have Hseqn0spseq := (seqn0_all_neq0 spseq); - have Hqsize := q_size; - have Hqsize2 := p_size; - have Hsizemidq := mid_seqn0q_size; - have Hsizespseq := size_seqn0spseq_maskdropp; - have Hqn1 := q_n_gt0; - have Hqn2 := q_n_neq0; - have Hq01 := q_0_lt0; - have Hq02 := q_0_neq0. - have H_1 : (0%N < (size (seqn0 q)).-1)%N. - by rewrite -(ltn_add2r 1%N) !addn1 prednK (ltn_trans _ Hsizeseqn0q). - have H_2 : (0%N < (size (seqn0 q)).-2)%N. - by rewrite -(ltn_add2r 2) !addn2 prednK // prednK (ltn_trans _ Hsizeseqn0q). - rewrite changes_decomp_sizegt2 //; last by rewrite (ltn_trans _ Hsizeseqn0q). - rewrite mid_seqn0q_decomp changes_mult // seqn0_0 // seqn0q_1 //. - rewrite {1}mid_seqn0q_decomp seqmul_coef. - rewrite seqn0_n // seqn0q_n // {1}mid_seqn0q_decomp seqmul_coef. - have H_3 : (0 < size (seqn0 spseq))%N. - by rewrite -mid_seqn0q_size mid_size. - have H_4 : (1 < size (seqn0 spseq))%N. - by rewrite -mid_seqn0q_size mid_size -subn2 ltn_subRL addn1. - case/orP : (changes_seq_incr Hincreasing2 Hseqn0spseq) => Hchanges. - (* one change in mid q *) - rewrite (eqP Hchanges). - rewrite changes_seq_incr_1 // in Hchanges. - move/andP : Hchanges => [] H0 H1. - have H2: (q`_0 * - ((seqn0 spseq)`_0 * - (mask [seq x != 0 | x <- mid q] (drop 1 p))`_0) < 0) = false. - apply: negbTE. - rewrite -leNgt nmulr_rge0 // nmulr_rle0 // ltW //. - apply/all_posP => //. - by rewrite -Hsizespseq -Hsizemidq mid_size. - rewrite H2 mid_seqn0q_size. - have H3 : ((seqn0 spseq)`_(size (seqn0 spseq)).-1 * - (mask [seq x != 0 | x <- mid q] (drop 1 p))`_ - (size (seqn0 spseq)).-1 * q`_(size q).-1 < 0) = false. - apply: negbTE. - rewrite -leNgt mulrC pmulr_lge0 ?ltW // pmulr_lgt0 //. - apply/all_posP => //. - rewrite -Hsizespseq -Hsizemidq mid_size - -{2}(subn2 (size (seqn0 q))) ltn_subRL - addnC addn2 prednK // prednK //. - by rewrite {2}(pred_Sn (size (seqn0 q))) - -(subn1 (size (seqn0 q)).+1) ltn_subRL - addnC addn1 prednK // (ltn_trans _ Hsizeseqn0q). - by rewrite H3. - (* no change in mid q *) - rewrite (eqP Hchanges). - rewrite changes_seq_incr_0 // in Hchanges. - case : (ltrgtP 0 (seqn0 spseq)`_0) => Hspseqn0_0. - (* first of spseq pos *) - have H1 : ((q`_0 * - ((seqn0 spseq)`_0 * - (mask [seq x != 0 | x <- mid q] (drop 1 p))`_0) < 0) = true). - apply/eqP; rewrite eqb_id. - rewrite nmulr_rlt0 // mulrC pmulr_lgt0 //. - apply/all_posP => //. - by rewrite -Hsizespseq -Hsizemidq mid_size. - rewrite H1 mid_seqn0q_size. - have H2 : (0 < (seqn0 spseq)`_(size (seqn0 spseq)).-1). - by rewrite -(@pmulr_lgt0 _ (seqn0 spseq)`_0) // mulrC. - have H3 : ((seqn0 spseq)`_(size (seqn0 spseq)).-1 * - (mask [seq x != 0 | x <- mid q] (drop 1 p))`_ - (size (seqn0 spseq)).-1 * q`_(size q).-1 < 0) = false. - apply: negbTE. - rewrite -leNgt mulrC pmulr_lge0 ?ltW // pmulr_lgt0 //. - apply/all_posP => //. - rewrite -Hsizespseq -Hsizemidq mid_size - -{2}(subn2 (size (seqn0 q))) ltn_subRL - addnC addn2 prednK // prednK //. - by rewrite {2}(pred_Sn (size (seqn0 q))) - -(subn1 (size (seqn0 q)).+1) ltn_subRL - addnC addn1 prednK // (ltn_trans _ Hsizeseqn0q). - by rewrite H3. - (* first of spseq neg *) - have H1 : ((q`_0 * - ((seqn0 spseq)`_0 * - (mask [seq x != 0 | x <- mid q] (drop 1 p))`_0) < 0) = false). - apply: negbTE. - rewrite -leNgt nmulr_lge0 ?ltW // nmulr_rlt0 //. - apply/all_posP => //. - by rewrite -Hsizespseq -Hsizemidq mid_size. - rewrite H1. - have H2 : ((seqn0 spseq)`_(size (mid (seqn0 q))).-1 < 0). - by rewrite Hsizemidq -(@nmulr_rgt0 _ (seqn0 spseq)`_0). - have H3 : (((seqn0 spseq)`_(size (mid (seqn0 q))).-1 * - (mask [seq x != 0 | x <- mid q] (drop 1 p))`_ - (size (mid (seqn0 q))).-1 * q`_(size q).-1 < 0) = true). - apply/eqP; rewrite eqb_id nmulr_rlt0 // nmulr_rlt0 //. - apply/all_posP => //. - rewrite -Hsizespseq -Hsizemidq mid_size - -{2}(subn2 (size (seqn0 q))) ltn_subRL - addnC addn2 prednK // prednK //. - by rewrite {2}(pred_Sn (size (seqn0 q))) - -(subn1 (size (seqn0 q)).+1) ltn_subRL - addnC addn1 prednK // (ltn_trans _ Hsizeseqn0q). - by rewrite H3. - (* impossible *) - have := ((all_neq0P _ Hseqn0spseq) 0%N H_3). - rewrite eq_sym => H_5. - by have/eqP := H_5. - by rewrite -Hsizespseq -Hsizemidq mid_size minnE subKn // - -(ltn_add2r 3) !addn3 prednK. - by rewrite -Hsizespseq -Hsizemidq minnE subKn // mid_size //. - by rewrite -(ltn_add2r 1%N) !addn1 prednK // (ltn_trans _ Hsizeseqn0q). -(* size (seqn0 q) == 2 *) -have Hsizeseqn0q2 : (size (seqn0 q) == 2%N). - by rewrite eqn_leq -ltnS Hsizeseqn0q /= seqn0q_size. -rewrite changes_decomp_size2 // ?seqn0_all_neq0 //. -rewrite seqn0_0 ?q_0_neq0 // {1}(@pred_Sn 1) -(eqP Hsizeseqn0q2) - seqn0_n ?q_n_neq0 //. -apply/eqP. -by rewrite eqb1 pmulr_llt0 ?q_0_lt0 // ?q_n_gt0. -(* size (seqn0 q) = 3*) -rewrite changes_size3 // ?seqn0_all_neq0 //. - by rewrite seqn0_0 ?q_0_lt0 // q_0_neq0. -by rewrite (@pred_Sn 2) Hsizeseqn0q seqn0_n ?q_n_gt0 // q_n_neq0. -Qed. - -End Proof_Prop_2_44. diff --git a/theories/preliminaries.v b/theories/preliminaries.v deleted file mode 100644 index a2ff380..0000000 --- a/theories/preliminaries.v +++ /dev/null @@ -1,241 +0,0 @@ -From elpi Require Import elpi. - -#[projections(primitive)] Record r := { fst : nat -> nat; snd : bool }. -Axiom t : r. -Elpi Command test. -Elpi Query lp:{{ - coq.say "quotation for primitive fst t" {{ t.(fst) 3 }}, - coq.say "quotation for compat fst t" {{ fst t 3 }}, - coq.locate "r" (indt I), - coq.env.projections I [some P1,some P2], - coq.say "compatibility constants" P1 P2, - coq.env.primitive-projections I [some (pr Q1 N1), some (pr Q2 N2)], - coq.say "fst primproj" Q1 N1, - coq.say "snd primproj" Q2 N2 -}}. - -From HB Require Import structures. -From mathcomp Require Import all_ssreflect all_algebra. -From mathcomp Require Import classical_sets reals Rstruct. -From infotheo Require Import convex. - -Import GRing.Theory Num.Theory convex. -Local Open Scope ring_scope. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -(* TODO: move to mathcomp ? *) -Lemma enum_rank_index {T : finType} i : - nat_of_ord (enum_rank i) = index i (enum T). -Proof. -rewrite /enum_rank [enum_rank_in]unlock /insubd /odflt /oapp insubT//. -by rewrite cardE index_mem mem_enum. -Qed. - -(* TODO: do we keep this as more newcomer friendly than having to look - deep into the library ? *) -Lemma enum_prodE {T1 T2 : finType} : enum {: T1 * T2} = prod_enum T1 T2. -Proof. -by rewrite /enum_mem unlock /= /prod_enum -(@eq_filter _ predT) ?filter_predT. -Qed. - -Lemma index_allpairs {T1 T2: eqType} (s1: seq T1) (s2: seq T2) x1 x2 : - x1 \in s1 -> x2 \in s2 -> - index (x1, x2) [seq (x1, x2) | x1 <- s1, x2 <- s2] = - ((index x1 s1) * (size s2) + index x2 s2)%N. -Proof. -move=>ins1 ins2. -elim: s1 ins1=>//= a s1 IHs1 ins1. (* HERE*) -rewrite index_cat. -case ax: (a == x1). - move: ax=>/eqP ax; subst a; rewrite /muln /muln_rec /addn /addn_rec /=. - move: ins2=>/(map_f (fun x => (x1, x))) ->. - by apply index_map=> x y eq; inversion eq. -move: ins1; rewrite in_cons=>/orP; case=> [ /eqP xa | ins1 ]. - by subst a; move: ax; rewrite eq_refl. -case in12: ((x1, x2) \in [seq (a, x0) | x0 <- s2]). - by move: in12=>/mapP [x xin xeq]; inversion xeq; subst a; move: ax; rewrite eq_refl. -by rewrite size_map (IHs1 ins1) addnA. -Qed. - -Lemma enum_rank_prod {T T': finType} (i : T) (j : T') : - (nat_of_ord (enum_rank (i, j)) = (enum_rank i) * #|T'| + enum_rank j)%N. -Proof. -do 3 rewrite enum_rank_index. -rewrite enum_prodE cardE /=. -by apply index_allpairs; rewrite enumT. -Qed. - -Lemma nth_cat_ord [T : Type] (x0 : T) (s1 s2 : seq T) (i: 'I_(size s1 + size s2)) : - nth x0 (s1 ++ s2) i = match split i with inl i=> nth x0 s1 i | inr i=> nth x0 s2 i end. -Proof. by move: (nth_cat x0 s1 s2 i)=>->; rewrite /split; case: (ltnP i (size s1)). Qed. - -Lemma nth_allpairs [T1 T2 rT : Type] (f : T1 -> T2 -> rT) - (s1: seq T1) (s2: seq T2) (x1: T1) (x2: T2) (x: rT) (i: 'I_(size s1 * size s2)) : - nth x (allpairs f s1 s2) i = let (i, j) := split_prod i in f (nth x1 s1 i) (nth x2 s2 j). -Proof. -elim: s1 i=>/= [| a s1 IHs1] i. - by exfalso; move: i=>[i ilt]; move: ilt; rewrite /muln /muln_rec /= ltn0. -move: i; rewrite /muln /muln_rec /= -/muln_rec -/muln -/addn_rec -/addn. -have->: (size s2 + size s1 * size s2 = size (map (f a) s2) + size (allpairs f s1 s2))%N. - rewrite size_map. - by move: (allpairs_tupleP f (in_tuple s1) (in_tuple s2))=>/eqP->. -move=>i; rewrite nth_cat_ord. -rewrite -{2 3}[i]splitK. -rewrite /split; case: ltnP=>/= i0. - rewrite (set_nth_default (f a x2)) //. - case: i i0=> [i ilt'] /=; rewrite size_map=> ilt. - by rewrite (nth_map x2)// divn_small// modn_small. -move: i i0; rewrite size_map=> [[i ilt']] i0. -have ilt: ((i - size s2) < size s1 * size s2)%N. - move: (allpairs_tupleP f (in_tuple s1) (in_tuple s2))=>/eqP<-. - apply (split_subproof i0). -rewrite (IHs1 (Ordinal ilt))=> /=. -rewrite addnC divnDr// divnn/= modnDr. -have [s20|] := ltnP 0 (size s2); first by rewrite addn1. -rewrite leqn0 => /eqP s20. -by move: ilt; rewrite s20 muln0. -Qed. - -(*TODO: move to mathcomp.*) -Lemma lift_range {aT rT: Type} [f: aT -> rT] (s: seq rT) : - all (fun u => u \in range f) s -> exists s', map f s' = s. -Proof. -elim: s=>[| a s IHs]. - by exists nil. -move=> /andP [/set_mem [a' _ ae] /IHs [s' se]]; subst a s. -by exists (a' :: s'). -Qed. - -Lemma index_enum_cast_ord n m (e: n = m) : - index_enum 'I_m = [seq (cast_ord e i) | i <- index_enum 'I_n]. -Proof. -subst m. -rewrite -{1}(map_id (index_enum 'I_n)). -apply eq_map=>[[x xlt]]. -rewrite /cast_ord; congr Ordinal; apply bool_irrelevance. -Qed. - -Lemma perm_map_bij [T: finType] [f : T -> T] (s: seq T) : - bijective f -> perm_eq (index_enum T) [seq f i | i <- index_enum T]. -Proof. -rewrite /index_enum; case: index_enum_key=>/=. -move=>fbij. -rewrite /perm_eq -enumT -forallb_tnth; apply /forallP=>i /=. -inversion fbij. -rewrite enumT enumP count_map -size_filter (@eq_in_filter _ _ (pred1 (g (tnth - (cat_tuple (enum_tuple T) (map_tuple [eta f] (enum_tuple T))) - i)))). - by rewrite size_filter enumP. -move=> x _ /=. -apply/eqP/eqP. - by move=>/(f_equal g) <-. -by move=>->. -Qed. - -(* TODO: this lemma has been moved to infotheo 0.5.1 *) -Section freeN_combination. -Import ssrnum vector. -Import Order.POrderTheory Num.Theory. -Variable (R : fieldType) (E : vectType R). -Local Open Scope ring_scope. -Local Open Scope classical_set_scope. -Import GRing. - -Lemma freeN_combination n (s : n.-tuple E) : ~~ free s -> - exists k : 'I_n -> R, (\sum_i k i *: s`_i = 0) /\ exists i, k i != 0. -Proof. -exact: freeN_combination. -Qed. - -End freeN_combination. - -Lemma ord_S_split n (i: 'I_n.+1): {j: 'I_n | i = lift ord0 j} + {i = ord0}. -Proof. -case: i; case=>[| i] ilt. - by right; apply val_inj. -by left; exists (Ordinal (ltnSE ilt)); apply val_inj. -Qed. - -Lemma subseq_incl (T : eqType) (s s' : seq T) x : subseq s s' -> - {f : 'I_(size s) -> 'I_(size s') | (forall i, nth x s' (f i) = nth x s i) /\ - {homo f : y x / (x < y)%O >-> (x < y)%O}}. -Proof. -elim: s' s=> [| a s' IHs'] s sub. - by move:sub=>/eqP -> /=; exists id; split=>// i j. -case: s sub=> [ _ | b s sub]. - move=>/=; simple refine (exist _ _ _). - by move=> i; case: i. - by split; move=> i; case: i. -move: sub=>/=; case sa: (b == a). - move: sa=>/eqP <- /IHs' [f [fn flt]]. - exists (fun i => match ord_S_split i with | inleft j => lift ord0 (f (proj1_sig j)) | inright _ => ord0 end). - split. - by move=> i; case: ord_S_split=> [ [j ie] | ie ]; subst i=>/=. - move=> i j; case: ord_S_split=> [ [i' ie] | ie ]; case: ord_S_split=> [ [j' je] | je ]; subst i j=>//=. - do 2 rewrite ltEord=>/=. - by rewrite /bump /= add1n add1n add1n add1n ltnS ltnS; apply flt. -by move=>/IHs' [f [fn flt]]; exists (fun i => lift ord0 (f i)). -Qed. - -Lemma hom_lt_inj {disp disp'} {T : orderType disp} {T' : porderType disp'} [f : T -> T'] : - {homo f : x y / (x < y)%O >-> (x < y)%O} -> injective f. -Proof. -move=>flt i j. -move: (Order.TotalTheory.le_total i j). -wlog: i j / (i <= j)%O. - move=>h /orP; case=>le fij. - by apply (h i j)=>//; rewrite le. - by apply/esym; apply (h j i)=>//; rewrite le. -rewrite Order.POrderTheory.le_eqVlt=>/orP; case=> [ /eqP ij | /flt fij ]=>// _ fije. -by move: fij; rewrite fije Order.POrderTheory.lt_irreflexive. -Qed. - -Lemma size_index_enum (T: finType): size (index_enum T) = #|T|. -Proof. by rewrite cardT enumT. Qed. - -Lemma map_nth_ord [T : Type] (x: T) (s : seq T) : - [seq nth x s (nat_of_ord i) | i <- index_enum 'I_(size s)] = s. -Proof. -rewrite /index_enum; case: index_enum_key=>/=; rewrite -enumT. -elim: s=>/= [| a s IHs]. - by case: (enum 'I_0)=> [| s q] //; inversion s. -by rewrite enum_ordSl /= -map_comp /=; congr cons. -Qed. - -Lemma nth_filter [T : Type] (P: {pred T}) x (s: seq T) n : - (n < size [seq i <- s | P i])%N -> P (nth x [seq i <- s | P i] n). -Proof. -elim: s n=> [| a s IHs] n //=. -case Pa: (P a). - 2: by apply IHs. -by case: n=>//=; rewrite ltnS; apply IHs. -Qed. - -Lemma big_pair [R : Type] (idr : R) (opr : R -> R -> R) [S : Type] (ids : S) - (ops : S -> S -> S) [I : Type] (r : seq I) (F : I -> R) (G: I -> S) : - \big[(fun (x y: R*S)=> (opr x.1 y.1, ops x.2 y.2))/(idr, ids)]_(i <- r) (F i, G i) = - (\big[opr/idr]_(i <- r) F i, \big[ops/ids]_(i <- r) G i). -Proof. -elim: r=>[| a r IHr]. - by do 3 rewrite big_nil. -by do 3 rewrite big_cons; rewrite IHr. -Qed. - -From infotheo Require Import fdist. -Local Open Scope fdist_scope. - -Lemma Convn_pair [T U : @convType Rdefinitions.R] [n : nat] (g : 'I_n -> T * U) - (d : {fdist 'I_n}) : - Convn conv d g = (Convn conv d (Datatypes.fst \o g), - Convn conv d (Datatypes.snd \o g)). -Proof. -elim: n g d => [|n IHn] g d. - by have := fdistI0_False d. -rewrite /Convn; case: (Bool.bool_dec _ _) => [_|d0]. - by rewrite -surjective_pairing. -have := IHn (g \o fdist_del_idx ord0) (fdist_del (Bool.eq_true_not_negb _ d0)). -by rewrite/Convn => ->. -Qed. diff --git a/theories/preliminaries_hull.v b/theories/preliminaries_hull.v deleted file mode 100644 index 496b471..0000000 --- a/theories/preliminaries_hull.v +++ /dev/null @@ -1,280 +0,0 @@ -From mathcomp Require Import all_ssreflect ssrnum zmodp order constructive_ereal. -Require Import preliminaries. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -Import Order.POrderTheory Order.TotalTheory. -Local Open Scope order_scope. - -(******************************************************************************) -(* Zp_succ (i : 'I_n) == the ordinal i.+1 : 'I_n *) -(******************************************************************************) - -Definition Zp_succ p : 'I_p -> 'I_p := - match p with - 0 => id - | q.+1 => fun i : 'I_q.+1 => inZp i.+1 - end. - -Notation "n .+1mod" := (Zp_succ n) (at level 2, left associativity, - format "n .+1mod"). - -Lemma Zp_succE n (i : 'I_n) : val (i .+1mod) = i.+1 %% n. -Proof. by case: n i => // -[]. Qed. - -Lemma Zp_succ_max n : (@ord_max n).+1mod = ord0. -Proof. by apply: val_inj => /=; rewrite modnn. Qed. - -Lemma subseq_iota (n m : nat) (l : seq nat) : subseq l (iota n m) = - (l == [::]) || (n <= nth 0 l 0)%N && - [forall i : 'I_(size l), (nth 0 l i < nth 0 (rcons l (n+m)) i.+1)%N]. -Proof. -elim:l n m=>[| a l IHl] n m; first by case: (iota n m). -elim: m n=>[| m IHm] n. - rewrite /addn/addn_rec-plus_n_O. - move:(size_iota n 0)=>/size0nil->/=; apply/esym/negbTE. - rewrite negb_and orbC -implybE; apply/implyP=>/forallP lmono; rewrite -ltnNge. - elim:l a {IHl} lmono=>[| b l IHl] a; first by move=>/(_ ord0). - by move=>lmono; apply (ltn_trans (lmono ord0)); apply IHl=>i/=; apply (lmono (lift ord0 i)). -rewrite/iota-/(iota n.+1 m)/subseq. -case: ifP. - move=>/eqP an; subst a. - rewrite -/(subseq l (iota n.+1 m)) (IHl n.+1 m)/= leqnn/=. - destruct l=>/=. - by apply/esym/forallP; case; case=>//= _; rewrite -{1}(addn0 n) ltn_add2l. - apply/andP/forallP. - by move=>[nn0 /forallP nl] i; case (ord_S_split i)=>[ [j]->/= | ->// ]; rewrite -addSnnS; apply nl. - move=>nl; split; first by apply (nl ord0). - by apply/forallP=>i; rewrite addSnnS; apply (nl (lift ord0 i)). -move=>an. -rewrite -/(subseq (a :: l) (iota n.+1 m)) IHm; congr andb=>/=. - by rewrite ltn_neqAle eq_sym an. -by rewrite addSnnS. -Qed. - -Lemma count_card (T : eqType) (x : T) (l : seq T) (P : pred T) : - count P l = #|[set i : 'I_(size l) | P (nth x l i)]|. -Proof. -elim:l. - by move=>/=; apply/esym /eqP; rewrite cards_eq0 -subset0; apply/subsetP=>[[i ilt]]. -move=>a l IHl /=. -rewrite (cardsD1 (Ordinal (ltn0Sn _))) IHl. -rewrite cardsE. -have fi: injective (fun i : 'I_(size l)=> lift ord0 i) by move=>[i ilt] [j jlt]/(congr1 val)/=/eqP; rewrite/bump/= 2!add1n eqSS=>/eqP ij; apply val_inj. -rewrite -(card_imset _ fi)/=. -have/eqP->: [set i : 'I_(size l).+1 | P (nth x (a :: l) i)] :\ Ordinal (ltn0Sn (size l)) == [set lift ord0 i | i in fun x0 : 'I_(size l) => P (nth x l x0)]. - rewrite eqEsubset; apply/andP; split; apply/subsetP=>i; rewrite in_setD1 inE. - move=>/andP[i0 Pi]. - case: (ord_S_split i); last by move=>ie; subst i; move: i0=>/negP; elim. - move=>[j ie]; subst i. - by apply /imsetP=>/=; exists j. - move=>/imsetP/=[j Pj ie]; subst i. - by apply/andP; split. -by apply/eqP; rewrite eqn_add2r inE; apply/eqP. -Qed. - -Lemma filter_incl_surj (T : eqType) (x : T) (l : seq T) (P : pred T) : - let l' := [seq x <- l | P x] in forall (f : 'I_(size l') -> 'I_(size l)), - (forall i : 'I_(size l'), nth x l (f i) = nth x l' i) -> - {homo f : x0 y / x0 < y >-> x0 < y} -> - forall j : 'I_(size l), P (nth x l j) -> - exists i : 'I_(size l'), j = f i. -Proof. -set l' := [seq x0 <- l | P x0]=>/= f fi fh j Pj. -suff: exists i, ~~ (j != f i) by move=>[i /negPn/eqP ->]; exists i. -apply /existsP. -rewrite -negb_forall; apply /negP=>/forallP jf. -suff: size l' < count P l by rewrite size_filter lt_irreflexive. -rewrite (count_card x). -(* Huh ??? *) -have what: (size l' < (size l').+1) by move:(leqnn (size l').+1). -apply (lt_le_trans what). -rewrite -(card_ord (size l').+1). -have/card_codom<-: injective (fun i => - match ord_S_split i with - | inleft j => f (proj1_sig j) - | _ => j - end). - move=>a b. - case:(ord_S_split a). - move=>[a'/= ae]; subst a. - case:(ord_S_split b). - move=>[b'/= be]; subst b=>fab. - apply val_inj; apply/eqP; rewrite/=/bump/= 2!add1n eqSS. - by apply/negP=>/negP/lt_total/orP; case=>/fh; rewrite fab lt_irreflexive. - by move=>->/esym je; move:(jf a'); rewrite je eq_refl. - case:(ord_S_split b). - by move=>[b'/= be]; subst b=>fab je; move:(jf b'); rewrite je eq_refl. - by move=>-> -> _. -apply subset_leq_card; apply/subsetP=>k /codomP [a ->]. -case: (ord_S_split a). - move=>[a'/= _]; rewrite inE fi. - have/mem_nth: val a' < size l' by case: a'. - by move=>/(_ x); rewrite mem_filter=>/andP[h _]. -by move=>_; rewrite inE. -Qed. - -Lemma homo_lt_total disp disp' {T : orderType disp} - {T' : orderType disp'} [f : T -> T'] : {homo f : x y / x < y >-> x < y} -> - forall x y, f x < f y -> x < y. -Proof. -move=>fh x y fxy. -case xy: (x == y); first by move:xy fxy=>/eqP ->; rewrite lt_irreflexive. -move:xy=>/negbT/lt_total/orP; case=>// /fh fyx. -by move:(lt_trans fxy fyx); rewrite lt_irreflexive. -Qed. - -Lemma homo_lt_inj {disp disp'} {T : orderType disp} - {T' : orderType disp'} [f : T -> T'] : {homo f : x y / x < y >-> x < y} -> - injective f. -Proof. -move=>fh x y fxy. -case xy: (x == y); first by move:xy=>/eqP. -by move:xy=>/negbT/lt_total/orP; case=>/fh; rewrite fxy lt_irreflexive. -Qed. - -Lemma filter_succ (T : eqType) (x : T) (l : seq T) (P : pred T) : - let l' := [seq x <- l | P x] in forall (f : 'I_(size l') -> 'I_(size l)), - (forall i : 'I_(size l'), nth x l (f i) = nth x l' i) -> - {homo f : x0 y / x0 < y >-> x0 < y} -> - forall (i' : 'I_(size l')) k, - (f i' < k < (f i'.+1mod + (i'.+1 == size l')*(size l))%N)%N -> - ~~ P (nth x l (k %% size l)). -Proof. -(*Huh???*) -set l' := [seq x0 <- l | P x0]=>/= f fi fh i' k ikj; apply /negP=>Pkl. -have kl: k %% size l < size l. - apply ltn_pmod; destruct l=>//. - by move:(i')=>[a/= alt]. -move: (@filter_incl_surj _ _ _ _ _ fi fh (Ordinal kl) Pkl)=>[[a alt] /(congr1 val)/= ke]. -(*Way too long*) -destruct i' as [i' i'lt]. -move:(i'lt); rewrite leq_eqVlt => /predU1P[ie|]. - move:ikj; rewrite ie eq_refl mul1n. - case klt: (k < size l). - move:(alt); rewrite -{1}ie leq_eqVlt=>/orP; case. - rewrite eqSS=>/eqP ae; subst a. - move: ke; rewrite modn_small ?klt//; move=>->/andP. - have->:Ordinal alt = Ordinal i'lt by apply val_inj. - move=>[h _]. - by move: (lt_irreflexive (f (Ordinal i'lt)))=>/negbT/negP; apply. - rewrite ltnS=>ai' /andP[fik _]. - have/fh fai:Ordinal alt < Ordinal i'lt by []. - move:(ltn_trans fai fik); rewrite/= -ke modn_small ?klt//. - by rewrite ltnn. - move:klt; rewrite ltNge=>/negbT/negbNE lk. - move=>/andP[_]; rewrite addnC -ltn_subLR// =>kf. - have kmod: (k %% size l = k - size l)%N. - rewrite -{1}[k](subnK lk) modnDr modn_small//. - by apply (ltn_trans kf). - move:ke; rewrite kmod=>ke. - have ie' : val (Ordinal i'lt).+1mod = 0%N. - by move: ie i'lt {kf}=><- i'lt/=; apply modnn. - destruct a as [| a]. - have ae: Zp_succ (Ordinal i'lt) = Ordinal alt by apply val_inj. - by move: kf; rewrite ke -ae ltnn. - have /fh fia : (Ordinal i'lt).+1mod < Ordinal alt. - suff: val (Ordinal i'lt).+1mod < a.+1 by []. - by rewrite ie'; apply ltn0Sn. - have fai: f (Ordinal alt) < f (Ordinal i'lt).+1mod. - by have: val (f (Ordinal alt)) < val (f (Ordinal i'lt).+1mod) by rewrite/= -ke. - by move:(lt_trans fai fia); rewrite ltxx. -move=>i'lt'; move:ikj. -case ile: ((Ordinal i'lt).+1 == size l'). - by move:ile=>/=/eqP ile; move:i'lt'; rewrite ile ltnn. -rewrite/=/muln/muln_rec/= addnC/addn/addn_rec/= => /andP[fk kf]. -have kl': (k < size l)%N by apply (ltn_trans kf). -move:Pkl kl ke; rewrite modn_small// =>Pkl kl ke. -move:fk kf; rewrite ke=>/(@homo_lt_total _ _ _ _ _ fh) ia /(@homo_lt_total _ _ _ _ _ fh) ai. -have ia': (i' < a)%N by []. -have ai': (a < i'.+1)%N. - have ai': val (Ordinal alt) < val (Ordinal i'lt).+1mod by []. - move:f fi fh alt i'lt ile {ia} ke i'lt' ai ai'; rewrite/Zp_succ -/l'; generalize (size l'); case=>// n _ _ _ /= _ _ _ _ i'lt _. - by rewrite modn_small. -by move: (leq_ltn_trans ia' ai'); rewrite ltnn. -Qed. - -Lemma uniq_subseq_size (T: eqType) (l l': seq T) : - all (fun x => x \in l) l' -> uniq l' -> (size l' <= size l)%N. -Proof. -elim: l' l=>// a l' IHl' l /andP[al /allP l'l] /andP [al' l'uniq]. -move:(al)=>/size_rem/(f_equal S). -rewrite prednK; last by case: l l'l al. -move=><-; rewrite ltnS; apply IHl'=>//. -apply/allP=>b bl'; move:(bl')=>/l'l bl. -apply/negPn/negP=>/count_memPn brem. -move:al=>/perm_to_rem /allP /(_ b). -rewrite mem_cat bl/= =>/(_ Logic.eq_refl); rewrite brem. -case ab: (a == b); first by move=>_; move: al'=>/negP; apply; move: ab=>/eqP->. -by move=>/=/eqP/count_memPn/negP; apply. -Qed. - -Section ereal_tblattice. -Variable (R : realDomainType). -Local Open Scope ereal_scope. - -(* PRed to MathComp-Analysis: https://github.com/math-comp/analysis/pull/859 *) -(* -Definition ereal_blatticeMixin : - Order.BLattice.mixin_of (Order.POrder.class (@ereal_porderType R)). -exists (-oo); exact leNye. -Defined. -Canonical ereal_blatticeType := BLatticeType (\bar R) ereal_blatticeMixin. - - -Definition ereal_tblatticeMixin : - Order.TBLattice.mixin_of (Order.POrder.class (ereal_blatticeType)). -exists (+oo); exact leey. -Defined. -Canonical ereal_tblatticeType := TBLatticeType (\bar R) ereal_tblatticeMixin. -(* /PRed *) -*) - -(* Note: Should be generalized to tbLatticeType+orderType, but such a structure is not defined. *) -Lemma ereal_joins_lt - (J : Type) (r : seq J) (P : {pred J}) (F : J -> \bar R) (u : \bar R) : - -oo < u -> - (forall x, P x -> F x < u) -> \join_(x <- r | P x) F x < u. -Proof. by move=>u0 ltFm; elim/big_rec: _ => // i x Px xu; rewrite ltUx ltFm. Qed. - -Lemma ereal_meets_gt - (J : Type) (r : seq J) (P : {pred J}) (F : J -> \bar R) (u : \bar R) : - u < +oo -> - (forall x, P x -> u < F x) -> u < \meet_(x <- r | P x) F x. -Proof. by move=>u0 ltFm; elim/big_rec: _ => // i x Px xu; rewrite ltxI ltFm. Qed. - -End ereal_tblattice. - -Section bigop_partition. - -Lemma perm_eq_partition {aT rT : eqType} (l : seq aT) (s : seq rT) (f : aT -> rT) : - uniq s -> all (fun x=> f x \in s) l -> perm_eq [seq x | y <- s, x <- [seq x <- l | f x == y]] l. -Proof. -elim: s l; first by case. -move=>y s IHs l yus /allP fl /=. -move: (perm_filterC (fun x=> f x == y) l)=>/(_ l); rewrite perm_refl; apply perm_trans. -rewrite map_id; apply perm_cat=>//. -have->: [seq x | y0 <- s, x <- [seq x <- l | f x == y0]] = [seq x | y0 <- s, x <- [seq x <- [seq x <- l | predC (fun x : aT => f x == y) x] | f x == y0]]. - clear IHs fl. - elim: s y yus=>// y' s IHl y /andP[]; rewrite in_cons negb_or=> /andP [yy' ys] /andP[_ us] /=; congr cat; last by apply/IHl/andP; split. - rewrite 2!map_id -filter_predI; apply eq_filter=>x. - apply/idP/idP. - by move=>/=/eqP->; rewrite eq_refl eq_sym. - by move=>/andP[]. -apply IHs; first by move:yus=>/andP[]. -by apply/allP=>x; rewrite mem_filter=>/andP [/= /negPf fxy /fl]; rewrite in_cons=>/orP; case=>//; rewrite fxy. -Qed. - -Lemma big_partition {aT rT : eqType} {R : Type} {idx : R} {op : Monoid.com_law idx} {F : aT -> R} {l : seq aT} {s : seq rT} {f : aT -> rT} : - uniq s -> all (fun x=> f x \in s) l -> - \big[op/idx]_(i <- l) F i = \big[op/idx]_(y <- s) \big[op/idx]_(i <- l | f i == y) F i. -Proof. -move=>us fs. -move:(@big_allpairs_dep _ idx op _ _ _ (fun i j=> j) s (fun i=> [seq j <- l | f j == i]) F); congr eq. - by apply/perm_big/perm_eq_partition. -by apply congr_big=>//y _; rewrite big_filter. -Qed. - -End bigop_partition. diff --git a/theories/shortest_path.v b/theories/shortest_path.v deleted file mode 100644 index ac4dac1..0000000 --- a/theories/shortest_path.v +++ /dev/null @@ -1,71 +0,0 @@ -From mathcomp Require Import all_ssreflect all_algebra. -Require Import ZArith String OrderedType OrderedTypeEx FMapAVL. - -Notation head := seq.head. -Notation seq := seq.seq. -Notation nth := seq.nth. -Notation sort := path.sort. - -Import Order.POrderTheory Order.TotalTheory. - -Section shortest_path. - -Variable R : Type. -Variable R0 : R. -Variable R_ltb : R -> R -> bool. -Variable R_add : R -> R -> R. - -Variable cell : Type. -Variable node : Type. -Variable node_eqb : node -> node -> bool. -Variable neighbors_of_node : node -> seq (node * R). -Variable source target : node. - -Variable priority_queue : Type. -Variable empty : priority_queue. -Variable gfind : priority_queue -> node -> option (seq node * option R). -Variable update : priority_queue -> node -> seq node -> option R -> - priority_queue. -Variable pop : priority_queue -> - option (node * seq node * option R * priority_queue). - -Definition cmp_option (v v' : option R) := - if v is Some x then - if v' is Some y then - (R_ltb x y)%O - else - true - else - false. - -Definition Dijkstra_step (d : node) (p : seq node) (dist : R) - (q : priority_queue) : priority_queue := - let neighbors := neighbors_of_node d in - foldr (fun '(d', dist') q => - match gfind q d' with - | None => q - | Some (p', o_dist) => - let new_dist_to_d' := Some (R_add dist dist') in - if cmp_option new_dist_to_d' o_dist then - update q d' (d :: p) new_dist_to_d' - else q - end) q neighbors. - -Fixpoint Dijkstra (fuel : nat) (q : priority_queue) := - match fuel with - | 0%nat => None - |S fuel' => - match pop q with - | Some (d, p, Some dist, q') => - if node_eqb d target then Some p else - Dijkstra fuel' (Dijkstra_step d p dist q') - | _ => None - end - end. - -Definition shortest_path (s : seq node) := - Dijkstra (size s) - (update (foldr [fun n q => update q n [::] None] empty s) - source [::] (Some R0)). - -End shortest_path. diff --git a/theories/shortest_path_proofs.v b/theories/shortest_path_proofs.v deleted file mode 100644 index 1e82b9d..0000000 --- a/theories/shortest_path_proofs.v +++ /dev/null @@ -1,105 +0,0 @@ -From mathcomp Require Import all_ssreflect all_algebra. -Require Import ZArith String OrderedType OrderedTypeEx FMapAVL. -Require Import shortest_path. - -Notation head := seq.head. -Notation seq := seq.seq. -Notation nth := seq.nth. -Notation sort := path.sort. - -Import Order.POrderTheory Order.TotalTheory. - -Section shortest_path_proofs. - -Variable R : realDomainType. - -Variable node : eqType. - -Variable neighbors : node -> seq (node * R). - -Variable queue : Type. -Variable empty : queue. -Variable find : queue -> node -> option (seq node * option R). -Variable update : queue -> node -> seq node -> option R -> queue. -Variable pop : queue -> option (node * seq node * option R * queue). - -Hypothesis find_empty : - forall n, find empty n = None. -Hypothesis find_update_eq : forall q n p d p' d', - find q n = Some(p', d') -> cmp_option R <%R d d' -> - find (update q n p d) n = Some(p, d). -Hypothesis find_update_None : forall q n p d, - find q n = None -> find (update q n p d) n = Some(p, d). -Hypothesis find_update_diff : forall q n1 n2 p d, - n1 != n2 -> - find (update q n1 p d) n2 = find q n2. -Hypothesis pop_remove : - forall q n p d q', pop q = Some (n, p, d, q') -> - find q' n = None. -Hypothesis pop_find : - forall q n p d q', pop q = Some (n, p, d, q') -> - find q n = Some(p, d). -Hypothesis pop_diff : - forall q n1 n2 p d q', pop q = Some(n1, p, d, q') -> - n1 != n2 -> - find q' n2 = find q n2. -Hypothesis pop_min : forall q n1 n2 p p' d d' q', - pop q = Some(n1, p, d, q') -> - find q n2 = Some(p', d') -> cmp_option _ <%R d d'. -Hypothesis update_discard : - forall q n p d p' d', - find q n = Some(p, d) -> - ~~ cmp_option _ <%R d' d -> - find (update q n p' d') n = find q n. - -Lemma oltNgt (d1 d2 : option R) : cmp_option _ <%R d1 d2 -> - ~~ cmp_option _ <%R d2 d1. -Proof. -case: d1 => [d1 | ]; case: d2 => [d2 | ] //. -rewrite /cmp_option. -by rewrite -leNgt le_eqVlt orbC => ->. -Qed. - - -Lemma cmp_option_trans (r : rel R) : ssrbool.transitive r -> - ssrbool.transitive (cmp_option _ r). -Proof. -move=> rtr [y |] [x |] [z|] //=. -by apply: rtr. -Qed. - -Lemma cmp_option_le_lt_trans (y x z: option R) : - ~~ cmp_option _ <%R y x -> cmp_option _ <%R y z -> - cmp_option _ <%R x z. -Proof. -case: x => [x | ]; case: y => [y | ] // xley. -rewrite /= -leNgt le_eqVlt in xley. -case: (orP xley)=> [/eqP ->| xltkey ]; first by []. -apply: (cmp_option_trans <%R lt_trans). -exact: xltkey. -Qed. - -Arguments cmp_option_trans [r] _ [_ _ _]. - -(* A sobering counter example: you cannot swap updates, because they - may imply different choices between points at the same distance. *) -Lemma update_update_counterx n p1 p2 d : - p1 != p2 -> - find (update (update empty n p1 d) n p2 d) n != - find (update (update empty n p2 d) n p1 d) n. -Proof. -move=> pdif. -have testfail : ~~ cmp_option R <%R d d. - by case: d => [d | ] //=; rewrite lt_irreflexive. -have inup1 : find (update empty n p1 d) n = Some(p1, d). - by rewrite find_update_None. -rewrite (update_discard _ _ _ _ _ _ inup1) //. -rewrite inup1. -have inup2 : find (update empty n p2 d) n = Some(p2, d). - by rewrite find_update_None. -rewrite (update_discard _ _ _ _ _ _ inup2) //. -rewrite inup2. -by apply/eqP=> - [] /eqP; rewrite (negbTE pdif). -Qed. - -End shortest_path_proofs. diff --git a/theories/square_free.v b/theories/square_free.v deleted file mode 100644 index 4bfdc65..0000000 --- a/theories/square_free.v +++ /dev/null @@ -1,119 +0,0 @@ -From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype prime. -From mathcomp Require Import div ssralg poly polydiv polyorder ssrnum zmodp polyrcf. - -Set Implicit Arguments. -Unset Strict Implicit. - -Import GRing.Theory. (*Num.Theory Num.Def.*) -Import Pdiv.Idomain. - -Open Scope ring_scope. - -Section more_deriv. - -Lemma derivXsubCexpSn : forall (R : idomainType) (c : R) (n : nat), - (('X-c%:P) ^+(n.+1))^`() = (n.+1)%:R *: ('X-c%:P) ^+ n. -Proof. -move=> R c; elim=> [|m Hm]; first by rewrite scaler_nat expr0 expr1 derivXsubC. -rewrite exprSr derivM derivXsubC Hm -scalerAl -exprSr mulr1 scaler_nat -mulrSr. -by rewrite -scaler_nat. -Qed. - -Lemma derivXsubCexpn : forall (R : idomainType) (c : R) (n : nat), - (0 < n)%N -> (('X-c%:P) ^+n)^`() = n%:R *: ('X-c%:P) ^+ (n.-1). -Proof. by move=> R c; elim=> [|m Hm H] //=; rewrite derivXsubCexpSn. Qed. - -End more_deriv. - -Section poly_simple_roots. - -Variable R : idomainType. -Hypothesis HR : [char R] =i pred0. - -Lemma mu_x_gcdp : forall (p : {poly R}) (x : R), (p != 0) -> (root p x) -> - \mu_x (gcdp p p^`()) == (\mu_x p) .-1. -Proof. -move=> p x Hp zero_x. -(*about p*) -have [q Hq Hpp] := (@mu_spec R p x Hp). -(*mu x > 0*) -have Hmu : ((\mu_x p)%R > 0)%N by rewrite mu_gt0. -(*about p'*) -have Hpderiv : (deriv p) = - ('X - x%:P) ^+ (\mu_x p).-1 * ((\mu_x p)%:R *: q + ('X-x%:P) * (deriv q)). - by rewrite mulrDr mulrA -exprSr prednK // -scalerCA -derivXsubCexpn // - -derivM mulrC {1}Hpp. -(**********) -rewrite eq_sym -muP. - apply/andP; split. -(*(X-x)^m-1 divides pgcd*) - rewrite dvdp_gcd. - apply/andP; split. -(*(X-x)^m-1 divides p*) - by rewrite {2}Hpp -(@prednK (\mu_x p)) // exprS mulrA; apply dvdp_mulIr. -(*(X-x)^m-1 divides p'*) - by rewrite Hpderiv; apply dvdp_mulIl. -(*(X-x)^m doesn't divide pgcd*) - rewrite prednK // dvdp_gcd negb_and. - apply/orP; right. -(*(X-x)^m doesn't divide p'*) - rewrite Hpderiv -{1}(@prednK (\mu_x p)) // exprSr dvdp_mul2l. -(*(X-x) doesn't divide the remaining factor of p'*) - rewrite dvdp_addl; last by apply dvdp_mulr. - rewrite (@eqp_dvdr _ q ((\mu_x p)%:R *: q) ('X -x%:P)). - by rewrite dvdp_XsubCl. - apply eqp_scale. - have/charf0P ->:= HR. - by rewrite -lt0n //. - by rewrite -size_poly_gt0 size_exp_XsubC prednK //. -by rewrite gcdp_eq0 negb_and Hp. -Qed. - -Lemma mu_gcdp_eq1 : forall (p : {poly R}) (x : R), (p != 0) -> root p x -> - (\mu_x (divp p (gcdp p p^`())) == 1)%N. -Proof. -move=> p x Hp zero_x. -rewrite -(@eqn_add2r ((\mu_x)%R p)) (@addnC 1%N _) addn1 - -{1}(@prednK ((\mu_x)%R p)) ?mu_gt0 //. -rewrite addnS -(eqP (mu_x_gcdp Hp zero_x)) -mu_mul. - rewrite divpK ?mu_mulC //; last by apply dvdp_gcdl. - by apply lc_expn_scalp_neq0. -rewrite divpK. - rewrite -size_poly_gt0 -mul_polyC size_Cmul ?size_poly_gt0 //. - by apply lc_expn_scalp_neq0. -by apply dvdp_gcdl. -Qed. - -Lemma same_roots_1 : forall (p : {poly R}) (x : R), root p x -> - root (divp p (gcdp p p^`())) x. -Proof. -move=> p x zero_x. -case h: (p==0). - by move/eqP: h => H; move : zero_x; rewrite H deriv0 gcd0p div0p. -move/negbT: h => H; rewrite -mu_gt0. - by move/eqP : (mu_gcdp_eq1 H zero_x) => ->. -rewrite divpN0; first by apply: leq_gcdpl. -by move/negPf : H => H; rewrite gcdp_eq0 H. -Qed. - -Lemma same_roots_2 : forall (p : {poly R}) (x : R), - root (divp p (gcdp p p^`())) x -> root p x. -Proof. -move=> p x zero_x. -rewrite -(@rootZ R x (lead_coef (gcdp p p^`()) ^+ scalp (R:=R) p - (gcdp p p^`())) p). - rewrite -divpK. - by rewrite rootM zero_x. - by apply dvdp_gcdl. -by apply lc_expn_scalp_neq0. -Qed. - -Lemma gcdp_simple_roots : forall (p : {poly R}) (x : R), (p != 0) -> - root (divp p (gcdp p p^`())) x -> - (\mu_x (divp p (gcdp p p^`())) == 1)%N. -Proof. -by move=> p x Hp zero_x; apply (mu_gcdp_eq1 Hp); apply same_roots_2. -Qed. -(*p!=0 beause of mu_polyC.*) - -End poly_simple_roots. diff --git a/theories/three_circles.v b/theories/three_circles.v deleted file mode 100644 index e782a95..0000000 --- a/theories/three_circles.v +++ /dev/null @@ -1,756 +0,0 @@ -From HB Require Import structures. -From mathcomp Require Import all_ssreflect. -From mathcomp Require Import ssralg poly polydiv polyorder ssrnum zmodp. -From mathcomp Require Import polyrcf qe_rcf_th complex. -Require Import poly_normal pol. - -(* -This file consists of several sections: -- nonnegative lists, polynomials with nonnegative coefs, - proof of Proposition 2.39 of [bpr], monic_roots_changes_eq0 -- complements for scaleX_poly -- complements for transformations in R and roots -- complements for transformations and equality -- complements for transformations in C and roots -- proof of 3 circles i) -- proof of 3 circles ii) -*) - -Set Implicit Arguments. -Unset Strict Implicit. - -Import Order.Theory GRing.Theory Num.Theory Num.Def. -Import Pdiv.Idomain. - -Local Open Scope ring_scope. - -Section about_nonneg. - -Variable R : rcfType. - -Local Notation C := (complex R). - -Definition nonneg (s : seq R) := all (fun x => 0 <= x) s. - -Lemma nonnegP (s : seq R) : - reflect (forall k, (k < size s)%N -> 0 <= s`_k) (nonneg s). -Proof. exact/all_nthP. Qed. - -Lemma nonneg_poly_deg1 (a : R) : nonneg ('X - a%:P) = (a <= 0). -Proof. -by rewrite polyseqXsubC /= ler01 oppr_ge0 !andbT. -Qed. - -Import complex. - -Lemma nonneg_poly_deg2 (z : C) : - nonneg ('X^2 + (1 *- 2 * Re z) *: 'X + (Re z ^+ 2 + Im z ^+ 2)%:P) = - ((Re z) <= 0). -Proof. -rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 /= ?oner_neq0 // ler01 !andbT. -by rewrite nmulr_rge0 ?oppr_lt0 ?ltr0n // addr_ge0 // sqr_ge0. -Qed. - -Lemma nonneg_mulr (p q : {poly R}) : nonneg p -> nonneg q -> nonneg (p * q). -Proof. -have [->|Hpsize] := eqVneq p 0; first by rewrite mul0r. -have [->|Hqsize Hp Hq] := eqVneq q 0; first by rewrite mulr0. -apply/nonnegP => k lpq. -rewrite coef_mul_poly /= sumr_ge0 // => i _. -apply: mulr_ge0. - have [Hi2|Hi2] := ltnP i (size p); first exact/nonnegP. - by rewrite -(coefK p) coef_poly ltnNge Hi2. -have [Hi2|Hi2] := ltnP (k - i) (size q); first exact/nonnegP. -by rewrite -(coefK q) coef_poly ltnNge Hi2. -Qed. - -Local Notation toC := (fun (p : {poly R}) => - @map_poly R _ (real_complex R) p). - -Lemma nonneg_root_nonpos (p : {poly R}) : p \is monic -> - (forall z : C, root (toC p) z -> (Re z <= 0)) -> nonneg p. -Proof. -move=> Hpmonic. -move: {2}(size p) (leqnn (size p)) => n. -elim: n p Hpmonic=> [p Hpmonic Hpsize Hproot | n IH p Hpmonic Hpsize Hproots]. -(* size p <= 0 *) - rewrite size_poly_leq0 in Hpsize. - by rewrite (eqP Hpsize) monicE lead_coef0 eq_sym oner_eq0 in Hpmonic. -(* size p <= n.+1 *) -case: (altP (size (toC p) =P 1%N)) => Hpsize2. -(* size p = 1 *) - rewrite size_map_poly_id0 in Hpsize2; - last by rewrite eq_sym negbT // lt_eqF // ltcR (eqP Hpmonic) ltr01. - have Hp := (size1_polyC (eq_leq Hpsize2)). - rewrite Hp in Hpsize2. - rewrite Hp monicE lead_coefE Hpsize2 -pred_Sn polyseqC in Hpmonic. - rewrite size_polyC in Hpsize2. - rewrite Hpsize2 /= in Hpmonic. - by rewrite Hp /= (eqP Hpmonic) polyseqC oner_neq0 /= ler01. -(* size p != 1 *) -move/closed_rootP : Hpsize2. -case=> x Hrootx. -have [Himx|Himx] := altP (Im x =P 0). -(* real root *) - have H := monicXsubC (Re x). - have Hp := real_root_div_poly_deg1 Himx Hrootx. - rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp. - rewrite (eqP Hp) nonneg_mulr //. - apply: IH=> [ | | z Hz]. - + by rewrite monicE -(@lead_coef_Mmonic _ (p %/ ('X - (Re x)%:P)) - ('X - (Re x)%:P)) // -(eqP Hp) -monicE. - - rewrite size_divp; last by apply: monic_neq0. - by rewrite size_XsubC leq_subLR addnC addn1. - + rewrite Hproots // (eqP Hp) rmorphM rootM. - apply/orP; by left. - by rewrite nonneg_poly_deg1 (Hproots x Hrootx). -(* pair of complex roots *) -have H : 'X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P \is monic. - by rewrite -(mul1r 'X^2) mul_polyC monicE lead_coefE polyseq_deg2 // oner_neq0. -have H2 : size ('X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P) = 3%N. - by rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 // oner_neq0. -have Hp := complex_root_div_poly_deg2 Himx Hrootx. -rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp. -rewrite (eqP Hp) nonneg_mulr //. - apply: IH=> [ | | z Hz]. - + by rewrite monicE -(@lead_coef_Mmonic _ _ ('X^2 + (1 *- 2 * Re x) *: 'X + - (Re x ^+ 2 + Im x ^+ 2)%:P)) // -(eqP Hp) -monicE. - - rewrite size_divp; last by apply: monic_neq0. - by rewrite H2 leq_subLR addnC addn2 (@leq_trans n.+1). - + by rewrite Hproots // (eqP Hp) rmorphM rootM Hz. -by rewrite nonneg_poly_deg2 (Hproots _ Hrootx). -Qed. - -Lemma nonneg_changes0 (s : seq R) : nonneg s -> changes s = 0%N. -Proof. -elim: s => [ |a ] //. -case=> [_ _ |b l IHbl /andP [] Ha Hblnonneg]. - by rewrite /= mulr0 addn0 ltxx. -have /andP[Hb Hlnonneg] := Hblnonneg. -apply/eqP; rewrite addn_eq0 eqb0 -leNgt mulr_ge0 //=. -apply/eqP; by apply: IHbl. -Qed. - -(* Proposition 2.39 *) -Lemma monic_roots_changes_eq0 (p : {poly R}) : p \is monic -> - (forall (z : C), (root (toC p) z) -> (Re z <= 0)) -> - changes p = 0%N. -Proof. -move=> Hpmonic H. -by rewrite nonneg_changes0 // nonneg_root_nonpos. -Qed. - -End about_nonneg. - -Section about_scaleX_poly. (* move this section to pol.v*) - -Variable (R : comRingType). - -Lemma scaleX_poly_is_linear (c : R) : linear (scaleX_poly c). -Proof. by move=> a u v; rewrite /scaleX_poly comp_polyD comp_polyZ. Qed. - -Lemma scaleX_poly_multiplicative (c : R) : multiplicative (scaleX_poly c). -Proof. -split. move=> x y; exact: comp_polyM. by rewrite /scaleX_poly comp_polyC. -Qed. - -HB.instance Definition _ (c : R) := GRing.isLinear.Build _ _ _ _ _ (scaleX_poly_is_linear c). - -HB.instance Definition _ c := GRing.isMultiplicative.Build _ _ _ (scaleX_poly_multiplicative c). - -(*Canonical scaleX_poly_rmorphism c := AddRMorphism (scaleX_poly_multiplicative c).*) - -Lemma scaleX_polyC (c a : R) : a%:P \scale c = a%:P. -Proof. by rewrite /scaleX_poly comp_polyC. Qed. - -End about_scaleX_poly. - -Section about_transformations. -Variable R : fieldType. -(* -Lemma root_shift_1 (p : {poly R}) (a x : R) : - (root p x) = root (p \shift a) (x-a). -Proof. by rewrite !rootE -horner_shift_poly1. Qed. -*) -Lemma root_shift_2 (p : {poly R}) (a x : R) : - root p (x + a) = root (p \shift a) x. -Proof. by rewrite !rootE -{2}(@addrK _ a x) -horner_shift_poly1. Qed. -(* -Lemma root_scale_1 (p : {poly R}) (a x : R) : (a != 0) -> - root p x = root (p \scale a) (x / a). -Proof. -move=> Ha. -by rewrite !rootE horner_scaleX_poly mulrC (@mulrVK _ a _ x) // unitfE. -Qed. -*) -Lemma root_scale_2 (p : {poly R}) (a x : R) : - root p (a * x) = root (p \scale a) x. -Proof. by rewrite !rootE horner_scaleX_poly. Qed. -(* -Lemma root_reciprocal_1 (p : {poly R}) (x : R) : (x != 0) -> - root p x = root (reciprocal_pol p) (x^-1). -Proof. -move=> Hx. -rewrite !rootE horner_reciprocal1; last by rewrite unitfE. -rewrite GRing.mulrI_eq0 //; apply: GRing.lregX. -by apply/lregP. -Qed. -*) -Lemma root_reciprocal_2 (p : {poly R}) (x : R) : x != 0 -> - root p (x^-1) = root (reciprocal_pol p) x. -Proof. -move=> Hx. -rewrite !rootE horner_reciprocal ?unitfE//. -by rewrite mulrI_eq0 //; apply/lregX/lregP. -Qed. -(* -Lemma root_Mobius_1 (p : {poly R}) (x : R) (l r : R) : - (l != r) -> (x != l) -> (x != r) -> - root p x = root (Mobius p l r) ((r - x) / (x - l)). -Proof. -move=> Hlr Hxl Hxr. -rewrite /Mobius. -rewrite -root_shift_2 -(@mulrK _ (x - l) _ 1); last by rewrite unitfE subr_eq0. -rewrite mul1r -mulrDl addrA -(@addrA _ _ (-x) x) (@addrC _ (-x) x) addrA addrK. -rewrite -root_reciprocal_2. - rewrite invrM; last by rewrite unitfE invr_eq0 subr_eq0. - rewrite invrK -root_scale_2 mulrC divrK; - last by rewrite unitfE subr_eq0 eq_sym. - by rewrite -root_shift_2 -addrA (@addrC _ _ l) addrA addrK. - by rewrite unitfE subr_eq0 eq_sym. -apply: GRing.mulf_neq0. - by rewrite subr_eq0 eq_sym. -by rewrite invr_eq0 subr_eq0. -Qed. -*) - -(* TODO(rei): define as an instance of Mobius in pol.v? *) -Definition Mobius' (R : ringType) (p : {poly R}) (a b : R) : {poly R} := -(* Mobius (size p).-1 a b p.? *) - reciprocal_pol ((p \shift a) \scale (b - a)) \shift 1. - -Lemma root_Mobius'_2 (p : {poly R}) (x : R) (l r : R) : - x + 1 != 0 -> - root p ((r + l * x) / (x + 1)) = root (Mobius' p l r) x. -Proof. -move=> Hx. -rewrite /Mobius -root_shift_2 -root_reciprocal_2 //. -rewrite -root_scale_2 -root_shift_2 -{3}(@mulrK _ (x + 1) _ l). - by rewrite -mulrDl {2}(@addrC _ x 1) mulrDr mulr1 addrA - -(addrA r (- l) l) (addrC (-l) l) addrA addrK. -by rewrite unitfE. -Qed. - -Lemma Mobius'M (p q : {poly R}) (l r : R) : - Mobius' (p * q) l r = Mobius' p l r * Mobius' q l r. -Proof. -by rewrite /Mobius' !rmorphM /= reciprocalM rmorphM. -Qed. - -Lemma Mobius'_Xsubc (c l r : R) : (l != r) -> - Mobius' ('X - c%:P) l r = (l - c) *: 'X + (r - c)%:P. -Proof. -move=> Hlr. -rewrite /Mobius' rmorphB /= shift_polyC rmorphB /= scaleX_polyC - /shift_poly comp_polyX rmorphD /= scaleX_polyC /scaleX_poly - comp_polyX -addrA -(rmorphB _ l c) /= reciprocal_monom. - by rewrite rmorphD rmorphM /= comp_polyX !comp_polyC - mulrDl polyC1 mul1r mulrC mul_polyC -addrA (addrC (l - c)%:P _) - -rmorphD /= addrA addrNK. -by rewrite subr_eq0 eq_sym. -Qed. - -Lemma Mobius'_Xsubc_monic (c l r : R) : l != r -> l != c -> - (lead_coef (Mobius' ('X - c%:P) l r))^-1 *: (Mobius' ('X - c%:P) l r) = - 'X + ((r - c) / (l - c))%:P. -Proof. -move=> Hlr Hlc. -rewrite Mobius'_Xsubc // lead_coefE. -have Hlc2 : (l - c) != 0 by rewrite subr_eq0. -have HlcP : ((l - c)%:P == 0) = false. - apply/eqP/eqP. - by rewrite polyC_eq0 subr_eq0. -have Hsize : size ((l - c) *: 'X + (r - c)%:P) = 2%N. - by rewrite -(mul_polyC (l - c) 'X) size_MXaddC HlcP /= size_polyC Hlc2. -have Hcoef1 : ((l - c) *: 'X + (r - c)%:P)`_1 = l - c. - by rewrite coefD coefC addr0 -mul_polyC coefMX coefC /=. -by rewrite Hsize -mul_polyC Hcoef1 mulrDr mul_polyC -rmorphM - mulrC -!mul_polyC mulrA (mulrC _ 'X) -rmorphM (mulrC _ (l - c)) - mulfV //= polyC1 mulr1. -Qed. - -End about_transformations. - -Section about_transformations_and_equality. - -Variable (R : idomainType). - -Lemma shift_poly_eq (p q : {poly R}) (a : R) : - (p == q) = (p \shift a == q \shift a). -Proof. -by rewrite /shift_poly -(subr_eq0 p q) -(@comp_poly2_eq0 _ (p-q) ('X + a%:P)) - ?size_XaddC // rmorphB subr_eq add0r. -Qed. - -Lemma scale_poly_eq (p q : {poly R}) (a : R) : (a != 0) -> - (p == q) = (p \scale a == q \scale a). -Proof. -move=> Ha. -by rewrite /scaleX_poly -(subr_eq0 p q) -(@comp_poly2_eq0 _ (p - q) ('X * a%:P)) - ?size_XmulC // rmorphB subr_eq add0r. -Qed. - -Lemma pdivmu0_0th_neq0 (p : {poly R}) : p != 0 -> (p %/ 'X^(\mu_0 p))`_0 != 0. -Proof. -move=> Hp. -have H0noroot : ~~(root (p %/ 'X^(\mu_0 p)) 0). - rewrite -mu_gt0. - rewrite -eqn0Ngt -(addr0 'X) -(@oppr0 {poly R}) -polyC0 mu_div - ?subn_eq0; by rewrite leqnn. - rewrite Pdiv.CommonIdomain.divp_eq0 negb_or Hp /= negb_or. - rewrite -size_poly_gt0 {1}size_polyXn /= -leqNgt dvdp_leq //. - by rewrite -(addr0 'X) -oppr0 -polyC0 root_mu. -rewrite -horner_coef0. apply: negbT. -by move/rootPf : H0noroot. -Qed. - -Lemma Mobius'0 (p : {poly R}) (a b : R) : a != b -> - (p == 0) = ((Mobius' p a b) == 0). -Proof. -move=> ab; apply/idP/idP => /eqP Hp. - by rewrite /Mobius' Hp /shift_poly /scaleX_poly !comp_polyC - reciprocalC comp_polyC. -rewrite /Mobius' in Hp. -rewrite (shift_poly_eq p 0 a) shift_polyC (@scale_poly_eq _ _ (b - a)). - by rewrite /scaleX_poly comp_polyC -reciprocal0 (shift_poly_eq _ _ 1) - shift_polyC Hp. -by rewrite subr_eq0 eq_sym. -Qed. - -End about_transformations_and_equality. - -From mathcomp Require Import complex. - -Section transformations_in_C. -Local Open Scope complex_scope. - -Variable (R : rcfType). -Local Notation C:= (complex R). - -Local Notation toC := (fun (p : {poly R}) => @map_poly R _ (real_complex R) p). - -Lemma shift_toC (p : {poly R}) (a : R) : toC (p \shift a) = (toC p) \shift a%:C. -Proof. -by rewrite /shift_poly (map_comp_poly _ p ('X + a%:P)) rmorphD /= - map_polyX map_polyC. -Qed. - -Lemma scale_toC (p : {poly R}) (a : R) : toC (p \scale a) = (toC p) \scale a%:C. -Proof. -by rewrite /scaleX_poly (map_comp_poly _ p ('X * a%:P)) rmorphM /= - map_polyX map_polyC. -Qed. - -Lemma reciprocal_toC (p : {poly R}) : - toC (@reciprocal_pol _ p) = reciprocal_pol (toC p). -Proof. -rewrite /reciprocal_pol poly_def rmorph_sum /= poly_def size_map_inj_poly. -- apply: eq_bigr => i _. - rewrite -mul_polyC rmorphM /= map_polyXn /=. - by rewrite !coef_map /= map_polyC /= mul_polyC. -- exact: complexI. -- by rewrite -complexr0. -Qed. - -Lemma Mobius'_toC (p : {poly R}) (l r : R) : - toC (Mobius' p l r) = Mobius' (toC p) l%:C r%:C. -Proof. -by rewrite {2}/Mobius' -shift_toC /= -rmorphB -scale_toC - -reciprocal_toC -shift_toC /Mobius. -Qed. - -(* -Lemma root_Mobius_C_1 : forall (p : {poly R}) (z : C) (l r : R), - (l != r) -> (z != l%:C) -> (z != r%:C) -> - root (toC p) z = - root (toC (Mobius p l r)) ((r%:C - z) / (z - l%:C)). -Proof. -move=> p z l r Hlr Hzl Hzr. -have HlrC : (l%:C != r%:C). - by rewrite -!complexr0 eq_complex /= negb_and eq_refl orbF. -rewrite !rootE Mobius_toC /Mobius -!rootE -@root_shift_2 - -(@mulrK _ (z - l%:C) _ 1). - rewrite mul1r -mulrDl addrA -(@addrA _ _ (-z) z) (@addrC _ (-z) z) addrA - addrK -root_reciprocal_2. - rewrite invrM. - rewrite invrK -root_scale_2 mulrC divrK. - by rewrite -root_shift_2 -addrA (@addrC _ _ l%:C) addrA addrK. - by rewrite unitfE subr_eq0 eq_sym. - by rewrite unitfE subr_eq0 eq_sym. - by rewrite unitfE invr_eq0 subr_eq0. - apply: GRing.mulf_neq0. - by rewrite subr_eq0 eq_sym. - by rewrite invr_eq0 subr_eq0. -by rewrite unitfE subr_eq0. -Qed. -*) - -Lemma root_Mobius'_C_2 (p : {poly R}) (z : C) (l r : R) : - z + 1 != 0 -> - root (toC p) ((r%:C + l%:C * z) / (z + 1)) = root (toC (Mobius' p l r)) z. -Proof. -move=> Hz. -rewrite !rootE Mobius'_toC /Mobius -!rootE -root_shift_2 -root_reciprocal_2 //. -rewrite -root_scale_2 -root_shift_2 -{3}(@mulrK _ (z + 1) _ l%:C). - by rewrite -mulrDl {2}(@addrC _ z 1) mulrDr mulr1 addrA - -(addrA r%:C (- l%:C) l%:C) (addrC (-l%:C) l%:C) addrA addrK. -by rewrite unitfE. -Qed. - -End transformations_in_C. - -Lemma mul_polyC_seqmul (R : rcfType) (p : {poly R}) (a : R) : - a != 0 -> - polyseq (a *: p) = seqmul (nseq (size p) a) p. -Proof. -move=> Ha; elim/poly_ind : p => [ | p c IHp]. - by rewrite size_poly0 /= seqmul0 -mul_polyC mulr0 -polyC0 polyseq0. -rewrite -{2}(cons_poly_def) -mul_polyC mulrDr mulrA mul_polyC -polyCM. -rewrite -!cons_poly_def !polyseq_cons. -case Hp : (nilp p); last first. - rewrite ifT; last first. - rewrite nil_poly in Hp. - by rewrite nil_poly -mul_polyC mulf_neq0 // ?Hp // polyC_eq0. - by rewrite seqmul_cons IHp. -rewrite ifF; last first. - rewrite nil_poly in Hp. - by rewrite nil_poly -mul_polyC mulf_eq0 Hp orbT. -rewrite /= size_polyC. -have [->|Hc] := eqVneq c 0; first by rewrite mulr0 seqmul0 polyseqC eq_refl. -by rewrite !polyseqC mulf_neq0//= Hc seqmul_cons. -Qed. - -Lemma changes_mulC (R : rcfType) (p : {poly R}) (a : R) : a != 0 -> - changes p = changes (a *: p). -Proof. -move=> Ha. -rewrite mul_polyC_seqmul //=. -case: p. -elim => [Hs//|b/=]. -case => [_ _ |c l IHcl Hs] //=. - by rewrite !addn0 !mulr0. -rewrite /= in IHcl. -rewrite IHcl //= /seqmul. -apply/eqP. -rewrite eqn_add2r !mulrA (mulrC a) -(mulrA b) -expr2 (mulrC _ (a^+2)) -mulrA - eq_sym. -by rewrite (@pmulr_rlt0 _ (a ^+2) (b * c)) // exprn_even_gt0. -Qed. - -Section thm_3_cercles_partie1. -Local Open Scope complex_scope. - -Variables (R : rcfType) (l r : R) (Hlr_le : l < r). - -Local Notation C := (complex R). - -Local Notation toC := (fun (p : {poly R}) => @map_poly R _ (real_complex R) p). - -Lemma HlrC : l%:C != r%:C. -Proof. by rewrite -!complexr0 eq_complex /= negb_and lt_eqF. Qed. - -Definition notinC (z : C) := - 0 <= (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 + r * l. - -Lemma notinC_Re_lt0_1 : forall (z : C), z != l%:C -> - notinC z = (Re ((r%:C - z) / (z - l%:C)) <= 0). -Proof. -case => a b Hab. -rewrite /notinC /=. -simpc. -rewrite !mulrA -(mulNr (b * b) _) -mulrDl - -expr2 (mulrDl r (-a) _) (mulrC r (a - l)) (mulrC (-a) _) (mulrDl _ _ r) - (mulrDl _ _ (-a)) mulrNN mulrN -expr2 !addrA (addrC (a * r) _) - -(addrA _ (a * r) _ ) (addrC (a * r) _ ) (mulrC a r) addrA - (addrC (- l * r) _ ) -(addrA _ (r * a) (l * a)) -(mulrDl _ _ a) - -(addrA (- a ^+2) _ _) (addrC (- l * r)) -!addrA (addrC _ (- b^+2)) - !addrA mulNr (mulrC l r) (addrC r l) -oppr_ge0 -[X in (_ = (0 <= X))]mulNr - !opprD !opprK pmulr_lge0 //. -rewrite invr_gt0 lt_neqAle addr_ge0 ?sqr_ge0 // andbT eq_sym paddr_eq0 ?sqr_ge0 // - negb_and !sqrf_eq0 subr_eq0. -by rewrite -complexr0 eq_complex negb_and /= in Hab. -Qed. - -Lemma notinC_Re_lt0_2 (z : C) : z + 1 != 0 -> - (notinC ((r%:C + l%:C * z) / (z + 1))) = (Re z <= 0). -Proof. -move=> Hz. -rewrite (@notinC_Re_lt0_1 ((r%:C + l%:C * z) / (z + 1))) /=. - rewrite -{1}(@mulrK _ (z+1) _ r%:C); last by rewrite unitfE. - rewrite -(mulNr (r%:C + l%:C * z) _ ) -(mulrDl _ _ (z+1)^-1) mulrDr mulr1 - opprD !addrA addrK -{3}(@mulrK _ (z+1) _ l%:C); last by rewrite unitfE. - rewrite -(mulNr (l%:C * (z+1)) _ ) -(mulrDl _ _ (z+1)^-1) mulrDr mulr1 - opprD !addrA addrK invrM. - rewrite invrK !mulrA -(mulrA _ _ (z+1)) (mulrC _ (z+1)) !mulrA mulrK; - last by rewrite unitfE. - rewrite -mulNr -mulrDl (mulrC _ z) mulrK //. - by rewrite unitfE subr_eq0 eq_sym HlrC. - by rewrite unitfE subr_eq0 eq_sym HlrC. - by rewrite -unitrV invrK unitfE. -rewrite -subr_eq0 -{2}(@mulrK _ (z + 1) _ l%:C); last by rewrite unitfE. -rewrite -mulNr -mulrDl mulrDr mulr1 opprD addrA addrK mulf_neq0 //. - by rewrite subr_eq add0r eq_sym HlrC. -by rewrite invr_eq0. -Qed. - -(* Theorem 10.47 i. *) -Theorem three_circles_1 (p : {poly R}) : - (forall (z : C), root (toC p) z -> (notinC z)) -> - changes (Mobius' p l r) = 0%N. -Proof. -move=> H. -have [/eqP|Hp0] := eqVneq p 0. - rewrite (@Mobius'0 _ p l r) ?lt_eqF// => /eqP ->. - by rewrite polyseq0. -rewrite (@changes_mulC R (Mobius' p l r) (lead_coef (Mobius' p l r))^-1). - apply: monic_roots_changes_eq0 => [ | z Hz]. - by rewrite monicE lead_coefZ mulrC -unitrE unitfE lead_coef_eq0 - -Mobius'0 ?lt_eqF// Hp0. - case/altP : (z+1 =P 0) => [/eqP Hz2 | Hz2]. - rewrite addr_eq0 eq_complex in Hz2. - move/andP : Hz2; case => /eqP Hrez _. - by rewrite Hrez raddfN lerN10. - rewrite map_polyZ rootZ /= -?root_Mobius'_C_2 // in Hz. - rewrite -notinC_Re_lt0_2 //. - apply: H => //. - rewrite -complexr0 eq_complex /= negb_and eq_refl orbF. - by rewrite invr_eq0 lead_coef_eq0 -Mobius'0 ?lt_eqF// negbT. -by rewrite invr_eq0 lead_coef_eq0 -Mobius'0 ?lt_eqF// negbT. -Qed. - -End thm_3_cercles_partie1. - -Section thm_3_cercles_partie2. -Variable R : rcfType. - -Local Notation C := (complex R). - -Definition inC1 := fun (l r : R) (z : C) => - (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 - - (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0. - -Definition inC2 := fun (l r : R) (z : C) => - (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 + - (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0. - -Definition inC12 := fun (l r : R) (z : C) => - ((Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 - - (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0) || - ((Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 + - (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0). - -Lemma inC1_or_inC2 (l r : R) (z : C) : - (inC1 l r z) || (inC2 l r z) = (inC12 l r z). -Proof. by []. Qed. - -Definition inB1 (z : C) := - (Re z - 1 <= 0) && ((Im z)^+2 <= 3%:R * (Re z - 1) ^+2). - -Lemma inB_inB1 : forall (z : C), inB z = inB1 (z + 1). -Proof. -case => a b. -by rewrite /inB1 /= addrK addr0 /inB. -Qed. - -Lemma inB1_help : forall (z : C), (inB1 z) = - (((Num.sqrt 3%:R) * (Re z - 1) - Im z <= 0) && - (0 <= - (Num.sqrt 3%:R * (Re z - 1)) - Im z)). -Proof. -case=> a b. -rewrite /inB1 /=. -case/altP : (a - 1 =P 0) => Ha. - rewrite Ha /= mulr0 oppr0 add0r lexx/= (expr2 0) !mulr0. - by rewrite -eq_le oppr_eq0 -sqrf_eq0 eq_le sqr_ge0 andbT. -rewrite -{1}(sqr_sqrtr (a:=3%:R)); last by apply: ler0n. -rewrite -exprMn -(ler_sqrt (b^+2)). - rewrite !sqrtr_sqr normrM (ger0_norm (x := Num.sqrt 3%:R)); - last by apply: sqrtr_ge0. - apply/idP/idP => /andP [] => H1 H2. - rewrite -(normrN (a - 1)) (gtr0_norm (x:= - (a - 1))) in H2. - by rewrite ler_norml mulrN opprK -subr_le0 - -[X in (_ && X)]subr_ge0 in H2. - by rewrite oppr_gt0 lt_def H1 eq_sym Ha. - have Hb : `|b| <= Num.sqrt 3%:R * -(a - 1). - by rewrite ler_norml mulrN opprK -subr_le0 -[X in (_ && X)]subr_ge0 H1 H2. - have Ha2 : (0 <= - (a - 1)). - rewrite -(pmulr_lge0 (x:=Num.sqrt 3%:R)); last by rewrite sqrtr_gt0 ltr0n. - by rewrite mulrC (@le_trans _ _ `| b |). - by rewrite -oppr_ge0 Ha2 /= -(normrN (a-1)) (ger0_norm (x:= -(a-1))). -by rewrite exprMn mulr_ge0 // ?sqr_ge0//. -Qed. - -Lemma Re_invc (z : C) : Re z^-1 = Re z / ((Re z) ^+ 2 + (Im z) ^+2). -Proof. by case: z. Qed. - -Lemma Im_invc : forall (z : C), Im z^-1 = (- Im z) / ((Re z) ^+ 2 + (Im z) ^+2). -Proof. by case => a b; rewrite mulNr. Qed. - -Lemma inB1_notinC1201 : forall (z : C), z != 0 -> inB1 z = ~~ inC12 0 1 (z ^-1). -Proof. -case=> a b Hz. -rewrite -inC1_or_inC2 negb_or inB1_help /=. -have H : a ^+ 2 + b ^+ 2 \is a GRing.unit. - rewrite eq_complex /= negb_and in Hz. - case/orP: Hz=> H; - by rewrite unitfE paddr_eq0 ?sqr_ge0 // negb_and !sqrf_eq0 H ?orbT. -have H3 : (Num.ExtraDef.sqrtr (GRing.natmul (V:=R) (GRing.one R) (3))) - \is a GRing.unit. - by rewrite unitfE sqrtr_eq0 -ltNge ltr0n. -rewrite /inC1 /= -leNgt add0r oppr0 mul0r !addr0 !mul1r. -rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA - exprMn -(mulNr b) exprMn sqrrN -mulrDl - (expr2 ((a^+2 + b^+2)^-1)) -{2}(mulr1 (a^+2 + b^+2)) -invrM // - -mulf_div [x in (0 <= _ + x + _)]mulrC !mulrA (mulrK (x:=(a^+2 + b^+2))) //. -rewrite -[in x in _ = x](mulNr a) -mulrDl. -rewrite -{5}(opprK 1) -(opprD a (- 1)) -mulrA -invrM //. -rewrite -[in x in _ = x]mulNr -(mul1r ( - (a - 1) / (a ^+ 2 + b ^+ 2))) - -{5}(@mulrK _ (Num.sqrt 3%:R) _ 1) //. -rewrite mul1r mulf_div -mulrDl mulrN -[in x in (_ = x)]opprD. -rewrite /inC2 /= -leNgt add0r oppr0 mul0r !addr0 !mul1r. -rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA - exprMn -(mulNr b) exprMn sqrrN -mulrDl - (expr2 ((a^+2 + b^+2)^-1)) -{3}(mulr1 (a^+2 + b^+2)) -invrM // - -mulf_div [x in (0 <= _ + x + _)]mulrC !mulrA (mulrK (x:=(a^+2 + b^+2))) // - -[in x in (_ = _ && x)]mulNr -mulrDl -{8}(opprK 1) -(opprD a (- 1)) -mulrA - -invrM //. -rewrite -(mul1r ( - (a - 1) / (a ^+ 2 + b ^+ 2))) - -{8}(@mulrK _ (Num.sqrt 3%:R) _ 1) //. -rewrite mul1r mulf_div -mulrDl mulNr oppr_ge0 pmulr_lge0. - rewrite pmulr_lle0 ?mulrN //. - by rewrite invr_gt0 lt_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 // - addr_ge0 // sqr_ge0. -by rewrite invr_gt0 lt_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 // - addr_ge0 // sqr_ge0. -Qed. - -Local Open Scope complex_scope. - -Lemma notinC1201_lr_scale (l r : R) : forall (z : C), l != r -> - ~~ inC12 0 1 z = ~~ inC12 0 (r - l) ((r - l)%:C * z). -Proof. -case=> a b Hlr. -rewrite !/inC12. simpc. rewrite /=. -rewrite !exprMn !(mulrA (r - l) _ a) !(mulrA (r - l) _ b) - -expr2 -(mulrN _ a) -mulrA -(mulrN _ (b / Num.sqrt 3%:R)) - -!(mulrDr ((r - l)^+2)) !negb_or -!leNgt. -by rewrite !pmulr_rge0 // lt_def sqr_ge0 sqrf_eq0 subr_eq0 eq_sym Hlr. -Qed. - -Lemma notinC12lr_shift (l r : R) : forall (z : C), l != r -> - ~~ inC12 0 (r - l) z = ~~ inC12 l r (z + l%:C). -Proof. -case=> a b Hlr. -rewrite !/inC12. simpc. rewrite /= !negb_or -!leNgt. -by rewrite (expr2 (a+l)) (mulrDl a l) !mulrDr (mulrDl l r) - (mulrDl l r) -!expr2 !opprD - [l * a + _]addrC !addrA addrK -(addrA _ (- (r * a)) _) - (addrC (- (r * a)) _) !addrA addrK -(addrA _ (a * l) _) - (addrC (a * l)) (mulrC a l) -{5 9}(opprK l) mulNr -opprD - -mulrDl [X in (_ = (0 <= X) && _)]addrC [X in (_ = _ && (0 <= X))]addrC - !addrA (addrC (l * r)) -(addrA _ (l * r) _) - (addrC (l * r)) (mulrC l r) !addrA addrK. -Qed. - -Lemma inB_notinC12 (l r : R) (z : C) : l != r -> z + 1 != 0 -> - inB z = ~~ inC12 l r ((r%:C + l%:C * z) / (z + 1)). -Proof. -move=> Hlr Hz. -have H : (r%:C + l%:C * z) / (z + 1) = ((r - l)%:C / (z + 1) + l%:C). - rewrite -{2}[l%:C](@mulrK _ (z + 1)); last by rewrite unitfE. - by rewrite -mulrDl {2}[z+1]addrC mulrDr mulr1 rmorphB /= !addrA addrNK. -by rewrite H -notinC12lr_shift // -notinC1201_lr_scale // - -inB1_notinC1201 // -inB_inB1. -Qed. - -Lemma changes_nseq : forall (s : seq R) (a : R), a != 0 -> - changes (seqmul (nseq (size s) a) s) = changes s. -Proof. -elim => [ | c l IHl a Ha] //. -case : l IHl => [IH |b l IHbl ] //. - by rewrite /= !mulr0 addn0. -have -> : (changes [::c, b & l]) = ((c * b < 0)%R + changes [:: b & l])%N. - by []. -rewrite -(IHbl a) //. -suff : ((a * c) * (a * b) < 0) = (c * b < 0) by move=> <-. -rewrite (mulrC a b) -mulrA (mulrC a) -!mulrA -expr2 mulrA. -by rewrite pmulr_llt0 // exprn_even_gt0. -Qed. - -Lemma seqn0_nseq : forall (s : seq R) (a : R), a != 0 -> - seqmul (nseq (size (seqn0 s)) a) (seqn0 s) = - seqn0 (seqmul (nseq (size s) a) s). -Proof. -elim => [ | c l IHl a Ha] //. -case Hc : (c != 0). - have Hac : a * c != 0 by apply: mulf_neq0. - by rewrite seqmul_cons /= Hac /= Hc /= seqmul_cons /= -IHl. -have Hac : (a * c != 0) = false by rewrite mulf_eq0 negb_or Ha Hc. -by rewrite seqmul_cons /= Hc /= Hac /= IHl. -Qed. - -Lemma inBneg1 : @inB R (-1). -Proof. -by rewrite /inB !raddfN lerN10 /= oppr0 sqrrN !expr2 mulr0 !mulr1 ler0n. -Qed. - -Local Notation toC := (fun (p : {poly R}) => @map_poly R _ (real_complex R) p). - -(* (~~ root p r) because of (~~ root (Mobius p l r) 0) *) -Theorem three_circles_2 (l r : R) (p : {poly R}) (a : R) : - ~~ root p r -> l < a < r -> ~~ root p a -> - (forall z : C, root (toC p) z -> ~~ inC12 l r z) -> - changes (seqn0 (Mobius' (p * ('X - a%:P)) l r)) = 1%N. -Proof. -move=> Hpnorootr /andP [] Hal Har Hpnoroota H. -have Hlr : l != r by rewrite lt_eqF// (lt_trans Hal). -have Hal2 : l != a by rewrite negbT // lt_eqF. -have [Hp|Hp] := eqVneq p 0. - have : false => //. - by rewrite -(andbN (root p a)) Hpnoroota Hp root0. -have Hlc1 : (lead_coef (Mobius' (R:=R) (p * ('X - a%:P)) l r))^-1 != 0. - rewrite invr_neq0 // Mobius'M lead_coefM mulf_neq0 //; - rewrite lead_coef_eq0 -Mobius'0 // negbT //. - exact: polyXsubC_eq0. -have Hl2 : lead_coef (Mobius' p l r) != 0 by rewrite lead_coef_eq0 -Mobius'0. -rewrite -(@changes_nseq _ - (lead_coef (Mobius' (p * ('X - a%:P)) l r)) ^-1) // - seqn0_nseq // -mul_polyC_seqmul //. -rewrite Mobius'M lead_coefM -mul_polyC invrM ?unitfE; [ | by [] |]; last first. - by rewrite lead_coef_eq0 -Mobius'0 // negbT // polyXsubC_eq0. -rewrite rmorphM /= mulrA mulrC !mulrA - (mulrC (Mobius' ('X - a%:P) _ _) _) - mul_polyC -mulrA mul_polyC mulrC - [in X in (changes (R:=R) (seqn0 (polyseq (_ * X))))] - (@Mobius'_Xsubc_monic R a l r Hlr Hal2) - -(opprK ((r - a) / (l - a))%:P) -polyCN. - apply: normal_changes. - by rewrite oppr_gt0 pmulr_rlt0 ?invr_lt0 ?subr_lt0 // subr_gt0. - apply: normal_root_inB => [ | z Hz]. - rewrite monicE lead_coef_lreg. - by rewrite mulrC -unitrE unitfE. - exact/lregP/invr_neq0. - have [/eqP Hz2|Hz2] := eqVneq (z + 1) 0. - rewrite addr_eq0 in Hz2. - by rewrite (eqP Hz2) inBneg1. - rewrite (inB_notinC12 Hlr) //. - rewrite -mul_polyC rmorphM /= map_polyC mul_polyC rootZ in Hz. - apply: H. - by rewrite root_Mobius'_C_2. - by rewrite /= eq_complex negb_and/= invr_neq0. -rewrite rootZ. - rewrite -root_Mobius'_2; last by rewrite add0r oner_neq0. - by rewrite mulr0 addr0 add0r invr1 mulr1. -exact: invr_neq0. -Qed. - -End thm_3_cercles_partie2. diff --git a/theories/xssralg.v b/theories/xssralg.v deleted file mode 100644 index 9af8ea7..0000000 --- a/theories/xssralg.v +++ /dev/null @@ -1,1166 +0,0 @@ -(* TODO(rei): remove this file? *) -From mathcomp Require Import ssreflect eqtype ssrbool ssrnat fintype seq ssrfun. -From mathcomp Require Import bigop (*groups*) choice. -From mathcomp Require Export ssralg. - -Set Implicit Arguments. -Unset Strict Implicit. -Import Prenex Implicits. - -(*Import GroupScope .*) -Import GRing.Theory . - -Local Open Scope ring_scope . - -Structure orderb (M : Type) (R : M -> M -> bool) : Type := Orderb { - reflb : reflexive R; - antisymb : antisymmetric R; - transb : transitive R -} . - -Structure sorderb (M : Type) (R : M -> M -> bool) : Type := SOrderb { - irreflsb : irreflexive R; - transsb : transitive R -} . - -Reserved Notation "x <<= y" (at level 70, no associativity) . -Reserved Notation "x < R -> bool) := - forall (x y₁ y₂ : R), r 0 x -> r y₁ y₂ -> r (x * y₁) (x * y₂) . - - Definition rcompatible (r : R -> R -> bool) := - forall (x y₁ y₂ : R), r 0 x -> r y₁ y₂ -> r (y₁* x) (y₂ * x) . - - -End Compatible . - - -(* -------------------------------------------------------------------- *) -Module GOrdered . - (* ------------------------------------------------------------------ *) - Module OComRing. - - Record mixin_of (G : GRing.Ring.type) : Type := Mixin { - leb : G -> G -> bool; - ltb : G -> G -> bool; - _ : sorderb ltb; - _ : forall x y, leb x y -> forall z, leb (x+z) (y+z); - _ : forall x y, leb x y = (ltb x y) || (x == y); - _ : forall x y, (leb x y) || (leb y x); - _ : lcompatible ltb - } . - - Record class_of (R : Type) : Type := Class { - base :> GRing.ComRing.class_of R; - mixin :> mixin_of (GRing.Ring.Pack base R) - } . - - - Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}. - - Definition class cT := let: Pack _ c _ := cT return class_of cT in c. - Definition unpack K (k : forall T (c : class_of T), K T c) cT := - let: Pack T c _ := cT return K _ (class cT) in k _ c. - Definition repack cT : _ -> Type -> type := - let k T c p := p c in unpack k cT. - - Definition pack := let k T c m := - Pack (@Class T c m) T in GRing.ComRing.unpack k. - - Definition eqType cT := Equality.Pack (class cT) cT. - Definition choiceType cT := Choice.Pack (class cT) cT. - Definition zmodType cT := GRing.Zmodule.Pack (class cT) cT. - Definition ringType cT := GRing.Ring.Pack (class cT) cT. - Coercion comringType cT := GRing.ComRing.Pack (class cT) cT. - - Definition EtaMixin R leb ltb ltr_sorderb leb_addr leb_ltb_eq leb_total ltb_lcompatible := - let _ := @Mixin R leb ltb ltr_sorderb leb_addr leb_ltb_eq leb_total ltb_lcompatible in - @Mixin (GRing.Ring.Pack (GRing.Ring.class R) R) leb ltb ltr_sorderb leb_addr leb_ltb_eq leb_total ltb_lcompatible. - - - End OComRing . - - Canonical Structure OComRing.eqType. - Canonical Structure OComRing.choiceType. - Canonical Structure OComRing.zmodType. - Canonical Structure OComRing.ringType. - Canonical Structure OComRing.comringType. - - Bind Scope comring_scope with OComRing.sort . - - Definition ltbDef (R : OComRing.type) : R -> R -> bool := OComRing.ltb (OComRing.class R). - Notation ltb := (@ltbDef _). - - Definition lebDef (R : OComRing.type) : R -> R -> bool := OComRing.leb (OComRing.class R). - Notation leb := (@lebDef _). - -(* Definition leb R := OComRing.leb (OComRing.class R).*) -(* Definition ltb R := OComRing.ltb (OComRing.class R).*) - - Local Notation "x <<= y" := (leb x y) . - Local Notation "x < [T [? []]] . Qed . - - Lemma ltr_irrefl : irreflexive (@ltbDef G). - Proof . by case ltr_sorderb . Qed . - - Lemma ltr_trans : transitive (@ltbDef G) . - Proof . by case ltr_sorderb . Qed . - - Lemma ltr_lcompat : lcompatible (@ltbDef G) . - Proof . by case G => [T [? []]] . Qed . - - Lemma ltr_rcompat : rcompatible (@ltbDef G). - Proof. by move=> x y z; rewrite mulrC [z * _]mulrC; exact: ltr_lcompat. Qed. - - - (* ------------------------------------------------------------------ *) - - Lemma ler_ltreq : forall x y, (x <<= y) = (x < [T [? []]]. Qed. -(* Proof . - move=> x y; rewrite ltr_lerne /negb; case D: (x == y) . - + by rewrite (eqP D) ler_refl . - + by rewrite orbF andbT . - Qed . -*) - - Lemma ler_refl : reflexive (@lebDef G) . - Proof. by move=> x; rewrite ler_ltreq eqxx orbT. Qed. - - Lemma ler_antisym : forall (x y : G), x <<= y -> y <<= x -> x = y . - Proof . - case: ltr_sorderb => h3 h4 x y; rewrite !ler_ltreq. - case/orP=> hxy; last by move/eqP: hxy. - case/orP=> hyx; last by move/eqP: hyx. - by move: (h4 _ _ _ hxy hyx); rewrite (h3 x). - Qed . - - Lemma ler_trans : transitive (@lebDef G) . - Proof . - case: ltr_sorderb=> h1 h2. - move=> x y z; rewrite !ler_ltreq; case/orP; last first. - move/eqP->; case/orP; by [move-> | move/eqP->; rewrite eqxx orbT]. - move=> hyx; case/orP; last by move/eqP<-; rewrite hyx. - by move=> hxz; rewrite (h2 _ _ _ hyx). - Qed. - - Lemma ler_order : orderb (@lebDef G) . - Proof . - constructor. - - exact: ler_refl. - - move=> x y; case/andP; exact: ler_antisym. - - exact: ler_trans. - Qed. - - Lemma ler_total : forall x y, (x <<= y) || (y <<= x) . - Proof . by case G => [T [? []]] . Qed . - - Lemma ler_lcompat : lcompatible (@lebDef G) . - Proof . - move=> x y z; rewrite !ler_ltreq => px. - case/orP; last by move/eqP->; rewrite eqxx orbT. - move=> hyz; case/orP: px => hx; first by rewrite ltr_lcompat. - by rewrite -(eqP hx) !mul0r eqxx orbT. - Qed. - - Lemma ler_rcompat : rcompatible (@lebDef G). - Proof. by move=> x y z; rewrite mulrC [z * _]mulrC; exact: ler_lcompat. Qed. - - Lemma eq_ler : forall x y, (x == y) = (x <<= y) && (y <<= x) . - Proof . - move=> x y; apply/idP/idP . - + by move/eqP => ->; rewrite ler_refl . - + by case/andP=> Hxy Hyx; rewrite (ler_antisym Hxy Hyx) . - Qed . - - (* ------------------------------------------------------------------ *) - - - - Lemma ltr_lerne : forall x y, (x < x y; rewrite ler_ltreq; case e: (x < //; rewrite (eqP exy) ltr_irrefl. - Qed . - - Lemma ltr_ne : forall x y, (x < (x != y) . - Proof. by move=> x y; rewrite ltr_lerne; case/andP. Qed. - - Lemma ltrW : forall x y, x < x <<= y . - Proof . by move=> x y H; rewrite ler_ltreq H . Qed . - - Lemma lerNgtr : forall x y, (x <<= y) = ~~ (y < x y; rewrite ltr_lerne eq_ler; case e: (y <<= x); rewrite ?negbK //=. - by move: (ler_total x y); rewrite e orbF. - Qed. - - Lemma ltr_ler_trans : - forall x y z, x < y <<= z -> x < x y z Hxy Hyz; rewrite ltr_lerne; apply/andP; split . - + by apply ler_trans with y; first apply ltrW . - + apply/eqP; move=> H; subst z . - rewrite ltr_lerne in Hxy; case/andP: Hxy => Hxy . - by rewrite eq_ler Hyz Hxy . - Qed . - - - Lemma ler_ltr_trans : forall x y z, - x <<= y -> y < x < x y z Hxy Hyz; rewrite ltr_lerne; apply/andP; split . - + by apply ler_trans with y; last apply ltrW . - + apply/eqP; move=> H; subst z . - rewrite ltr_lerne in Hyz; case/andP: Hyz => Hyz . - by rewrite eq_ler Hyz Hxy . - Qed. - (* ------------------------------------------------------------------ *) - - Lemma ltrN : forall x y, x < ~~ (y < x y; case e: (y < //; move/(ltr_trans e); rewrite ltr_irrefl. - Qed. - - - Lemma ltrNger : forall x y, (x < x y; rewrite lerNgtr negbK . - Qed . - - (* ------------------------------------------------------------------ *) - Lemma lerTl : forall x y, x <<= y -> forall z, x+z <<= y+z . - Proof . by case G => T [? []] . Qed . - - Lemma lerTr : forall x y, x <<= y -> forall z, z+x <<= z+y . - Proof . - by move=> x y Hxy z; rewrite ![z+_]addrC; apply lerTl . - Qed . - - Lemma lerTlb : forall z x y, (x+z <<= y+z) = (x <<= y) . - Proof . - move=> z x y; apply /idP/idP => H; last by apply lerTl . - rewrite -[x](addr0) -(addrN z) -[y](addr0) -(addrN z) . - by rewrite !addrA; apply lerTl . - Qed . - - Lemma lerTrb : forall z x y, (z+x <<= z+y) = (x <<= y) . - Proof . by move=> z x y; rewrite ![z+_]addrC; apply lerTlb . Qed . - - (* ------------------------------------------------------------------ *) - Lemma ltrTl : forall x y, x < forall z, x+z < x y H z; rewrite ltr_lerne; apply/andP; split . - + by apply lerTl; apply ltrW . - + rewrite ltr_lerne in H; case/andP: H => _ H . - by apply/eqP => Hz; rewrite (addIr Hz) eqxx in H . - Qed . - - Lemma ltrTr : forall x y, x < forall z, z+x < x y Hxy z; rewrite ![z+_]addrC; apply ltrTl . - Qed . - - Lemma ltrTlb : forall z x y, (x+z < z x y; apply/idP/idP => H; last by apply ltrTl . - rewrite -[x](addr0) -(addrN z) -[y](addr0) -(addrN z) . - by rewrite !addrA; apply ltrTl . - Qed . - - Lemma ltrTrb : forall z x y, (z+x < z x y; rewrite ![z+_]addrC; apply ltrTlb . Qed . - - (* ------------------------------------------------------------------ *) - Lemma lerT : - forall (x₁ y₁ x₂ y₂ : G), x₁ <<= y₁ -> x₂ <<= y₂ -> x₁ + x₂ <<= y₁ + y₂ . - Proof . - move=> x₁ y₁ x₂ y₂ Hx Hy; apply ler_trans with (x₁+y₂) . - by apply lerTr . by apply lerTl . - Qed . - - Lemma lerT0 : - forall (x y : G), 0 <<= x -> 0 <<= y -> 0 <<= x + y . - Proof . - by move=> x y Hx Hy; rewrite -[0]addr0; apply lerT . - Qed . - - - Lemma ler0T : - forall (x y : G), x <<= 0 -> y <<= 0 -> x + y <<= 0. - Proof . - by move=> x y Hx Hy; rewrite -[0]add0r; apply lerT . - Qed . - - Lemma ltrT : - forall (x₁ y₁ x₂ y₂ : G), x₁ < x₂ < x₁ + x₂ < x₁ y₁ x₂ y₂ H1 H2; apply ltr_ler_trans with (y₁ + x₂) . - - by apply ltrTl . - - by apply: lerT; rewrite ?ler_refl //; apply: ltrW. - Qed . - - Lemma ltr_lerT : - forall (x₁ y₁ x₂ y₂ : G), x₁ < x₂ <<= y₂ -> x₁ + x₂ < x₁ y₁ x₂ y₂ H1 H2; apply ltr_ler_trans with (y₁ + x₂) . - by apply ltrTl . by apply lerTr . - Qed . - - Lemma ltrT0 : - forall (x y : G), 0 < 0 < 0 < x y Hx Hy; rewrite -[0]addr0; apply ltrT => //. - Qed . - - Lemma ltr0T : - forall (x y : G), x < y < x + y < x y Hx Hy; rewrite -[0]add0r; apply ltrT . - Qed . - - - - (* ------------------------------------------------------------------ *) - Lemma ler_oppger : forall x y, (-x <<= -y) = (y <<= x) . - Proof . - move=> x y; rewrite -(lerTlb x) addNr -(lerTrb y) . - by rewrite addrA addrN addr0 add0r . - Qed . - - Lemma le0r_geNr0 : forall x, (0 <<= -x) = (x <<= 0) . - Proof . by move => x; rewrite -{1}oppr0 ler_oppger . Qed . - - Lemma ger0_leNr0 : forall x, (0 <<= x) = (- x <<= 0). - Proof. by move=> x; rewrite -{2}oppr0 ler_oppger. Qed. - - Lemma ltr_oppgtr : forall x y, (-x < x y . - rewrite !ltr_lerne ler_oppger; case (y <<= x) => //= . - apply congr1; apply/eqP/eqP => [H|->//] . - by rewrite -[y]opprK -[x]opprK H . - Qed . - - Lemma lt0r_gtNr0 : forall x, (0 < x; rewrite -{1}oppr0 ltr_oppgtr . Qed . - - Lemma gtr0_ltNr0 : forall x, (0 < x; rewrite -[x]opprK lt0r_gtNr0 opprK. Qed. - - Lemma opp_ler_ler0 : forall x, ( -x <<= x) = (0 <<= x). - Proof. - move=> x;rewrite -(lerTlb x) addNr. - case e : (0 <<= x); first by rewrite lerT0 //. - by apply: negbTE; rewrite lerNgtr negbK ltr0T // ltrNger e. - Qed. - - Lemma opp_lrr_lrr0 : forall x, ( -x < x;rewrite -(ltrTlb x) addNr. - case e : (0 < x;rewrite -(lerTlb x) addNr. - case e : (x <<= 0); first by rewrite ler0T //. - by apply: negbTE; rewrite lerNgtr negbK ltrT0 // ltrNger e. - Qed. - - Lemma lrr_opp_lrr0 : forall x, ( x < x;rewrite -(ltrTlb x) addNr. - case e : (x < 0 <<= y -> 0 <<= x * y . - Proof . - by move=> x y Hx Hy; rewrite -[0](mulr0 x); apply ler_lcompat . - Qed . - - Lemma ler_neg0_lcompat : forall x y, x <<= 0 -> y <<= 0 -> 0 <<= x * y . - Proof . - move=> x y Hx Hy . - by rewrite -mulrNN; apply ler_0_lcompat; rewrite le0r_geNr0 . - Qed . - - Lemma ltr_0_1 : 0 < // H . - by rewrite -[1](mulr1 1); apply ler_neg0_lcompat . - Qed . - - - (* ------------------------------------------------------------------ *) - Lemma ler_add_0l : forall x y, 0 <<= x -> 0 <<= y -> x+y = 0 -> x = 0 . - Proof . - move=> x y Hx Hy; move/(congr1 (+%R^~ -y)) . - rewrite -addrA addrN addr0 add0r; move=> H; subst x . - rewrite -ler_oppger oppr0 in Hy . - by apply/eqP; rewrite eq_ler Hx Hy . - Qed . - - Lemma ler_add_0r : forall x y, 0 <<= x -> 0 <<= y -> x+y = 0 -> y = 0 . - Proof . - move=> x y Hx Hy Hxy; apply ler_add_0l with x => // . - by rewrite addrC . - Qed . - - (* ------------------------------------------------------------------ *) - CoInductive ler_xor_gtr (x y : G) : bool -> bool -> Set := - | LerNotGtr of x <<= y : ler_xor_gtr x y true false - | GtrNotLer of y < bool -> Set := - | LtrNotGer of x < x y; rewrite ltrNger; case Hxy: (x <<= y); constructor=> // . - by rewrite ltrNger Hxy . - Qed. - - Lemma ltrP : forall x y, ltr_xor_ger x y (x < x y; rewrite lerNgtr; case Hxy: (x < // . - by rewrite lerNgtr Hxy . - Qed . - - CoInductive compare x y : bool -> bool -> bool -> Set := - | CompareLt of x < x y; rewrite ltrNger eq_ler andbC ltr_lerne . - case: ltrP; [by constructor | rewrite ler_ltreq; case: lerP => //=] . - + by move=> _; move/eqP => ->; rewrite eqxx; constructor . - + by move=> Hxy _; rewrite (ltr_ne Hxy); constructor . - Qed . - - Lemma ltrNgtr : forall x y, x < ~~(y < x y; case: compareP . Qed . - - (* ------------------------------------------------------------------ *) - - Lemma χ0_ltr : forall n, (0 : G) < [|n IH]; [apply ltr_0_1 | rewrite 2!mulrS; apply ltrTr] . - elim=> [|n IH]; [by apply ltr_0_1 | apply: ltr_trans] . - by apply IH . by rewrite 2!mulrS; apply ltrTr; apply HnSn . - Qed . - - Lemma χ0 : forall n, 1 *+ n.+1 != 0 :> G. - Proof . - move=> n; case D: (n.+1%:R == 0) => //= . - by move/eqP: D => D; have H := χ0_ltr n; rewrite D ltr_irrefl in H . - Qed . - - - Lemma sign_posR : forall x, 0 < sign x = 1 . - Proof . by move=> x hx; rewrite /sign hx. Qed. - - - Lemma sign_negR : forall x, x < sign x = -1 . - Proof . by move=> x hx; rewrite /sign hx (negbTE (ltrN hx)). Qed. - - Lemma sign0 : sign 0 = 0 :> G. - Proof . by rewrite /sign !ltr_irrefl . Qed . - - Lemma sign0P : forall x, reflect (sign x = 0) (x == 0) . - Proof . - move=> x; rewrite /sign; case: (compareP 0 x)=> H; last first. - + by rewrite -H eqxx; constructor. - + rewrite (negbTE (ltr_ne H)); constructor. - by apply/eqP; rewrite oppr_eq0 nonzero1r. - + rewrite eq_sym (negbTE (ltr_ne H)); constructor. - by apply/eqP; rewrite nonzero1r. - Qed. - - - Lemma sign_codomP : - forall x, [\/ sign x = 1, sign x = -1 | sign x = 0] . - Proof . - move=> x; case: (compareP 0 x) => H; [apply Or31 | apply Or32 | apply Or33] . - - by apply: sign_posR. - - by apply: sign_negR. - - by rewrite -H sign0 . - Qed . - - - (* ------------------------------------------------------------------ *) - Lemma absr_nneg : forall x, 0 <<= x -> absr x = x . - Proof . - move=> x Hx; rewrite /absr ltrNger . - - by case D: (0 <<= x) => //=; rewrite Hx in D . - Qed . - - Lemma absr_npos : forall x, x <<= 0 -> absr x = -x . - Proof . - move=> x Hx; rewrite /absr ltrNger; case Hx': (0 <<= x) => //= . - have Hx0: x = 0 by apply/eqP; rewrite eq_ler Hx Hx' . - by rewrite Hx0 oppr0 . - Qed . - - Lemma absr_neg : forall x, x < absr x = -x . - Proof . by move=> x Hx; apply absr_npos; apply ltrW . Qed . - - Lemma absr0 : absr 0 = 0 :> G . - Proof . by rewrite /absr ltr_irrefl . Qed . - - Lemma absrpos : forall x, 0 <<= absr x . - Proof . - move=> x; case: (ltrP x 0) => H . - + by rewrite absr_neg // le0r_geNr0; apply ltrW . - + by rewrite absr_nneg. - Qed . - - Lemma absrK : forall x, absr (absr x) = absr x . - Proof . by move=> x; rewrite absr_nneg // absrpos . Qed . - - Lemma absr_oppr : forall x, absr(-x) = absr x. - Proof. - move=> x. - case a : (0 < a'; rewrite (absr_npos a'). - by rewrite absr_nneg // -ler_oppger opprK oppr0. - Qed. - - Lemma absr_sign : forall x , (absr x) = (sign x) * x . - Proof . - move=> x; case: (compareP x 0) => h. - + by rewrite /absr h; move/sign_negR: h=> ->; rewrite mulN1r. - + by rewrite absr_nneg ?ltrW //; move/sign_posR: h=> ->; rewrite mul1r . - + by rewrite h sign0 absr0 mul0r. - Qed . - - - - Lemma absr_addr : - forall x y, absr (x + y) <<= (absr x) + (absr y). - move=> x y; rewrite !absr_sign. - case: (compareP x 0) => hx. - - rewrite (sign_negR hx) mulN1r; case: (compareP y 0) => hy. - + rewrite (sign_negR hy) mulN1r mulr_addr. - rewrite (_ : sign _ = -1) ?mulN1r ?ler_refl //; apply: sign_negR. - by apply: ltr0T. - + rewrite (sign_posR hy) mul1r ; case: (compareP (x + y) 0) => hxy. - * by rewrite (sign_negR hxy) mulr_addr !mulN1r lerTrb opp_ler_ler0 ltrW. - * by rewrite (sign_posR hxy) mul1r lerTlb ler_opp_ler0 ltrW. - * by rewrite hxy sign0 mul0r lerT0 // ?le0r_geNr0 ltrW. - + by rewrite hy mulr0 !addr0 (sign_negR hx) mulN1r ler_refl. - - rewrite (sign_posR hx) mul1r; case: (compareP y 0) => hy. - + rewrite (sign_negR hy) mulN1r mulr_addr; case: (compareP (x + y) 0) => hxy. - * by rewrite (sign_negR hxy) !mulN1r lerTlb opp_ler_ler0 ltrW. - * by rewrite (sign_posR hxy) !mul1r lerTrb ler_opp_ler0 ltrW. - * by rewrite hxy sign0 !mul0r addr0 lerT0 // ?le0r_geNr0 ltrW. - + rewrite (sign_posR hy) mul1r (_ : sign _ = 1) ?mul1r ?ler_refl //. - by apply: sign_posR; apply: ltrT0. - + by rewrite hy mulr0 !addr0 (sign_posR hx) mul1r ler_refl. - - by rewrite hx mulr0 !add0r ler_refl. - Qed. - - -Lemma absr_lt : forall x y, absr x < x < x y h. -have py : 0 < h2. -- by rewrite (ltr_trans h2). -- by rewrite -[x]absr_nneg // ltrW. -- by rewrite h2. -Qed. - -Lemma absr_le : forall x y, absr x <<= y -> x <<= y. -Proof. -move=> x y h. -have py : 0 <<= y by apply: (ler_trans (absrpos x)). -case: (compareP x 0) => h2. -- by rewrite ltrW // (ltr_ler_trans h2). -- by rewrite -[x]absr_nneg // ltrW. -- by rewrite h2. -Qed. - -Lemma lt_absr : forall x y, absr x < - y < x y h. -have py : 0 < h2. -- by rewrite -[x]opprK ltr_oppgtr -[- x]absr_npos // ltrW. -- by rewrite -[x]opprK -ltr_oppgtr !opprK; apply: ltr_trans py; rewrite -gtr0_ltNr0. -- by rewrite h2 -gtr0_ltNr0. -Qed. - -Lemma le_absr : forall x y, absr x <<= y -> - y <<= x. -Proof. -move=> x y h. -have py : 0 <<= y by apply: (ler_trans (absrpos x)). -case: (compareP x 0) => h2. -- by rewrite -[x]opprK ler_oppger -[- x]absr_npos // ltrW. -- by rewrite -[x]opprK -ler_oppger !opprK; apply: ler_trans py; rewrite -ger0_leNr0 ltrW. -- by rewrite h2 -ger0_leNr0. -Qed. - -(* ------------------------------------------------------------------ *) -Lemma ler_addl_abs : - forall x₁ x₂, x₁ <<= x₂ -> - forall y, (absr y) <<= (x₂ - x₁) -> - x₁ <<= x₂ + y . -Proof. -move=> x1 x2 hx12 y; move/le_absr. rewrite -(@lerTlb x2) addrC oppr_add opprK. -by rewrite addrA addrN add0r addrC. -Qed. - - - Lemma ler0_addl_abs : - forall x y, 0 <<= x -> (absr y) <<= x -> 0 <<= x + y . - Proof . - by move=> x y Hx Hy; apply ler_addl_abs; last rewrite oppr0 addr0 . - Qed . - End OComringTheory . - -(* - Module OField . - - Record class_of (R : Type) : Type := Class { - base1 :> GRing.Field.class_of R; - ext :> OComRing.mixin_of (GRing.Field.Pack base1 R) - } . - -(* Coercion base2 R m := OComRing.Class (@ext R m).*) - Coercion base2 R m := @OComRing.Class R _ (@ext R m). - - - Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}. - - Definition class cT := let: Pack _ c _ := cT return class_of cT in c. - Definition unpack K (k : forall T (c : class_of T), K T c) cT := - let: Pack T c _ := cT return K _ (class cT) in k _ c. - Definition repack cT : _ -> Type -> type := - let k T c p := p c in unpack k cT. - -(* Mixin here ? *) - Definition pack := - let k T c m := Pack (@Class T c m) T in GRing.Field.unpack k. - - Definition eqType cT := Equality.Pack (class cT) cT. - Definition choiceType cT := Choice.Pack (class cT) cT. - Definition zmodType cT := GRing.Zmodule.Pack (class cT) cT. - Definition ringType cT := GRing.Ring.Pack (class cT) cT. - Definition unitRingType cT := GRing.UnitRing.Pack (class cT) cT. - Definition comRingType cT := GRing.ComRing.Pack (class cT) cT. - Definition comUnitRingType cT := GRing.ComUnitRing.Pack (class cT) cT. - Definition idomainType cT := GRing.IntegralDomain.Pack (class cT) cT. - Coercion fieldType cT := GRing.Field.Pack (class cT) cT. - Coercion oComRingType cT := OComRing.Pack (class cT) cT. - Definition oFieldType cT := - @OComRing.Pack (fieldType cT) (class cT) cT. - - End OField . - - Canonical Structure OField.eqType. - Canonical Structure OField.choiceType. - Canonical Structure OField.zmodType. - Canonical Structure OField.ringType. - Canonical Structure OField.comRingType. - Canonical Structure OField.unitRingType. - Canonical Structure OField.comUnitRingType. - Canonical Structure OField.idomainType. - Canonical Structure OField.fieldType. - - Bind Scope comring_scope with OField.sort . -*) - Module OField . - - Record class_of (R : Type) : Type := Class { - base1 :> GRing.Field.class_of R; - ext :> OComRing.mixin_of (GRing.Field.Pack base1 R) - } . - - Coercion base2 R m := @OComRing.Class R _ (@ext R m). - - Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}. - - Definition class cT := let: Pack _ c _ := cT return class_of cT in c. - Definition unpack K (k : forall T (c : class_of T), K T c) cT := - let: Pack T c _ := cT return K _ (class cT) in k _ c. - Definition repack cT : _ -> Type -> type := - let k T c p := p c in unpack k cT. - -(* Mixin here ? *) - Definition pack := - let k T c m := Pack (@Class T c m) T in GRing.Field.unpack k. - - Definition eqType cT := Equality.Pack (class cT) cT. - Definition choiceType cT := Choice.Pack (class cT) cT. - Definition zmodType cT := GRing.Zmodule.Pack (class cT) cT. - Definition ringType cT := GRing.Ring.Pack (class cT) cT. - Definition unitRingType cT := GRing.UnitRing.Pack (class cT) cT. - Definition comRingType cT := GRing.ComRing.Pack (class cT) cT. - Definition comUnitRingType cT := GRing.ComUnitRing.Pack (class cT) cT. - Definition idomainType cT := GRing.IntegralDomain.Pack (class cT) cT. - Coercion fieldType cT := GRing.Field.Pack (class cT) cT. - Coercion oComRingType cT := OComRing.Pack (class cT) cT. - Definition oFieldType cT := - @OComRing.Pack (fieldType cT) (class cT) cT. - - End OField . - - Canonical Structure OField.eqType. - Canonical Structure OField.choiceType. - Canonical Structure OField.zmodType. - Canonical Structure OField.ringType. - Canonical Structure OField.comRingType. - Canonical Structure OField.unitRingType. - Canonical Structure OField.comUnitRingType. - Canonical Structure OField.idomainType. - Canonical Structure OField.fieldType. - Canonical Structure OField.oComRingType. - -Bind Scope ring_scope with OField.sort. - -Section OrderedFieldTheory. - - Variable G : OField.type . - Implicit Types x y : G. - - Lemma ltr_0_lcompat : forall x y, 0 < 0 < 0 < x y Hx Hy; rewrite ltr_lerne; apply/andP; split . - + by apply ler_0_lcompat; apply ltrW . - + rewrite eq_sym mulf_eq0 negb_or . - by rewrite ![_ == 0]eq_sym (ltr_ne Hx) (ltr_ne Hy) . - Qed . - - Lemma oppreq_0 : forall x, (x == -x) = (x == 0) . - Proof . - move=> x; apply/eqP/eqP => [|->]; last by rewrite oppr0 . - move/(congr1 (+%R x)); rewrite addrN -{1 2}[x](mul1r) -mulr_addl . - move/eqP; rewrite mulf_eq0; case/orP; last by move/eqP => -> . - by rewrite (negbTE (χ0 G 1%nat)). - Qed. - - Lemma sign_pos : forall x, reflect (sign x = 1) (0 < x; rewrite /sign; case: (compareP 0 x) => h; constructor => //. - + by apply/eqP; rewrite eq_sym oppreq_0 nonzero1r. - + by apply/eqP; rewrite eq_sym nonzero1r. - Qed . - - Lemma sign_neg : forall x, reflect (sign x = -1) (x < x; rewrite /sign; case: (compareP 0 x) => _; constructor=> // . - + apply/eqP; rewrite oppreq_0; exact: nonzero1r . - + move/(congr1 -%R); rewrite opprK oppr0; move/eqP . - by rewrite eq_sym (negbTE (nonzero1r _)) . - Qed . - - Lemma mulr_sign : forall x y, sign (x * y) = (sign x) * (sign y) . - Proof . - move=> x y; case: (compareP 0 x) . - + case: (compareP 0 y) => Hy Hx . - * by rewrite !sign_posR ?mul1r //; apply ltr_0_lcompat . - * rewrite [sign x]sign_posR // !sign_negR ?mul1r // . - rewrite -lt0r_gtNr0 -mulrN; apply ltr_0_lcompat => // . - by rewrite lt0r_gtNr0 . - * by rewrite -Hy mulr0 sign0 mulr0 . - + case: (compareP 0 y) => Hy Hx . - * rewrite [sign y]sign_posR // !sign_negR ?mulr1 // . - rewrite -lt0r_gtNr0 -mulNr; apply ltr_0_lcompat => // . - by rewrite lt0r_gtNr0 . - * rewrite [sign x]sign_negR // [sign y]sign_negR // . - rewrite sign_posR; first by rewrite ?mulrNN ?mulr1 . - by rewrite -mulrNN; apply ltr_0_lcompat; rewrite lt0r_gtNr0 . - * by rewrite -Hy mulr0 sign0 mulr0 . - + by move=> <-; rewrite mul0r sign0 mul0r . - Qed . - - (* ------------------------------------------------------------------ *) - - - Lemma invr_ltr : forall x, (0 < sign (x^-1 * x) = 1 . - + by move=> x Hx; rewrite mulVf // sign_posR // ltr_0_1 . - - have HP: forall x, 0 < 0 < x Hx; apply/sign_pos; rewrite -(Hsign x) . - * rewrite mulr_sign -{1}[sign x^-1]mulr1 . - by congr (_ * _); symmetry; apply/sign_pos . - * by rewrite eq_sym; apply (ltr_ne Hx) . - - move=> x; apply/idP/idP; last exact: HP . - by move=> Hx; rewrite -(invrK x); apply HP . - Qed . - - Lemma ler_Ilcompat_r : - forall x y₁ y₂, 0 < x * y₁ <<= x * y₂ -> y₁ <<= y₂ . - Proof . - move=> x y₁ y₂ Hx Hy . - rewrite -[y₁](mul1r) -[y₂](mul1r) -[1](@mulVf _ x) 1?eq_sym ?(ltr_ne Hx) //. - by rewrite -!mulrA; apply ler_lcompat => //; apply ltrW; rewrite invr_ltr . - Qed . - - Lemma ler_Ilcompat_l : - forall x y₁ y₂, 0 < y₁ * x <<= y₂ * x -> y₁ <<= y₂ . - Proof . - move=> x y₁ y₂; rewrite mulrC [y₂ * _]mulrC; exact: ler_Ilcompat_r. - Qed . - - Lemma ltr_Ilcompat_r : - forall x y₁ y₂, 0 < x * y₁ < y₁ < x y₁ y₂ Hx Hy . - rewrite -[y₁](mul1r) -[y₂](mul1r) -[1](@mulVf _ x) 1?eq_sym ?(ltr_ne Hx) //. - by rewrite -!mulrA; apply ltr_lcompat => //; rewrite invr_ltr . - Qed . - - Lemma ltr_Ilcompat_l : - forall x y₁ y₂, 0 < y₁ * x < y₁ < x y₁ y₂; rewrite mulrC [y₂ * _]mulrC; exact: ltr_Ilcompat_r. - Qed . - - - Lemma invr1_ltr0_ltr1 : forall x, 0 < (x < x hx; move:(hx); rewrite ltr_lerne eq_sym; case/andP=> hx1 hx2. - rewrite -{1}(divff hx2) -{1}(mulr1 x); case e: (1 < (1 < x hx; apply/idP/idP => h1. - apply: (ltr_Ilcompat_r hx); rewrite divff // ?mulr1 //. - by move: hx; rewrite ltr_lerne eq_sym; case/andP. - move:(hx); rewrite -invr_ltr=> hIx; apply: (ltr_Ilcompat_r hIx). - by rewrite mulr1 mulVf //; move: hx; rewrite ltr_lerne eq_sym; case/andP. - Qed. - - Lemma invr1_0ltr_ltr1I : forall x, x < (x < x; rewrite -(opprK x). - rewrite invrN !ltr_oppgtr -lt0r_gtNr0 opprK; exact: invr1_ltr0_1ltr. - Qed. - - Lemma invr1_0ltr_ltrI1 : forall x, x < (-1 < x; rewrite -(opprK x). - rewrite invrN !ltr_oppgtr -lt0r_gtNr0 opprK; exact: invr1_ltr0_ltr1. - Qed. - - (* We cannot define a theory of floor since some ordered comring do not have...*) - - (* ------------------------------------------------------------------ *) - Lemma Ndiscrete01 : exists x : G, (0 < // . - rewrite -(ltrTlb (-1)) addrN . - rewrite -{4}[1](@mulfV _ (1+1)); last exact: (χ0 _ 1) . - rewrite -mulNr -mulr_addl -mulN1r mulr_addr mulN1r . - by rewrite addrA addrN add0r mulNr -ltr_oppgtr oppr0 opprK . - Qed . - - Lemma Ndiscrete : forall x z, x < exists y, (x < x z Hxz; elim Ndiscrete01=> y; case/andP => Hylow Hyhi . - exists (y * (z-x) + x); apply/andP; split . - + rewrite -{1}[x]add0r ltrTlb; apply ltr_0_lcompat => // . - by rewrite -[0](addrN x) ltrTlb . - + rewrite -(ltrTlb (-x)) -addrA addrN addr0 . - rewrite mulrC -{2}[z-x]mulr1; apply ltr_lcompat => // . - by rewrite -[0](addrN x) ltrTlb . - Qed . - - - Lemma absr_mulr : - forall x y, absr (x * y) = (absr x) * (absr y) . - Proof . - move=> x y; rewrite !absr_sign mulr_sign . - by rewrite -[_ * x * _]mulrA -[x * (_ * _)]mulrCA !mulrA . - Qed . - - - -End OrderedFieldTheory. - -End GOrdered . - -Bind Scope comring_scope with GOrdered.OComRing.sort . - -Canonical Structure GOrdered.OComRing.eqType. -Canonical Structure GOrdered.OComRing.choiceType. -Canonical Structure GOrdered.OComRing.zmodType. -Canonical Structure GOrdered.OComRing.ringType. -Canonical Structure GOrdered.OComRing.comringType. - -Notation ocomringType := (GOrdered.OComRing.type) . -Notation OcomringType := (GOrdered.OComRing.pack) . -Notation OcomringMixin := (GOrdered.OComRing.Mixin) . - -Canonical Structure GOrdered.OField.eqType. -Canonical Structure GOrdered.OField.choiceType. -Canonical Structure GOrdered.OField.zmodType. -Canonical Structure GOrdered.OField.ringType. -Canonical Structure GOrdered.OField.comRingType. -Canonical Structure GOrdered.OField.unitRingType. -Canonical Structure GOrdered.OField.comUnitRingType. -Canonical Structure GOrdered.OField.idomainType. -Canonical Structure GOrdered.OField.fieldType. -Canonical Structure GOrdered.OField.oComRingType. - -Notation ofieldType := (GOrdered.OField.type) . -Notation OfieldType := (GOrdered.OField.pack) . - - -Notation "x <<= y" := (GOrdered.leb x y) . -Notation "x < R . - - Definition minB (x0 : R) (r : seq I) := - if (filter P r) is x::xs - then \big[minr/(F x)]_(i <- xs) (F i) - else x0 . - End MinB . - End Defs . -End Min . - -Notation minr := (@Min.minr _) . -Notation minB := (@Min.minB _ _) . - -Section MinTheory . - Variable R : ocomringType . - - Import GOrdered . - - Lemma minrC : commutative (@Min.minr R) . - Proof . by move=> x y; rewrite /minr; case: (compareP x y) . Qed . - - Lemma minrA : associative (@Min.minr R) . - move=> x y z; rewrite /minr . - (case: (compareP y z); last (move=> <-)); - (case: (compareP x y); last (move=> <-)); - try solve - [ by do! (move=> H; rewrite ?H ?(negbTE (ltrNgtr H)) => {H}) - | by rewrite ltr_irrefl ] . - + by move=> Hxy Hyz; rewrite (ltr_trans Hxy Hyz) . - + move=> Hyx Hzy; rewrite (negbTE (ltrNgtr Hzy)) . - by rewrite (negbTE (ltrNgtr (ltr_trans Hzy Hyx))) . - Qed . - - Lemma minrCA : left_commutative (@Min.minr R) . - Proof . - by move=> x y z; rewrite minrA [minr x y]minrC -minrA . - Qed . - - Lemma minrAC : right_commutative (@Min.minr R) . - Proof . - by move=> x y z; rewrite -minrA [minr y z]minrC minrA . - Qed . - - Lemma minrl : forall (x y : R), minr x y <<= x . - Proof . - by move=> x y; rewrite /minr; case: (ltrP x y); rewrite // ler_refl . - Qed . - - Lemma minrr : forall (x y : R), minr x y <<= y . - Proof . - by move=> x y; rewrite minrC; apply minrl . - Qed . - - Section minB . - Variable I : eqType . - Variable P : pred I . - Variable F : I -> R . - Variable x0 : R . - - Lemma minB_nil : minB P F x0 [::] = x0 . - Proof . by [] . Qed . - - Lemma minB_seq1 : forall x, P x -> minB P F x0 [:: x] = (F x) . - Proof . by move=> x H; rewrite /minB /filter H big_nil . Qed . - - Lemma minB_cons : - forall x xs, P x -> has P xs - -> minB P F x0 (x::xs) = minr (F x) (minB P F x0 xs) . - Proof . - move=> x xs HPx HPxs; rewrite {1}/minB /= HPx . - rewrite has_filter in HPxs; move/eqP: HPxs => HPxs . - rewrite /minB; case D: (filter P xs) => [|z₁ zs] {D HPx} // . - elim: zs x z₁ => [|z₂ zs IH] x z₁ . - + by rewrite unlock /= minrC . - + by rewrite big_cons !IH minrCA . - Qed . - - Lemma minB_head : - forall x xs, ~~ (has P xs) -> - minB P F x0 (x::xs) = (if P x then F x else x0) . - Proof . - move=> x xs HPxs; rewrite /minB /= . - rewrite has_filter negbK in HPxs; rewrite (eqP HPxs) . - by case (P x); rewrite ?big_nil . - Qed . - - Lemma minB_tail : - forall x xs, ~~ (P x) -> minB P F x0 (x::xs) = minB P F x0 xs . - Proof . - by move=> x xs HPx; rewrite {1}/minB /= (negbTE HPx) . - Qed . - - Lemma minB_empty : - forall xs, ~~ (has P xs) -> minB P F x0 xs = x0 . - Proof . - elim=> [|x xs IH] //= . - rewrite negb_orb; case/andP=> HPx HPxs . - by rewrite minB_tail // IH . - Qed . - - Lemma minBE : - forall (r : seq I), - forall z, z \in r -> P z -> minB P F x0 r <<= F z . - Proof . - elim=> [|x xs IH] // z Hmem Hpz . - rewrite in_cons in Hmem; case/orP: Hmem => [|Hz] . - + move/eqP => <-; case D: (has P xs) . - * by rewrite minB_cons // minrl . - * by rewrite minB_head /negb ?D // Hpz ler_refl . - + have Htail: has P xs by (apply/hasP; exists z) . - case D: (P x) . - * rewrite minB_cons //; apply: ler_trans . - by apply minrr . by apply IH . - * by rewrite minB_tail /negb ?D //; apply IH . - Qed . - - Lemma minBP : - forall d (r : seq I), has P r -> - exists i, - let x := nth d r i in - [/\ (i < size r), P x & (minB P F x0 r = F x)] . - Proof . - move=> d; elim=> [|x xs IH] //= H . - case Dhead: (P x); case Dtail: (has P xs) . - + rewrite minB_cons // /minr; case: ltrP => _ . - * by exists 0%N => // . - * by elim (IH Dtail)=> i [Hsize HPi Hmini]; exists i.+1 . - + exists 0%N; split=> // . - by rewrite minB_head ?Dhead //=; apply negbT . - + elim (IH Dtail)=> i [Hsize HPi Hmini]; exists i.+1 . - by split=> //=; rewrite minB_tail //; apply negbT . - + by rewrite Dhead Dtail in H . - Qed . - - Lemma minBI : - forall (r : seq I), has P r -> (minB P F x0 r) \in (map F r) . - Proof . - move=> r; move/hasP=> [d Hdr HPd]; elim (@minBP d r) . - + move=> n [Hsize HP Heq]; apply/nthP; exists n . - * by rewrite size_map . - * by rewrite Heq -(nth_map d x0) //; reflexivity . - + by apply/hasP; exists d . - Qed . - - Lemma min_fall_lt : - forall (r : seq I) x, has P r - -> (forall z, z \in r -> P z -> x < x < [|x xs IH] // z Hpz H . - case Dhead: (P x); case Dtail: (has P xs) . - + rewrite minB_cons // /minr; case: (ltrP (F x)) => D . - * by apply H => //; rewrite in_cons eqxx . - * by apply IH => // w Hw HPw; apply H => //; rewrite in_cons Hw orbT . - + rewrite minB_head /negb ?Dtail // Dhead . - by apply H => //; rewrite in_cons eqxx . - + rewrite minB_tail /negb ?Dhead //; apply IH => // . - by move=> w Hw HPw; apply H => //; rewrite in_cons Hw orbT . - + by rewrite /= Dhead Dtail in Hpz . - Qed . - - Lemma min_fall_le : - forall (r : seq I) x, has P r - -> (forall z, z \in r -> P z -> x <<= F z) - -> x <<= minB P F x0 r . - Proof . - elim=> [|x xs IH] // z Hpz H . - case Dhead: (P x); case Dtail: (has P xs) . - + rewrite minB_cons // /minr; case: (ltrP (F x)) => D . - * by apply H => //; rewrite in_cons eqxx . - * by apply IH => // w Hw HPw; apply H => //; rewrite in_cons Hw orbT . - + rewrite minB_head /negb ?Dtail // Dhead . - by apply H => //; rewrite in_cons eqxx . - + rewrite minB_tail /negb ?Dhead //; apply IH => // . - by move=> w Hw HPw; apply H => //; rewrite in_cons Hw orbT . - + by rewrite /= Dhead Dtail in Hpz . - Qed . - End minB . -End MinTheory . - -Notation "\minB_ ( i | P ) F" := - (minB (fun i => P%B) (fun i => F) 0 (index_enum _)) - (at level 36, F at level 36, i at level 50) . - -Notation "\minB_ ( i \in I | P ) F" - := (\minB_(i | (i \in I) && P) F) - (at level 36, F at level 36, i, A at level 50) . From 23c1914898d322638fd3550da9bb2d026890d6ec Mon Sep 17 00:00:00 2001 From: Thomas Portet Date: Mon, 17 Mar 2025 13:36:57 +0100 Subject: [PATCH 3/3] Revert "removing unused libraries and updating coqproject" This reverts commit 78b823072bb367bba55632ddbdc85ea301f48958. --- _CoqProject | 37 +- theories/axiomsKnuth.v | 35 + theories/bern.v | 404 +++++++ theories/bern5.v | 136 +++ theories/casteljau.v | 1846 ++++++++++++++++++++++++++++++ theories/civt.v | 449 ++++++++ theories/conv.v | 364 ++++++ theories/convex.v | 545 +++++++++ theories/counterclockwise.v | 380 ++++++ theories/desc.v | 1260 ++++++++++++++++++++ theories/desc1.v | 697 +++++++++++ theories/desc2.v | 601 ++++++++++ theories/door_crossing.v | 1133 ++++++++++++++++++ theories/encompass.v | 224 ++++ theories/generic_trajectories.v | 1139 ++++++++++++++++++ theories/hulls.v | 327 ++++++ theories/intersection.v | 371 ++++++ theories/isolate.v | 689 +++++++++++ theories/math_comp_complements.v | 346 ++++++ theories/pol.v | 1158 +++++++++++++++++++ theories/poly_normal.v | 1832 +++++++++++++++++++++++++++++ theories/preliminaries.v | 241 ++++ theories/preliminaries_hull.v | 280 +++++ theories/shortest_path.v | 71 ++ theories/shortest_path_proofs.v | 105 ++ theories/square_free.v | 119 ++ theories/three_circles.v | 756 ++++++++++++ theories/xssralg.v | 1166 +++++++++++++++++++ 28 files changed, 16706 insertions(+), 5 deletions(-) create mode 100644 theories/axiomsKnuth.v create mode 100644 theories/bern.v create mode 100644 theories/bern5.v create mode 100644 theories/casteljau.v create mode 100644 theories/civt.v create mode 100644 theories/conv.v create mode 100644 theories/convex.v create mode 100644 theories/counterclockwise.v create mode 100644 theories/desc.v create mode 100644 theories/desc1.v create mode 100644 theories/desc2.v create mode 100644 theories/door_crossing.v create mode 100644 theories/encompass.v create mode 100644 theories/generic_trajectories.v create mode 100644 theories/hulls.v create mode 100644 theories/intersection.v create mode 100644 theories/isolate.v create mode 100644 theories/math_comp_complements.v create mode 100644 theories/pol.v create mode 100644 theories/poly_normal.v create mode 100644 theories/preliminaries.v create mode 100644 theories/preliminaries_hull.v create mode 100644 theories/shortest_path.v create mode 100644 theories/shortest_path_proofs.v create mode 100644 theories/square_free.v create mode 100644 theories/three_circles.v create mode 100644 theories/xssralg.v diff --git a/_CoqProject b/_CoqProject index 43a581c..711b00d 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,15 +1,42 @@ +theories/shortest_path.v +theories/generic_trajectories.v +theories/smooth_trajectories.v +theories/convex.v +theories/preliminaries.v +theories/poly_normal.v +theories/pol.v +theories/civt.v +theories/desc.v +theories/desc1.v +theories/desc2.v +theories/bern.v +theories/bern5.v +theories/casteljau.v +theories/isolate.v +theories/square_free.v +theories/three_circles.v +theories/hulls.v +theories/intersection.v +theories/conv.v +theories/encompass.v +theories/counterclockwise.v +theories/axiomsKnuth.v +theories/preliminaries_hull.v theories/cells.v theories/cells_alg.v +theories/door_crossing.v theories/events.v -theories/first_degenerate_position.v -theories/general_position.v -theories/initial_cell.v +theories/extraction_command.v +theories/math_comp_complements.v +theories/no_crossing.v theories/opening_cells.v theories/points_and_edges.v theories/safe_cells.v -theories/second_degenerate_position.v +theories/general_position.v theories/simple_step.v -theories/smooth_trajectories.v +theories/initial_cell.v +theories/first_degenerate_position.v +theories/second_degenerate_position.v theories/step_correct.v -R theories trajectories diff --git a/theories/axiomsKnuth.v b/theories/axiomsKnuth.v new file mode 100644 index 0000000..6812757 --- /dev/null +++ b/theories/axiomsKnuth.v @@ -0,0 +1,35 @@ +From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals order. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. +Module Type KnuthAxioms. +Section Dummy. + +Variable R : realType. +Definition Plane : vectType _ := (R^o * R^o)%type. +Parameter OT : Plane -> Plane -> Plane -> bool. + +(*Knuth's axioms are given by the following variables. But axiom 4 is not used in Jarvis' algorithm and axiom 3 is a property of the data, not of the + plane. *) +Axiom Axiom1 : forall p q r, OT p q r -> OT q r p. + +Axiom Axiom2 : forall p q r, OT p q r -> ~ OT p r q. + +Axiom Axiom4 : forall p q r t, OT t q r -> OT p t r -> OT p q t -> OT p q r. + +Axiom Axiom5 : + forall t s p q r, OT t s p -> OT t s q -> OT t s r -> + OT t p q -> OT t q r -> OT t p r. + +Local Open Scope order_scope. +Axiom Axiom5' : forall (pivot p q r : Plane), + (pivot : R *l R) < p -> + (pivot : R *l R) < q -> + (pivot : R *l R) < r -> + OT pivot p q -> + OT pivot q r -> + OT pivot p r. + +End Dummy. +End KnuthAxioms. diff --git a/theories/bern.v b/theories/bern.v new file mode 100644 index 0000000..4e0d1bc --- /dev/null +++ b/theories/bern.v @@ -0,0 +1,404 @@ +From mathcomp Require Import all_ssreflect all_algebra archimedean. +(*Require Import QArith ZArith Zwf Omega. +From mathcomp Require Import ssreflect eqtype ssrbool ssrnat div fintype seq ssrfun order. +From mathcomp Require Import bigop fingroup choice binomial poly. +From mathcomp Require Export ssralg rat ssrnum. *) +Require Import pol desc. +(* Require Import infra pol civt desc. *) + +(* Import GroupScope . *) +Import Order.TTheory GRing.Theory Num.Theory. +Local Open Scope ring_scope . + +(* Set Printing Width 50. *) + +(******************************************************************************) +(* Two predicates to describe that a polynomial has only one root: *) +(* one_root1 l a b == there exists c, d, k, s.t. a, c, d, b are ordered, *) +(* k is positive, the polynomial value is positive *) +(* between a and c, negative between d and b, the slope *) +(* is less than -k between c and d; *) +(* This statement is specifically suited to speak about *) +(* roots inside the interval a b. *) +(* one_root2 l a == there exists c, d, k, s.t. a is smaller than c, *) +(* k is positive, the polynomial value is negative *) +(* between a and c, and the slope is larger than k above *) +(* c; *) +(* A consequence of one_root2 is that there can be only *) +(* one root above c, hence only one root above a. *) +(******************************************************************************) + +Local Open Scope order_scope . + +Definition one_root1 {R : archiFieldType} (p : {poly R}) (a b : R) := + exists c d k : R, [/\ [/\ a < c, c < d, d < b & 0 < k], + (forall x, a < x -> x <= c -> 0 < p.[x]), + (forall x, d < x -> x < b -> p.[x] < 0) & + (forall x y, c < x -> x <= y -> y < d -> k * (y - x) <= p.[x] - p.[y])]%R. + +Definition one_root2 {R : archiFieldType} (p : {poly R}) (a : R) := + exists c k : R, [/\ a < c, 0 < k, + (forall x, a < x -> x <= c -> p.[x] < 0) & + (forall x y, c <= x -> x < y -> k * (y - x) <= p.[y] - p.[x])]%R. + +Lemma alt_one_root2 (R : archiFieldType) (l : {poly R}) : alternate l -> + one_root2 l 0. +Proof. +move/desc => [[x1 k] /= [/andP[x1p kp] neg] sl]; exists x1, k; split => //. +- by move=> x xgt0 xlex1; apply: neg; rewrite xgt0 xlex1. +- by move=> x y xlex1 xlty; apply: sl; rewrite xlex1 (ltW xlty). +Qed. + +Definition translate_pol {R : ringType} (l : {poly R}) (a : R) : {poly R} := + l \Po ('X + a%:P). + +Lemma size_translate_pol {R : idomainType} (l : {poly R}) a : + size (translate_pol l a) = size l. +Proof. by rewrite size_comp_poly2// size_XaddC. Qed. + +Lemma translate_polq {R : comRingType} (l : {poly R}) a x : + (translate_pol l a).[x] = l.[x + a]. +Proof. by rewrite /translate_pol horner_comp 3!hornerE. Qed. + +Lemma one_root2_translate {R : archiFieldType} (l : {poly R}) a b : + one_root2 (translate_pol l a) b -> one_root2 l (a + b). +Proof. +move=> [x1 [k [x1a kp neg sl]]]; exists (a + x1), k; split => //. +- by rewrite ltrD2l. +- move=> x abx xax1; rewrite (_ : x = x - a + a); last by rewrite addrNK. + by rewrite -translate_polq; apply: neg; rewrite ?ltrBrDl ?lerBlDl. +- move=> x y ax1x xy. + have t z : z = (z - a) + a by rewrite addrNK. + rewrite {2}(t y) {2}(t x). + rewrite -!(translate_polq l) (_ : y - x = y - a - (x - a)); last first. + by rewrite [x + _]addrC opprD opprK addrA addrNK. + by apply: sl; rewrite ?lerBrDl ?ltr_leD. +Qed. + +Lemma one_root1_translate {R : archiFieldType} (l : {poly R}) a b c : + one_root1 (translate_pol l c) a b -> one_root1 l (c + a) (c + b). +Proof. +move=> [x1 [x2 [k [[ax1 x1x2 x2b kp] pos neg sl]]]]. +exists (c + x1), (c + x2), k; split. +- by rewrite !ltrD2l. +- move=> x cax xcx1; rewrite (_ : x = x - c + c); last by rewrite addrNK. + by rewrite -translate_polq; apply pos; rewrite ?ltrBrDl ?lerBlDl. +- move=> x cx2x xcb; rewrite (_ : x = x - c + c); last by rewrite addrNK. + rewrite -translate_polq; apply: neg; rewrite -?ler_addlA //. + by rewrite ltrBrDl. + by rewrite ltrBlDl. +- move=> x y cx1x xy ycx2. + have t z : z = (z - c) + c by rewrite addrNK. + rewrite {2}(t x) {2}(t y) (_ : y - x = y - c - (x - c)); last first. + by rewrite [x + _]addrC opprD opprK addrA addrNK. + rewrite -!(translate_polq l); apply: sl; rewrite ?lerD2l. + + by rewrite ltrBrDl. + + by rewrite lerB. + + by rewrite ltrBlDl. +Qed. + +Lemma diff_xn_ub {R : archiFieldType} (n : nat) : + forall z, (0 < z)%R -> exists2 k, (0 <= k)%R & + forall x y : R, (0 < x)%R -> x <= y -> (y <= z) -> + y ^+ n - x ^+ n <= k * (y - x). +Proof. +elim: n => [z z0| n IHn z z0]. + by exists 0%R => // x y x0 xy yz; rewrite !expr0 subrr mul0r. +have [k k0 kp] := IHn z z0. +exists (z * k + z ^+ n) => [| x y x0 xy yz]. + by rewrite addr_ge0// ?exprn_ge0// ?mulr_ge0// ltW. +rewrite !exprS. +rewrite (_: _ * _ - _ = y * (y ^+ n - x ^+ n) + (y - x) * x ^+ n); last first. + by rewrite mulrDr mulrDl addrA mulrN mulNr addrNK. +rewrite [_ * (y-x)]mulrDl lerD //=. + rewrite -mulrA (@le_trans _ _ (y * (k * (y - x))))//. + rewrite (ler_wpM2l (le_trans (ltW x0) xy))//. + exact: kp. + by rewrite !(mulrCA _ k) ler_wpM2l// ler_wpM2r// subr_ge0. +rewrite (mulrC (_ - _)) ler_wpM2r ?subr_ge0// lerXn2r//. +- by rewrite nnegrE ltW. +- by rewrite nnegrE ltW. +- exact: le_trans yz. +Qed. + +Definition reciprocate_pol (l : seq rat) := rev l. + +Lemma reciprocate_size l : size (reciprocate_pol l) = size l. +Proof. by rewrite /reciprocate_pol size_rev. Qed. + +Lemma cut_epsilon {R : archiFieldType} (eps : R) : (0 < eps)%R -> + exists eps1 eps2 : R, [/\ (0 < eps1)%R, (0 < eps2)%R, (eps1 + eps2 <= eps)%R, + eps1 < eps & eps2 < eps]. +Proof. +move=> p; exists (eps / 2%:R), (eps / 2%:R). +have p1 : (0 < eps / 2%:R)%R by rewrite divr_gt0// ltr0n. +have cmp : eps / 2%:R < eps. + by rewrite ltr_pdivrMr// ?ltr0n// ltr_pMr// ltr1n. +split => //. +by rewrite -splitr. +Qed. + +Lemma ler_horner_norm_pol {R : realFieldType} (l : {poly R}) x : + (0 <= x)%R -> `|l.[x]| <= \sum_(i < size l) (`|l`_i| * x ^+ i). +Proof. +move=> xge0; elim/poly_ind: l => [ | l a Ih]. + by rewrite !hornerE normr0 size_poly0 big_ord0. +rewrite hornerE. +have [->|ln0] := eqVneq l 0%R. + rewrite mul0r !hornerE size_polyC. + have [->|an0] := eqVneq a 0%R; first by rewrite normr0 big_ord0. + by rewrite big_ord1 /= expr0 mulr1 coefC eqxx. +rewrite size_MXaddC (negbTE ln0) /= big_ord_recl expr0 mulr1. +rewrite (le_trans (ler_normD _ _))//. +rewrite coefD coefMX eqxx add0r coefC eqxx hornerE [X in X <= _]addrC. +rewrite lerD// !hornerE. +have exteq (i : 'I_(size l)) : true -> + `|(l * 'X + a%:P)`_(lift ord0 i)| * x ^+ lift ord0 i = + (`|l`_i| * x ^+ i) * x. + move=> _; rewrite lift0 coefD coefC /= addr0 coefMX /=. + by rewrite exprS (mulrC x) mulrA. +rewrite normrM (ger0_norm xge0). +by rewrite (eq_bigr _ exteq) -mulr_suml ler_wpM2r. +Qed. + +Lemma cm3 {R : realFieldType} (b : R) : + (0 < b)%R -> forall l : {poly R}, {c | forall x y : R, + (0 <= x)%R -> (x <= y)%R -> (y <= b)%R -> `|l.[y] - l.[x]| <= c * (y - x)}. +Proof. +move=> pb; elim/poly_ind=> [ | l u [c cp]]. + by exists 0%R => x y; rewrite !hornerE oppr0 normr0 lexx. +exists ((\sum_(i < size l) `|nth 0 l i| * b ^+ i) + c * b). +move=> x y xge0 xy yb. +rewrite !hornerE addrAC opprD addrA addrNK. +rewrite [A in `|A|](_ : _ = l.[y] * y - l.[y] * x + l.[y] * x - l.[x] * x); + last by rewrite -[_ - _ + _]addrA addNr addr0. +have py : (0 <= y)%R by rewrite (le_trans xge0). +have psyx : (0 <= y - x)%R by rewrite subr_ge0. +rewrite -addrA (le_trans (ler_normD _ _)) //. +rewrite -mulrBr -mulrBl !normrM (ger0_norm xge0) (ger0_norm psyx). +rewrite [X in _ <= X]mulrDl lerD//. + rewrite ler_wpM2r// (le_trans (ler_horner_norm_pol l y py))//. + apply: ler_sum => i _. + rewrite ler_wpM2l ?normr_ge0//. + by rewrite lerXn2r// nnegrE (le_trans _ yb). +rewrite mulrAC ler_pM//; first exact: cp. +by rewrite (le_trans xy). +Qed. + +Lemma one_root_reciprocate {R : archiFieldType} (l : {poly R}) : + one_root2 (reciprocal_pol l) 1 -> one_root1 l 0 1. +Proof. +move=> [x1 [k [x1gt1 kp neg sl]]]. +have x10 : (0 < x1)%R by rewrite (lt_trans _ x1gt1)// ltr01. +set y' := x1 - (reciprocal_pol l).[x1] / k. +have y'1 : x1 < y'. + rewrite /y' -(ltrD2l (-x1)) addNr addrA addNr add0r -mulNr. + by rewrite divr_gt0 // oppr_gt0; exact: neg. +have nx1 : (reciprocal_pol l).[x1] < 0%R by apply: neg; rewrite // ltxx. +have y'pos : (0 <= (reciprocal_pol l).[y'])%R. + rewrite -[_ _ y']addr0 -{2}(addNr (reciprocal_pol l).[x1]) addrA + -{2}(opprK (_ _ x1)) subr_gte0 /=. + apply: le_trans (_ : k * (y' - x1) <= _)=> /=. + by rewrite /y' (addrC x1) addrK mulrN mulrC mulrVK // unitfE gt_eqF. + exact: sl. +have [u u0 up] := diff_xn_ub (size l - 1) _ (@ltr01 R). +have [u' u1 u'u] : exists2 u', (1 <= u')%R & (u <= u')%R. + case cmp: (1 <= u)%R; first by exists u => //; rewrite lexx cmp. + by exists 1%R; rewrite ?lexx // ltW // ltNge cmp. +have u'0 : (0 < u')%R by apply: lt_le_trans u1. +have divu_ltr (x : R) : (0 <= x)%R -> (x / u' <= x)%R. + by move=> x0; rewrite ler_pdivrMr// ler_peMr. +have y'0 : (0 < y')%R by apply: lt_trans y'1. +pose y := y' + 1. +have y'y : y' < y by rewrite /y ltrDl ltr01. +have y1 : x1 < y by apply: lt_trans y'1 _. +have ypos : (0 < (reciprocal_pol l).[y])%R. + apply: le_lt_trans y'pos _=> /=. + rewrite -subr_gte0 /=; apply: lt_le_trans (_ : k * (y - y') <= _)=> /=. + by rewrite mulr_gt0// subr_gt0. + by apply: sl=> //; apply: ltW. +have y0 : (0 < y)%R by apply: lt_trans y'y. +pose k' := ((k * x1 ^+ 2 * y ^- 1 ^+ (size l - 1))/(1+1)). +have k'p : (0 < k')%R. + rewrite /k' !mulr_gt0// ?invr_gt0 ?addr_gt0 ?ltr01//. + by rewrite exprn_gt0// invr_gt0. +pose e : R := k' / u'. +have ep: (0 < e)%R by rewrite divr_gt0. +have [e1 [e2 [e1p e2p e1e2e e1e e2e]]] := cut_epsilon _ ep. +have [[a b']] := @constructive_ivt _ (@reciprocal_pol _ l) _ _ _ y'1 nx1 y'pos e1p. +rewrite {1}/pair_in_interval. +move=> /and5P[/and3P[cla ? clb']]. +rewrite /pair_in_interval. +move=> /and3P[x1a ab b'y' nega posb' bma]. +have [c cp] := cm3 y y0 (reciprocal_pol l). +have a0 : (0 < a)%R by apply: lt_le_trans x1a. +have c0 : (0 < c)%R. + rewrite -(@pmulr_lgt0 _ (b' - a)) ?subr_gt0//. + rewrite (@lt_le_trans _ _ (`|(reciprocal_pol l).[b'] - + (reciprocal_pol l).[a] |))//; last first. + apply: cp. + - exact: ltW. + - exact: ltW. + - by rewrite (le_trans b'y')// ltW. + by rewrite normr_gt0// gt_eqF// subr_gt0. +have [b [b'b clb blty]] : exists b, [/\ b' < b, c * (b - b') < e2 & b <= y]. + have [e3 [e4 [e3p e4p e3e4e2 e3e2 e4e2]]] := cut_epsilon _ e2p. + case cmp : (b' + e2 / c <= y). + exists (b' + e3 / c); split. + - by rewrite ltrDl// divr_gt0. + - by rewrite (addrC b') addrK mulrA (mulrC c) mulfK // gt_eqF. + - apply: le_trans cmp; rewrite lerD2l//. + by rewrite ler_pM// ltW// invr_gt0. + exists y; split => //. + - by rewrite (le_lt_trans b'y'). + - by rewrite mulrC -ltr_pdivlMr// ltrBlDl ltNge cmp. +pose n := ((size l))%:R - 1. +have b'0 : (0 < b')%R by apply: lt_trans ab. +have b0 : (0 < b)%R by apply: lt_trans b'b. +have b'v0 : (0 < b'^-1)%R by rewrite invr_gte0. +have bv0 : (0 < b^-1)%R by rewrite invr_gte0. +have bb'v : b^-1 < b'^-1 by rewrite ltf_pV2. +exists b^-1, a^-1, k'; split => //. +- split => //. + + by rewrite (lt_le_trans bb'v)// lef_pV2// ltW. + + by rewrite invf_lt1// (lt_le_trans _ x1a). +- move => x x0 xb. + have xv0 : (0 < x^-1)%R by rewrite invr_gt0. + have xexp0 : (0 < x^-1 ^+ (size l - 1))%R by rewrite exprn_gt0. + have b'x : b' < x^-1. + by rewrite -(invrK b')// ltf_pV2// (le_lt_trans _ bb'v). + rewrite -(pmulr_rgt0 _ xexp0) -{2}[x]invrK -horner_reciprocal; last first. + by rewrite unitfE gt_eqF. + apply: (le_lt_trans posb'); rewrite -subr_gte0 /=. + apply: lt_le_trans (_ : k * (x^-1 - b') <= _)=> /=. + by rewrite mulr_gt0// subr_gt0. + by apply: sl => //; rewrite (le_trans x1a)// ltW. +- move => x a1x xlt1. + have x0 : (0 < x)%R by apply: lt_trans a1x; rewrite invr_gt0. + have xv0 : (0 < x^-1)%R by rewrite invr_gt0. + have x1a0 : (x^-1 < a)%R by rewrite -[a]invrK ltf_pV2// posrE// invr_gt0. + have xexp0 : (0 < x^-1 ^+ (size l - 1))%R by apply: exprn_gt0. + rewrite -(pmulr_rlt0 _ xexp0) -{2}[x]invrK -horner_reciprocal//; last first. + by rewrite unitfE gt_eqF. + case cmp: (x^-1 <= x1); last (move/negbT:cmp => cmp). + by apply: neg => //; rewrite -invr1 ltf_pV2// ?posrE ltr01//. + apply: lt_trans nega; rewrite -subr_gte0. + apply: lt_le_trans (_ : k * (a - x^-1) <= _). + by rewrite mulr_gt0// subr_gt0. + apply: sl => //. + rewrite -ltNge in cmp. + exact: ltW. +- move=> x z bvx + zav; rewrite le_eqVlt => /predU1P[->|xz]. + by rewrite !addrN mulr0 lexx. + have x0 : (0 < x)%R by apply: lt_trans bvx. + have z0 : (0 < z)%R by apply: (lt_trans x0). + have := horner_reciprocal1 l (unitf_gt0 x0) => ->. + have := horner_reciprocal1 l (unitf_gt0 z0) => ->. + rewrite (_ : _ * _ - _ = (x ^+ (size l - 1) - z ^+ (size l - 1)) * + (reciprocal_pol l).[x ^-1] + + ((reciprocal_pol l).[x ^-1] - + (reciprocal_pol l).[z ^-1]) * + z ^+ (size l - 1)); last first. + by rewrite !mulrDl !mulNr ![_.[_] * _]mulrC !addrA addrNK. + set t1 := _ * _.[_]. + set t3 := (_.[_] - _). + set t2 := t3 * _. + pose k1 := -k'; pose k2 := k' + k'. + have times2 : forall a : rat, a + a = (1 + 1) * a. + by move => a'; rewrite mulrDl !mul1r. + have k2p : k2 = (k * x1 ^+ 2 * y ^-1 ^+ (size l - 1)). + rewrite /k2 /k' -mulr2n -mulr_natl. + rewrite -(mulrC (1 + 1)^-1) mulrA mulfV; first by rewrite mul1r. + have twop : (0 < (1 + 1))%Q by []. + by rewrite gt_eqF// ltr0n. + rewrite (_ : k' = k1 + k2); last by rewrite /k1 /k2 addrA addNr add0r. + have x1ltvz : x1 < z ^-1. + by rewrite (le_lt_trans x1a) // -[a]invrK ltef_pV2 ?posrE ?invr_gt0 ?ltW. + rewrite mulrDl; apply: lerD; last first. + have maj' : t3 * y^-1 ^+ (size l - 1) <= t3 * z^+ (size l - 1). + have maj : y^-1 ^+(size l - 1) <= z ^+ (size l - 1). + case: (size l - 1)%N => [ | n']; first by rewrite !expr0 lexx. + have /pow_monotone : (0 <= y ^-1 <= z)%R. + rewrite ltW /=; last by rewrite invr_gt0 (lt_trans x10). + apply: ltW (le_lt_trans _ xz); apply: ltW (le_lt_trans _ bvx). + by rewrite lef_pV2 ?posrE. + by move=> /(_ n'.+1) /andP[]. + rewrite lter_pM2l // /t3. + apply: (lt_le_trans _ (_ : k * (x ^-1 - z ^-1) <= _)); last first. + apply: sl; first by apply: ltW. + by rewrite ltf_pV2. + by rewrite mulr_gt0 // subr_gt0 ltf_pV2. + apply: le_trans maj'; rewrite /t3 k2p mulrAC. + rewrite lter_pM2r; last by apply: exprn_gt0; rewrite invr_gt0. + apply: ltW (lt_le_trans _ (_ :k * (x ^-1 - z ^-1) <= _)). + rewrite ![k * _]mulrC mulrAC lter_pM2r; last by []. + rewrite -[x ^-1](mulrK (unitf_gt0 z0)). + rewrite -[X in _ < _ - X](mulrK (unitf_gt0 x0)) -(mulrC x) -(mulrC z). + rewrite (mulrAC x) -!(mulrA _ (x^-1)) -mulrBl (mulrC (z - x)). + rewrite lter_pM2r; last by rewrite subr_gte0. + apply: lt_le_trans (_ : x1 / z <= _); first by rewrite lter_pM2l. + rewrite lter_pM2r; last by rewrite invr_gte0. + by apply: ltW (lt_trans x1ltvz _); rewrite ltef_pV2 ?posrE. + apply: sl; first by apply: ltW. + by rewrite ltef_pV2 ?posrE. + rewrite /t1/k1/k' {t2 t3}. + have xzexp : (x ^+ (size l - 1) <= z ^+ (size l - 1)). + case sizep : (size l - 1)%N => [ | n']. + by rewrite !expr0 ltexx. + have /pow_monotone : (0 <= x <= z)%R. + by rewrite !ltW. + by move=>/(_ n'.+1)=> /andP[]. + case: (lerP 0 ((reciprocal_pol l).[x^-1])) => sign; last first. + apply: le_trans (_ : 0 <= _)%R. + rewrite mulNr lterNl oppr0; apply: mulr_ge0; last first. + by rewrite subr_gte0 ltW. + exact (ltW k'p). + by rewrite nmulr_lge0 // subr_lte0. + rewrite mulNr lterNl -mulNr opprB. + have rpxe : (reciprocal_pol l).[x^-1] <= e. + apply:le_trans (_ : (reciprocal_pol l).[b] <= _) => /=. + rewrite -subr_gte0 /= ; apply: le_trans (_ : k * (b - x^-1) <= _). + rewrite mulr_ge0 //. + exact: ltW. + by rewrite subr_ge0 ltW // -(invrK b) ltef_pV2 ?posrE. + apply: sl. + by apply: (ltW (lt_trans x1ltvz _)); rewrite ltef_pV2 ?posrE. + by rewrite -(invrK b) ltef_pV2 ?posrE. + rewrite -[_ _ b]addr0 -(addrN ((reciprocal_pol l).[b'])) addrA. + rewrite (addrC (_.[b])) -addrA; apply: le_trans e1e2e. + apply: lerD; first by []. + apply: (le_trans (ler_norm _)). + by apply/ltW/(le_lt_trans _ clb)/cp=> //; apply/ltW. + apply: le_trans (_ : (z^+ (size l - 1) - x ^+ (size l - 1)) * e <= _). + move: xzexp; rewrite -subr_gte0 le_eqVlt => /predU1P[<-|xzexp] /=. + by rewrite !mul0r. + by rewrite lter_pM2l. +rewrite [_ * e]mulrC; apply: le_trans (_ : e * (u' * (z - x)) <= _)=> /=. + rewrite ler_pM2l//. + apply: le_trans (_ : u * (z - x) <= _). + apply: up => //. + by apply: ltW. + apply: ltW (lt_trans zav _). + by rewrite invf_lt1 //; by apply: lt_le_trans x1a. + by rewrite ler_pM2r// subr_gt0. +rewrite mulrA. +rewrite ler_pM2r// ?subr_gt0//. +by rewrite /e divrK// unitfE gt_eqF. +Qed. + +(* TODO(rei) +Lemma Bernstein_isolate : forall a b l, a < b -> + alternate (Mobius l a b) -> one_root1 l a b. +Proof. +rewrite /Mobius => a b l altb alt. +rewrite (_ : a = a + (a - a)); last by rewrite addrN addr0. +rewrite (_ : b = a + (b - a)); last by rewrite (addrC b) addrA addrN add0r. +apply one_root1_translate. +rewrite addrN (_ : (b-a) = (b-a) * 1); last by rewrite mulr1. +rewrite (_ : 0 = (b-a) * 0); last by rewrite mulr0. +apply one_root1_expand; first by rewrite -(addrN a) lter_add2l. +apply one_root_reciprocate. +rewrite -[1]addr0; apply one_root2_translate. +by apply: alt_one_root2. +Qed. +*) diff --git a/theories/bern5.v b/theories/bern5.v new file mode 100644 index 0000000..d905fb0 --- /dev/null +++ b/theories/bern5.v @@ -0,0 +1,136 @@ +Require Import ZArith List. +Open Scope Z_scope. + +(* Just a few programs to test the ideas. In particular, this shows + that the composition translate then expand, reciprocate, and again translate + does not yield directly the binomial coefficients, in the sens that + they do not give the coefficients in the Bernstein polynomial basis. + The discrepancy is simply a binomial coefficient. Fortunately this does + not the result on signs. +*) + +(* binomial coefficients *) + +Fixpoint bin (a b : nat) : Z := + match a, b with + O, O => 1 + | O, S q => 0 + | S p, O => 1 + | S p, S q => bin p (S q) + bin p q + end. + +(* Now, a re-definition of the arithmetic on polynomials. *) +(* Fixpoint expandr (l : list Z) (ratio : Z) : list Z := + match l with a::tl => a * ratio :: expandr tl ratio | nil => nil end. *) + +Fixpoint mysum (f : nat -> Z) (n:nat) := + match n with S p => f p + mysum f p | _ => 0 end. + +Fixpoint add_list (s1 s2 : list Z) := + match s1 with a::s1' => + match s2 with b::s2' => (a+b) :: add_list s1' s2' | _ => s1 end + | _ => s2 end. + +Fixpoint scal_mul (x : Z) (s : list Z) := + match s with a::s' => (x * a) :: scal_mul x s' | _ => nil end. + +Fixpoint mul_list (s1 s2 : list Z) := + match s1 with a::s1' => add_list (scal_mul a s2) (0::mul_list s1' s2) + | _ => nil end. + +Fixpoint power_list (s1 : list Z) (n : nat) := + match n with S p => mul_list s1 (power_list s1 p) | _ => 1::nil end. + +Fixpoint compose_list (s1 s2 : list Z) := + match s1 with + a::nil => a::nil + | a::s1' => add_list (a::nil) (mul_list s2 (compose_list s1' s2)) + | _ => nil end. + +Definition expandr (s1 : list Z) (ratio : Z) := + compose_list s1 (0::ratio::nil). + +Definition transr (s : list Z) (offset : Z) : list Z := + compose_list s (offset :: 1 :: nil). + +Fixpoint recipr n (s : list Z) := + match n with S p => + match s with a::tl => (recipr p tl)++(a::nil) + | nil => (recipr p nil)++(0::nil) end + | 0%nat => nil + end. + +Definition bc n s l r := transr (recipr n (expandr (transr s l) (r - l))) 1. + +(* Bernstein basis of degree 5 for the interval (0,1) + is : bin 5 i * (1 - X)^(5-i) * x ^i *) + +Definition B5_ (i:nat) := + fun x : Z => (bin 5 i) * Zpower_nat x (5 - i) * Zpower_nat (1 - x) i. + +Definition B5'_(i : nat) (l r : Z) := + fun x : Z => + bin 5 i * Zpower_nat (x - l) (5 - i) * Zpower_nat (r - x) i. + +Definition pol_from_B (a b c d e f x : Z) := + a * B5_(0) x + b * B5_(1) x + c * B5_(2) x + d * B5_(3) x + + e * B5_(4) x + f * B5_(5) x. + +(* Working on integers brings a stupid constraint, because of division + by the size of interval at power 5. *) + +Definition pol_from_B' (l r a b c d e f x : Z) := + a * B5'_(0) l r x + b * B5'_(1)l r x + c * B5'_(2)l r x + d * B5'_(3)l r x + + e * B5'_(4)l r x + f * B5'_(5)l r x. + +(* NB(rei): couldn't figure out how to make the code below go through +Require Import FunInd. +Functional Scheme iter_nat_ind := Induction for iter_nat Sort Prop. + +(* Using Coq as a symbolic engine to compute some polynomials from + their Bernstein coefficients. *) + +Ltac expand_bernstein := + intros; unfold pol_from_B, B5_, pol_from_B', B5'_; simpl minus; simpl bin; + unfold Zpower_nat; repeat rewrite iter_nat_equation; ring_simplify. + +Lemma example1 : + forall x, pol_from_B 1 4 1 (-5) 3 1 x = + (55*x^5 - 205 * x^4 + 240*x^3 - 100 * x^ 2 + 10 * x + 1). +intros x; expand_bernstein. +trivial. +Qed. + +Lemma example2 : + forall x, pol_from_B' 2 4 1 4 1 (-5) 3 1 x = 55 * x^5 - 960 * x ^ 4 + + 6440 * x ^ 3 - 20800 * x ^ 2 + 32400 * x - 19488. +intros x; expand_bernstein. +reflexivity. +Qed. + +(* This list of coefficients is taken from the expanded formula exhibited + in the lemma example1. *) +Definition ex1 : list Z := 1::10::(-100)::240::(-205)::55::nil. + +Definition ex2 : list Z := (-19488)::32400::(-20800)::6440::-960::55::nil. + +Fixpoint zip (f : Z -> Z -> Z) (l1 l2 : list Z) := + match l1, l2 with a::l1', b::l2' => f a b::zip f l1' l2' | _, _ => nil end. + +Lemma bc_right1 : bc 6 ex1 (0) (1) = + zip Zmult (1::4::1::(-5)::3::1::nil) + (map (fun x => bin 5 x) (seq 0 6)). +unfold bc, ex1, seq. +simpl zip. +unfold expandr; simpl compose_list. +simpl recipr. +compute. +reflexivity. +Qed. + +Lemma bc_right2 : bc 6 ex2 2 4 = + zip Zmult (1::4::1::(-5)::3::1::nil) + (map (fun x => (4 - 2) ^ 5 * bin 5 x) (seq 0 6)). +reflexivity. +Qed. +*) diff --git a/theories/casteljau.v b/theories/casteljau.v new file mode 100644 index 0000000..6f1c6bb --- /dev/null +++ b/theories/casteljau.v @@ -0,0 +1,1846 @@ +From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat binomial seq choice order. +From mathcomp Require Import fintype bigop ssralg poly ssrnum ssrint rat ssrnum archimedean. +From mathcomp Require Import polyrcf qe_rcf_th realalg. +Require Import pol poly_normal desc. + +(******************************************************************************) +(* de_casteljau == De Casteljau's algorithm *) +(* dicho' b i := de_casteljau b i 0 *) +(* dicho p b i := de_casteljau b (p - i) i *) +(* bernp a b p i == Bernstein polynomial of degree p for a, b for 0 <= i <= p *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import Order.Theory. +Import GRing.Theory. +Import Num.Theory Num.Def. +Local Open Scope ring_scope. + +(* A technical binomial identity for the proof of de Casteljau *) +Lemma util_C : forall n i j : nat, (i <= j)%nat -> (j <= n)%nat -> + ('C(n, i) * 'C(n-i, j-i) = 'C(j, i) * 'C(n, j))%nat. +Proof. +move => n i j ij jn. +apply/eqP; rewrite -(@eqn_pmul2r ( i`! * (n - i) `!)); + last by rewrite muln_gt0; apply/andP; split; apply: fact_gt0. +rewrite -(@eqn_pmul2r ((j - i)`! * ((n - i)-(j - i))`!)); last first. + by rewrite muln_gt0; apply/andP; split; apply: fact_gt0. +have ilen : (i <= n)%nat by apply: leq_trans jn. +rewrite (mulnAC 'C(n, i)) -mulnA !bin_fact //; last by apply: leq_sub2r. +rewrite !mulnA (mulnAC _ _ (i`!)) 2!(mulnAC _ _ ((j-i)`!)) -(mulnA 'C(j, i)). +rewrite bin_fact // -subnDA subnKC // mulnAC (mulnC j`!) -(mulnA _ j`!). +by rewrite bin_fact. +Qed. + +Section ToBeAddedInOrderedAlg. + +Variable F : numFieldType. + +Lemma normr_sum : forall m (G : nat -> F), + `|\sum_(i < m) G i| <= \sum_(i < m) `|G i|. +Proof. +elim=> [|m ihm] G; first by rewrite !big_ord0 normr0. +rewrite !big_ord_recr /=; apply: le_trans (ler_normD _ _) _=> /=. +by rewrite lerD2r; exact: ihm. +Qed. + +Lemma expf_gt1 : forall m (x : F), x > 1 -> x^+m.+1 > 1. +Proof. +elim => [|m ihm] x hx; first by rewrite expr1. +apply: lt_trans (hx) _ => /=; rewrite exprS -{1}(mulr1 x). +rewrite ltr_pM2l; first exact: ihm. +apply: lt_trans hx; exact: ltr01. +Qed. + +Lemma expf_ge1 : forall m (x : F), x >= 1 -> x^+m >= 1. +Proof. +elim => [|m ihm] x hx; first by rewrite expr0 lexx. +apply: le_trans (hx) _ => /=; rewrite exprS. (* -{1}(mulr1 x). *) +rewrite ler_pMr; first exact: ihm. +apply: lt_le_trans hx; exact: ltr01. +Qed. + +End ToBeAddedInOrderedAlg. + +Section ToBeAddedInPoly. + +Variable R : idomainType. + +(* A remark, lemma size_Xma should be with addition *) +Lemma size_factor_expr : forall (t : R)(n : nat), + size (('X + t%:P)^+n) = n.+1. +Proof. +move=> t; elim=> [|n ihn]; first by rewrite expr0 size_polyC oner_eq0. +rewrite exprS size_monicM //; last first. + by rewrite -size_poly_eq0 ihn; apply/negP; move/eqP. + by rewrite -(opprK t%:P) -polyCN monicXsubC. +by rewrite ihn -(opprK t%:P) -polyCN size_XsubC. +Qed. + +Lemma size_amul_expr : forall (t c : R)(i : nat), + c != 0 -> size (('X * c%:P + t%:P) ^+ i) = i.+1. +Proof. +move=> t c; elim=> [| i ih] cn0; first by rewrite expr0 size_poly1. +have hn0 : size ('X * c%:P + t%:P) = 2%N. + rewrite mulrC size_MXaddC polyC_eq0. + move: cn0; rewrite -eqbF_neg=> /eqP => cn0. + by rewrite size_polyC cn0 andFb. +by rewrite exprS size_mul // ?expf_eq0 -?size_poly_eq0 hn0 ?andbF // ih. +Qed. + +Lemma size_factor (x : R) : size ('X + x%:P) = 2%N. +Proof. +by rewrite size_addl ?size_polyX // size_polyC /=; case: (x == 0). +Qed. + +Lemma size_polyX_mul (p : {poly R}) : + size ('X * p) = if p == 0 then 0%nat else (size p).+1. +Proof. +rewrite (_ : 'X * p = p * 'X + 0%:P); last by rewrite mulrC addr0. + by rewrite size_MXaddC eqxx andbT. +Qed. + +Lemma coef_poly0 (p q : {poly R}) : (p * q)`_0 = p`_0 * q`_0. +Proof. +by rewrite coef_mul_poly big_ord_recl big_ord0 sub0n addr0. +Qed. + +End ToBeAddedInPoly. +(* We prove the Cauchy bound in any ordered field *) + +Section CauchyBound. + +Variable F : realFieldType. + +Variables (n : nat)(E : nat -> F). + +Hypothesis pnz : E n != 0. + +Lemma CauchyBound x: (\poly_(i < n.+1) E i).[x] = 0 -> + `| x | <= `|E n|^-1 * \sum_(i < n.+1) `|E i|. +Proof. +move=> px0; case: (lerP `|x| 1)=> cx1. + set C := _ * _; suff leC1 : 1 <= C by apply: le_trans leC1. + have h1 : `|E n| > 0 by rewrite normr_gt0. + rewrite -(ler_pM2l h1) /= mulr1 /C mulrA mulfV ?normr_eq0 // mul1r. + by rewrite big_ord_recr /= -{1}(add0r `|E n|) lerD2r sumr_ge0. +case e: n=> [| m]. + move: pnz; rewrite -px0 e horner_poly big_ord_recl big_ord0 /=. + by rewrite addr0 expr0 mulr1 /= eqxx. +have h1 : E m.+1 * x^+m.+1 = - \sum_(i < m.+1) E i * x^+ i. + apply/eqP; rewrite -subr_eq0 opprK -{2}px0 horner_poly (big_ord_recr n). + by rewrite e //= addrC. +case x0 : (x == 0). + by rewrite (eqP x0) normr0 mulr_ge0 ?sumr_ge0// invr_gte0. +have {h1} h2 : E m.+1 * x = - \sum_(i < m.+1) E i * x^-(m - i). +have xmn0 : ~~ (x^+m == 0) by rewrite expf_eq0 x0 andbF. + apply: (mulIf xmn0); rewrite mulNr big_distrl /= -mulrA -exprS h1. + congr (- _); apply: congr_big; [by [] | by [] |] => [[i hi]] _ /=. + have mi : m = (m - i + i)%N by rewrite subnK. + rewrite {2}mi exprD -!mulrA; congr (_ * _); rewrite mulrA mulVf ?mul1r //. + by rewrite expf_eq0 x0 andbF. +have h3 : `|\sum_(i < m.+1) E i / x ^+ (m - i) | <= \sum_(i < m.+2) `|E i|. + apply: le_trans (normr_sum m.+1 (fun i => E i / x ^+ (m - i))) _. + apply: (@le_trans _ _ (\sum_(i < m.+1) `|E i|)); last first. + by rewrite (big_ord_recr m.+1) /= lerDl /= normr_ge0. + suff h: forall i, (i < m.+1)%N -> `|E i/x^+(m-i)| <= `|E i|. + by apply: ler_sum => //= i _; exact: h. + move=> i lti; rewrite normrM -{2}(mulr1 (`|E i|)) ler_wpM2l ?normr_ge0 //. + rewrite normfV normrX invf_le1; first by rewrite exprn_cp1 // ltW. + by rewrite exprn_gt0 // (lt_trans ltr01). +rewrite lter_pdivlMl; last by rewrite normr_gt0 -e. +by apply: le_trans h3=> /=; rewrite -normrM h2 normrN lexx. +Qed. + +End CauchyBound. + +(* +Section TranslateProps. + +(* First linearity lemma : translate complies with scalar product for *) +(* elements of the basis *) + +(* +(* Second linearity lemma : translate complies with addition *) +Lemma translate_add : forall l1 l2 c, + size l1 = size l2 -> + shift_poly (map (fun x : Qcb * Qcb => x.1 + x.2) (zip l1 l2)) c = + map (fun x => x.1 + x.2) (zip (shift_poly l1 c) (shift_poly l2 c)). +Proof. +move=> l1 l2 c e; apply: (@eq_from_nth _ 0); rewrite size_shift_poly !size_map. + by rewrite !size1_zip ?size_shift_poly // e. +move=> i; rewrite size1_zip ?e // => his; rewrite translate_nth; last first. + by rewrite size_map size2_zip // e. +rewrite size_map size1_zip ?e //= (nth_map (0, 0)); last first. + by rewrite size2_zip ?size_shift_poly // e /=. +rewrite nth_zip ?size_shift_poly // !translate_nth // ?e //=. +rewrite -big_split /=; apply: congr_big=> // [[k hk]] _ /=. +rewrite (nth_map (0, 0)) ?size2_zip // ?e // nth_zip //= mulr_addl. +by rewrite mulrn_addl. +Qed. + +Lemma translate_mulX : forall (q1 q2 : {poly Qcb}) c, + q2 != 0 -> q1 != 0 -> + shift_poly q2 c = q1 -> shift_poly ('X * q2) c = ('X + c%:P) * q1. +Proof. + move=> q1 q2 c q2n0 q1n0 e. + have sp1 : size (shift_poly ('X * q2) c) = (size q2).+1. + by rewrite size_shift_poly size_mul_id // -?size_poly_eq0 ?size_polyX. + have sp2 : size ('X * q2) = (size q2).+1. + by rewrite mulrC size_mul_monic ?monicX // size_polyX !addnS addn0. + apply: (@eq_from_nth _ 0). + by rewrite sp1 size_mul_id // -?size_poly_eq0 ?size_factor // -e size_shift_poly. + rewrite sp1 => [[_|j hj]]. + rewrite translate_nth ?size_polyX_mul ?(negPf q2n0) //. + rewrite coef_poly0 coef_add coefC eqxx coefX add0r -e /shift_poly. + rewrite !nth_mkseq ?lt0n ?size_poly_eq0 // -?size_poly_eq0 ?sp2 //. + rewrite big_distrr big_ord_recl coef_Xmul eqxx mul0r mul0rn add0r. + apply: congr_big=> // [[k hk]] _. + rewrite !bin0 !subn0 !mulr1n -[('X * q2)`__]/(('X * q2)`_k.+1). + rewrite [GRing.muloid _ _]/= [c * _]mulrC. + rewrite -mulrA [_ * c]mulrC -exprS; congr (_ * _). + (* we should really put a nosimpl on `_ *) + by rewrite coef_Xmul /=. + rewrite /shift_poly nth_mkseq ?sp2 //. + rewrite coef_mul; apply: sym_eq; rewrite 2!big_ord_recl big1; last first. + case=> k hk _; rewrite -[('X + c%:P)`_ _]/(('X + c%:P)`_ k.+2). + by rewrite coef_add coefC coefX /= addr0 mul0r. + rewrite [nat_of_ord _]/= !subn0 addr0 -[nat_of_ord _]/1%N. + rewrite !coef_add !coefX !coefC !eqxx -![_ == _]/false add0r addr0 mul1r. + rewrite -e /shift_poly. + rewrite big_ord_recl coef_Xmul eqxx mul0r mul0rn add0r subSS subn0. + move: hj; rewrite ltnS leq_eqVlt; case/orP. + move/eqP=> ej; rewrite ej nth_default ?size_mkseq ?leqnn // mulr0 add0r. + rewrite nth_mkseq -?ej //; apply: congr_big => // [[k hk]] _. + rewrite -[('X * q2)`_ _]/(('X * q2)`_k.+1) subSS coef_Xmul -[_ == 0%N]/false /=. + move: hk; rewrite ltnS leq_eqVlt; case/orP; first by move/eqP->; rewrite !binn. + move=> hkj; rewrite !bin_small //. + move=> hjs. rewrite !nth_mkseq //; last by apply: ltn_trans hjs. + rewrite big_distrr -big_split; apply: congr_big=> // [[k hk]] _. + rewrite -[('X * q2)`_ _]/(('X * q2)`_k.+1) coef_Xmul /= subSS. + rewrite -mulrnAl mulrC -mulrA [_ * c]mulrC -exprS {hjs hk}. + case: (ltngtP k j) => ekj. + - by rewrite !bin_small //; apply: ltn_trans ekj _. + - by rewrite -ltn_subS // mulrnAl -mulrn_addr -binS. + - rewrite ekj !binn subnn bin_small // (_ : j - j.+1 = 0)%N; last first. + by apply/eqP; rewrite subn_eq0. + by rewrite !mulr0n mul0r add0r expr0. +Qed. + +Lemma shift_polyXn : forall (c : Qcb) i, + (shift_poly 'X^i c) = ('X + c%:P)^+i. +Proof. +move=> c i; rewrite -(mulr1 'X^i); elim: i => [| i ihi]. + rewrite !expr0 mulr1 /shift_poly size_polyC oner_eq0 /=. + rewrite /mkseq /= big_ord_recl big_ord0 subn0 bin0 addr0 expr0 mulr1 mulr1n. + by rewrite -polyC1 coefC eqxx polyseqC oner_eq0. +rewrite exprS -mulrA. +rewrite (translate_mulX _ _ _ _ _ ihi) ?exprS // ?mulr1 -size_poly_eq0. + by rewrite size_polyXn. +by rewrite size_factor_expr. +Qed. + +Lemma translate_mulXn : forall n (q1 q2 : {poly Qcb}) c, q2 != 0 -> q1 != 0 -> + q2 \shift c = q1 -> + ('X^n * q2) \shift c = ('X + c%:P)^+n * q1. +Proof. +elim=> [|n ihn] q1 q2 c nq20 nq10 e; first by rewrite expr0 !mul1r. +rewrite exprS -mulrA. +have h : shift_poly ('X^n * q2) c = ('X + c%:P) ^+ n * q1. + by rewrite (ihn q1 q2). +rewrite (translate_mulX _ _ _ _ _ h); first by rewrite mulrA -exprS. + rewrite -size_poly_eq0 mulrC size_mul_monic ?monicXn // size_polyXn !addnS /=. + by rewrite addn_eq0 negb_and size_poly_eq0 nq20. +rewrite -size_poly_eq0 size_mul_id // -?size_poly_eq0 ?size_polyXn size_factor_expr //=. +by rewrite addn_eq0 negb_and size_poly_eq0 nq10 orbT. +Qed. + +(* to be cleaned: a simple induction is probably enough *) +Lemma translate_padded_l : forall (i : nat) (q : seq Qcb)(c : Qcb) , + shift_poly (q ++ (nseq i 0)) c = (shift_poly q c) ++ (nseq i 0). +Proof. +move=> n; elim: n {-2}n (leqnn n) => [| i hi] n hn q c. + by move: hn; rewrite leqn0; move/eqP->; rewrite !cats0. +move: hn; rewrite leq_eqVlt; case/orP; last by move=> hn; rewrite hi //. +move/eqP->; rewrite -[q ++ _]/(q ++ nseq 1 0 ++ nseq i 0) catA hi //. +rewrite /shift_poly size_cat size_nseq addnS addn0. +rewrite -[nseq i.+1 0]/([:: 0] ++ nseq i 0) catA; congr (_ ++ _). +apply: (@eq_from_nth _ 0). + by rewrite size_cat /= !size_mkseq size_map size_iota addn1. +rewrite size_mkseq => j; rewrite ltnS leq_eqVlt; case/orP=> hj. + rewrite (eqP hj) nth_mkseq // nth_cat size_mkseq ltnn subnn /= big1 //. + case=> k /=; rewrite ltnS leq_eqVlt; case/orP=> hk _. + rewrite (eqP hk) nth_cat ltnn subnn /= mul0r mul0rn //. + by rewrite nth_cat hk bin_small // mulrn0. +rewrite nth_cat size_mkseq hj !nth_mkseq //; last by apply: ltn_trans hj _. +rewrite big_ord_recr /= nth_cat ltnn subnn mul0r mul0rn addr0. +by apply: congr_big; [by [] | by [] |] => [[k hk]] _ /=; rewrite nth_cat hk. +Qed. + +Lemma translateXn_addr : forall c1 c2 n, + shift_poly (shift_poly 'X^n c1) c2 = shift_poly 'X^n (c1 + c2). +Proof. +move=> c1 c2 n. +apply: (@eq_from_nth _ 0); rewrite ?size_shift_poly //. +rewrite size_polyXn => i hi. +rewrite /shift_poly nth_mkseq ?size_mkseq ?size_polyXn // nth_mkseq //. +apply: trans_equal (_ : + \sum_(k < n.+1) (\sum_(k0 < n.+1)'X^n`_k0 * c1 ^+ (k0 - k) *+ + 'C(k0, k) * c2 ^+ (k - i) *+ 'C(k, i)) = _). + apply: congr_big => // [[k hk]] _ /=; rewrite nth_mkseq //. + by rewrite big_distrl /= -sumr_muln. +rewrite exchange_big /=. +apply: trans_equal (_ : +\sum_(j < n.+1) +\sum_(i0 < n.+1) 'X^n`_j * (c1 ^+ (j - i0) *+ 'C(j, i0) * c2 ^+ (i0 - i) *+ 'C(i0, i)) = _). + apply: congr_big=> // [[k hk]] _ /=; apply: congr_big=> // [[j hj]] _ /=. + by rewrite !mulrnAr !mulrA mulrnAr. +apply: congr_big=> // [[k hk]] _ /=; rewrite -big_distrr /=. +rewrite -mulrnAr; congr (_ * _). +rewrite -(subnKC hk) big_split_ord /= addrC big1; last first. + case=> j hj _ /=; rewrite bin_small; last by apply: ltn_addr. + by rewrite mulr0n mul0r mul0rn. +rewrite add0r; case: (ltngtP k.+1 i) => hki. + -rewrite bin_small //; last by apply: ltn_trans hki. + rewrite mulr0n big1 // => [[j hj]] _ /=; rewrite (@bin_small j); last first. + by apply: ltn_trans hj _. + by rewrite mulr0n. + - rewrite ltnS in hki. rewrite -{- 7 11 12}(subnKC hki) -addnS big_split_ord /= big1; last first. + by case=> j hj _ /=; rewrite (@bin_small j). + rewrite add0r exprn_addl -sumr_muln; apply: congr_big => // [[j hj]] _ /=. + rewrite subnKC // -subnDA [(i + _)%N]addnC -addn_subA // subnn addn0. + rewrite mulrnAl -!mulrnA; congr (_ *+ _). + rewrite [(_ * 'C(k, i))%N]mulnC {3}(_ : j = j + i - i)%N; last first. + by rewrite -addn_subA // subnn addn0. + by rewrite util_C 1?mulnC // ?leq_addl // -(subnK hki) leq_add2r. + - rewrite -hki bin_small // mulr0n big1 // => [[j hj]] /= _. + by rewrite (@bin_small j). +Qed. +*) +End TranslateProps. +*) + +(* +Section ReciprocateProps. + +Lemma reciprocate_padded : forall (i : nat) (q : seq Qcb), + reciprocate_pol (q ++ (nseq i 0)) = (nseq i 0) ++ (reciprocate_pol q). +Proof. +move=> i q; rewrite /reciprocate_pol rev_cat; congr (_ ++_). +apply: (@eq_from_nth _ 0); rewrite size_rev size_nseq // => j hij. +rewrite nth_rev ?size_nseq // !nth_ncons. +by case: i hij=> // i hij; rewrite ltnS subSS leq_subr hij. +Qed. + +End ReciprocateProps. + +*) + +(* +Section ExpandProps. + +Lemma expand_padded : forall (i : nat) (q : seq Qcb)(c : Qcb) , + expand (q ++ (nseq i 0)) c = (expand q c) ++ (nseq i 0). +Proof. +elim=> [| i ih] q c; first by rewrite !cats0. +rewrite -[q ++ _]/(q ++ [:: 0] ++ nseq i 0) catA ih. +suff {ih} -> : expand (q ++ cons 0 [::]) c = expand q c ++ [:: 0] by rewrite -catA. +apply: (@eq_from_nth _ 0); first by rewrite size_cat /expand !size_mkseq !size_cat. +rewrite /expand size_mkseq size_cat addnS addn0=> {i} i. +rewrite ltnS leq_eqVlt; case/orP. + move/eqP->; rewrite nth_cat nth_mkseq // size_mkseq ltnn subnn nth_cat ltnn. + by rewrite subnn /= mul0r. +move=> ltis; rewrite nth_mkseq; last by apply: ltn_trans ltis _. +by rewrite !nth_cat size_mkseq ltis nth_mkseq. +Qed. + +End ExpandProps. + +*) + +(* b gives the coefficients of a polynomial on some bounded interval [a, b]. +de_casteljau computest all the coefficients in the triangle for a, m, n, with +l := m - a and r := b - m. + +invariant : l + r = b - a *) + +Section DeCasteljauAlgo. + +Variable R : comRingType. + +Variables l r : R. + +Fixpoint de_casteljau (b : nat -> R) (n : nat) := + match n with + O => b + | i.+1 => fun j => + (l * de_casteljau b i j + r * de_casteljau b i j.+1)%R + end. + +(* b gives the B. coefficients of a polynomial on some bounded interval [a, b]. +computes the B. coefficients on [a, a + l] si b - a = l + r *) +Definition dicho' b i := de_casteljau b i 0. + +(* b gives the B. coefficients of a polynomial P on some bounded interval [a, b]. +computes the B. coefficients on [b-r, b] si b - a = l + r , as soon as p = deg P *) +Definition dicho p b i := de_casteljau b (p - i) i. + +(* the computation of the value at index (k, n) only uses values (i, j) + for n <= i <= n + k (a triangle, up and right) *) + +Lemma ext_dc : + forall k b b' n, (forall i, (n <= i)%nat -> (i <= n + k)%nat -> b i = b' i) -> + de_casteljau b k n = de_casteljau b' k n. +move => k b b'; elim: k => [ n q | k IHk n q] /=. + by apply: q; rewrite ?addn0 leqnn. +rewrite !IHk //; move => i ni nik; apply: q => //; first exact: ltnW. + by move: nik; rewrite addnS addSn. +by apply: leq_trans nik _; rewrite addnS leqnSn. +Qed. + +(* de_casteljau is linear with respect to coefficients *) +Lemma lin_dc : forall k a a' b b' n, + de_casteljau (fun j => (a * b j + a' * b' j)%R) k n = + (a * de_casteljau b k n + a' * de_casteljau b' k n)%R. +Proof. +elim => [ | k IHk] a a' b b' n /= ; first by []. +rewrite 2!IHk !mulrDr !mulrA !(mulrC r) !(mulrC l) !addrA. +by rewrite (addrAC _ _ (a' * l * _)%R). +Qed. + +(* in particular it is additive *) +Lemma add_dc k b b' n : + de_casteljau (fun j => b j + b' j)%R k n = + (de_casteljau b k n + de_casteljau b' k n)%R. +Proof. +have := lin_dc k 1 1 b b' n. +rewrite (@ext_dc k (fun j => 1 * b j + 1 * b' j) (fun j => b j + b' j))%R. + by rewrite !mul1r. +by move => x; rewrite /= !mul1r. +Qed. + +(* in particular it is homothetic *) +Lemma scal_dc k a b n : + de_casteljau (fun j => a * b j)%R k n = (a * de_casteljau b k n)%R. +Proof. +have := lin_dc k a 0 b (fun i => 0)%R n. +rewrite (@ext_dc _ (fun j => a * b j + 0 * 0)%R (fun j => a * b j)%R). + by rewrite mul0r addr0. +by move => x; rewrite /= mul0r addr0. +Qed. + +End DeCasteljauAlgo. + +Section DeltaSeqs. + +Variable R : rcfType. + +Definition delta (i j : nat) : R := if (i == j) then 1 else 0. + +Lemma dc_delta_head : forall j k l r, + (j < k)%nat -> dicho' l r (delta k) j = 0. +Proof. +rewrite /dicho' => j k l r hlt. +pose d0 := fun _ : nat => 0 : R. +rewrite (@ext_dc _ _ _ _ _ d0); last first. + move=> i; rewrite add0n /delta => h1 h2. + have : (i < k)%nat by apply: leq_ltn_trans hlt. + by rewrite ltn_neqAle; case/andP; rewrite eq_sym; move/negPf->. +elim: j {hlt} 0%nat=> [| j ihj n] /=; first by done. +by rewrite !ihj !mulr0 addr0. +Qed. + +(*Lemma translation_delta:*) +Lemma dc_deltaS : forall k A B i j, + de_casteljau A B (delta i.+1) k j.+1 = de_casteljau A B (delta i) k j. +Proof. +elim=> [|k ihk] A B i j /=; last by rewrite !ihk. +case e : (i == j); first by rewrite /delta (eqP e) !eqxx. +by rewrite /delta eqSS e. +Qed. + +(* algorithme applique a delta_i (colonne j > i)*) + (*Lemma coef_algo_delta_col_supi:*) +Lemma dc_delta_lt : forall k A B i j, (j > i)%nat -> de_casteljau A B (delta i) k j = 0. +Proof. +elim=> [|k ihk] A B i j hlt /=. + by move: hlt; rewrite ltn_neqAle; case/andP; move/negPf; rewrite /delta; move->. +rewrite !ihk // ?mulr0 ?addr0 //; apply: ltn_trans hlt _; exact: ltnSn. +Qed. + +(* algorithme applique a delta_i (ligne n ,colonne i)*) + +(*Lemma coef_algo_delta_col_i:*) +Lemma dcn_deltan : forall n i A B, de_casteljau A B (delta i%nat) n i = A ^+ n. +Proof. +elim=> [|n ihn] i A B /=; first by rewrite /delta eqxx expr0. +by rewrite !ihn dc_delta_lt ?ltnSn // mulr0 exprS addr0. +Qed. + +(* algorithme applique a delta_i (colonne k avec k < i - j, ligne j avec j < i)*) +(*Lemma coef_algo_delta_ligne_infi_k:*) +Lemma dc_delta_gt : forall j i A B, (j < i)%nat -> + forall k, (k < i - j)%nat -> de_casteljau A B (delta i) j k = 0. +Proof. +elim=> [| j ihj] i A B hltji k hltkd /=. + by move: hltkd; rewrite subn0 ltn_neqAle /delta eq_sym; case/andP; move/negPf->. +have ltij : (j < i)%nat by apply: ltn_trans hltji; rewrite ltnSn. +rewrite !ihj // ?mulr0 ?addr0 //; first by rewrite -subnSK. +by apply: ltn_trans hltkd _; rewrite -[(i - j)%nat]subnSK. +Qed. + +(* pourquoi on a un add_rec qui nous saute la figure??? *) + +Lemma dc_delta_tail : forall i k A B, + de_casteljau A B (delta i) (i + k)%nat 0 = A ^+ k * B ^+ i *+'C(k + i, i). +Proof. +elim=> [|i ihi] k A B /=; rewrite -?addnE. + by rewrite add0n addn0 /= expr0 mulr1 bin0 dcn_deltan mulr1n. +rewrite dc_deltaS ihi. +elim: k => [|k ihk] /=. + rewrite !add0n !expr0 !addn0 !mul1r dc_delta_gt ?mulr0 ?add0r 1?mulrC ?subSnn //. + by rewrite !binn !mulr1n exprS mulrC. +rewrite !addnS /= dc_deltaS ihi ihk !addnS !addSn !mulrnAr mulrA -exprS. +rewrite [_ * B^+ i]mulrC mulrA -exprS [B^+_ * _]mulrC -mulrnDr. +by congr (_ *+ _). +Qed. + +(* Lemma algo_reverse:*) +Lemma dc_reverse b (A B : R) p : forall i k, + (i <= p)%N -> + (k <= p - i)%N -> + de_casteljau B A (fun t => b (p - t)%N) i k = de_casteljau A B b i (p - (i + k)). +Proof. +elim=> [| i ihi] k hip hk /=; first by rewrite add0n. +rewrite addrC; congr (_ + _). + by rewrite ihi ?(ltnW hip) ?addnS ?addSn // -[(p - i)%N]subnSK. +rewrite ihi ?(leq_trans hk) // ?leq_sub2l // ?(ltnW hip) //=. +rewrite addSn -subnSK //. +by move:hk; rewrite -ltn_subRL -ltnS subnSK. +Qed. + +End DeltaSeqs. + +Section weighted_sum. + +(* TODO : I don't know what the right type is. *) +Variable R : rcfType. + +Lemma size_weighted_sum_leq (A :eqType) (r : seq A) m (f : A -> R) + (g : A -> {poly R}) : + (forall i, i \in r -> (size (g i) <= m)%N) -> + (size (\sum_(i <- r) f i *: g i)%R <= m)%N. +Proof. +elim: r => [_ | n r IH cg]; first by rewrite big_nil polyseq0. +rewrite big_cons (leq_trans (size_add _ _)) // geq_max. +have sn : (size (f n *: g n) <= m)%N. + case fn : (f n == 0); first by rewrite (eqP fn) scale0r size_poly0. + rewrite size_scale; last by rewrite fn. + by apply: (cg n); rewrite in_cons eqxx. +by rewrite sn /=; apply: IH => i ir; apply: cg; rewrite in_cons ir orbT. +Qed. + +End weighted_sum. + +(* NB(2022/07/04): MathComp PR in progress, use eq_poly *) +Lemma poly_ext (R : ringType) (n : nat) (E1 E2 : nat -> R) : + (forall i : nat, (i < n)%N -> E1 i = E2 i) -> + \poly_(i < n) E1 i = \poly_(i < n) E2 i. +Proof. +by move=> E; rewrite !poly_def; apply: eq_bigr => i _; rewrite E. +Qed. + +Section bernp. +Variables (R : rcfType) (a b : R) (deg : nat). + +(* elements of the Bernstein basis of degree p *) +Definition bernp (i : nat) : {poly R} := + ((b - a)^-deg)%:P * ('X - a%:P)^+i * (b%:P - 'X)^+(deg - i) *+ 'C(deg, i). + +Lemma size_bernp (neqab : a != b) (i : nat) : + (i <= deg)%N -> size (bernp i) = deg.+1. +Proof. +move=> id; rewrite /bernp. +rewrite -!mulrnAl -polyCMn -mulrA. +rewrite size_Cmul. + rewrite size_monicM. + rewrite size_exp_XsubC. + have <- : (-1)%:P * ('X - b%:P) = (b%:P - 'X). + by rewrite mulrBr polyCN !mulNr -polyCM mul1r opprK addrC mul1r. + rewrite exprMn_comm; last by apply: mulrC. + rewrite -polyC_exp size_Cmul; last first. + rewrite exprnP; apply: expfz_neq0. + by rewrite oppr_eq0 oner_neq0. + by rewrite size_exp_XsubC addSn /= addnS subnKC. + by apply/monic_exp/monicXsubC. + rewrite exprnP expfz_neq0 // -size_poly_eq0. + have -> : b%:P - 'X = (-1)%:P * 'X + b%:P. + by rewrite addrC polyCN mulNr mul1r. + rewrite size_MXaddC size_polyC. + by rewrite polyCN oppr_eq0 (negbTE (oner_neq0 _)) andFb. +rewrite mulrn_eq0 negb_or. +rewrite invr_neq0 ?andbT; first by rewrite -lt0n bin_gt0. +by rewrite expf_neq0 // subr_eq0 eq_sym. +Qed. + +Lemma bernp_gt0 i x : (i <= deg)%N -> a < x < b -> + 0 < (bernp i).[x]. +Proof. +move=> id /andP [ax xb]; rewrite /bernp hornerMn pmulrn_lgt0; last first. + by rewrite bin_gt0. +rewrite !hornerE. +apply mulr_gt0; first apply mulr_gt0. + by rewrite invr_gt0 exprn_gt0 // subr_gt0 (lt_trans ax). + by rewrite exprn_gt0 // subr_gt0. +by rewrite exprn_gt0 // subr_gt0. +Qed. + +End bernp. + +Section BernsteinPols. +Variables (R : rcfType) (a b : R) (deg : nat). +Hypothesis neqab : a != b. + +Definition relocate (q : {poly R}) : {poly R}:= + let s := size q in + (* 1st case : degree of q is too large for the current basis choice *) + if (deg.+1 < s)%N then 0 + else + (recip deg ((q \shift (- 1)) \scale (b - a))) \shift - a. + +Lemma recipE (q : {poly R}) : (size q <= deg.+1)%N -> + recip deg q = \poly_(i < deg.+1) q`_(deg - i). +Proof. +move=> sq. +have t : forall n m (E : nat -> R), 'X ^+ n * \poly_(i < m) E i = + \poly_(i < m + n) (E (i - n)%N *+ (n <= i)%N). + elim=> [ | n IH] m E. + rewrite expr0 mul1r addn0; rewrite !poly_def; apply: eq_bigr => i _. + by rewrite subn0 leq0n mulr1n. + rewrite exprS -mulrA IH !poly_def. + rewrite addnS big_ord_recl. + rewrite [X in _ *+ (n < X)]/nat_of_ord /= mulr0n scale0r add0r big_distrr. + apply: eq_bigr; move=> [i ci] _ /=; rewrite /bump leq0n add1n ltnS subSS. + by rewrite mulrC -scalerAl exprS mulrC. +rewrite /recip t subnKC // !poly_def; apply: eq_bigr. +move=> [i ci] _ /=; congr (_ *: _). +case h : (deg.+1 - size q <= i)%N. + rewrite mulr1n; congr (q`_ _); apply/eqP. + rewrite -(eqn_add2r (i - (deg.+1 - size q)).+1) subnK; last first. + by rewrite -(ltn_add2r (deg.+1 - size q)) subnK // addnC subnK. + rewrite -subSn // addnBA; last by apply/(leq_trans h)/leqnSn. + by rewrite addnS subnK // subKn. +move/negP: h;move/negP; rewrite -ltnNge => h. +rewrite mulr0n nth_default //. +rewrite -(leq_add2r i.+1) -subSS subnK //. +by rewrite addnC -(subnK sq) leq_add2r. +Qed. + +Lemma size_recip (q : {poly R}) : + (size q <= deg.+1 -> size (recip deg q) <= deg.+1)%N. +Proof. by move=> s; rewrite recipE // size_poly. Qed. + +Lemma poly_extend (m n : nat) (E : nat -> R) : + (m <= n)%N -> (forall i : nat, (m <= i < n)%N -> E i = 0) -> + \poly_(i < m) E i = \poly_(i < n) E i. +Proof. +move=> c e; rewrite !poly_def. +rewrite (big_ord_widen n (fun i => E i *: 'X^i) c) big_mkcond /=. +apply: eq_bigr; move=> [i ci] _ /=; case h: (i < m)%N => //. +rewrite e; first by rewrite scale0r. +by rewrite ci andbT leqNgt h. +Qed. + +Lemma recipK (q : {poly R}) : (size q <= deg.+1)%N -> + recip deg (recip deg q) = q. +Proof. +move=> s; rewrite recipE; last by rewrite size_recip. +rewrite -{2}[q]coefK (poly_extend s). + apply: poly_ext => i c; rewrite recipE // coef_poly. + rewrite subKn; last by rewrite -ltnS. + by rewrite (leq_ltn_trans _ (ltnSn deg)) // leq_subr. +by move=> i c; rewrite nth_default //; case/andP: c. +Qed. + +Lemma recipD : forall q1 q2 : {poly R}, (size q1 <= deg.+1)%N -> + (size q2 <= deg.+1)%N -> recip deg (q1 + q2) = recip deg q1 + recip deg q2. +Proof. +move=> q1 q2 s1 s2; rewrite !recipE // ?poly_def; last first. + by rewrite (leq_trans (size_add _ _)) // geq_max s1 s2. +have t : forall i : 'I_deg.+1, true -> (q1 + q2)`_(deg.+1 - i.+1) *: 'X^i = + q1`_(deg.+1 - i.+1) *: 'X^i + q2`_(deg.+1 - i.+1) *: 'X^i. + by move=> [i ci] _ /=; rewrite coef_add_poly scalerDl. +by rewrite (eq_bigr _ t) big_split. +Qed. + +Lemma recipZ (q : {poly R}) c : + (size q <= deg.+1)%N -> recip deg (c *: q) = c *: recip deg q. +Proof. +move=> s; rewrite !recipE // ?poly_def; last first. + case h : (c == 0); first by rewrite (eqP h) scale0r size_poly0. + by rewrite size_scale ?h. +rewrite -[_ *: (\sum_(_ < _) _)]mul_polyC big_distrr; apply:eq_bigr. +by move=> [i ci] _ /=; rewrite coefZ mul_polyC scalerA. +Qed. + +Lemma recipP (q : {poly R}) : size q = deg.+1 -> + recip deg q = reciprocal_pol q. +Proof. by move=> s; rewrite /recip s subnn expr0 mul1r. Qed. + +Lemma recip_scale_swap (q : {poly R}) c : c != 0 -> (size q <= deg.+1)%N -> + recip deg (q \scale c) = (c ^+ deg)%:P * recip deg q \scale c^-1. +Proof. +move=> c0 sz; rewrite !recipE //; last by rewrite size_scaleX. +rewrite !poly_def big_distrr /=. +rewrite [_ \scale c^-1]/scaleX_poly linear_sum; apply: eq_bigr. +move=> [i ci] _ /=; rewrite scaleX_polyE coef_poly. +case h: (deg - i < size q)%N; last first. + rewrite scale0r nth_default; last by rewrite leqNgt h. + by rewrite scale0r mulr0 comp_poly0. +rewrite comp_polyM comp_polyC comp_polyZ poly_comp_exp comp_polyX. +rewrite (mulrC 'X) exprMn scalerAl -!mul_polyC -!polyC_exp mulrA -!polyCM. +rewrite mulrA mulrAC [q`_ _ * _]mulrC; congr (_ %:P * _); congr (_ * _). +case h' : (i < deg)%N; first by rewrite exprVn expfB. +have -> : i = deg by apply/eqP; move: ci; rewrite ltnS leq_eqVlt h' orbF. +by rewrite subnn expr0 exprVn mulfV // expf_neq0. +Qed. + +Lemma bern_coeffs_mon : forall i, (i <= deg)%N -> + relocate 'X^i = ((b - a)^+deg * 'C(deg, i)%:R^-1)%:P * bernp a b deg (deg - i)%N. +Proof. +have nsba0 : ~~ (b - a == 0) by rewrite subr_eq0 eq_sym. +move=> i leqip. +rewrite /bernp polyCM mulrAC -mulr_natr !mulrA -polyCM mulfV; last first. + by rewrite expf_eq0 (negbTE nsba0) andbF. +rewrite mul1r -!mulrA -polyCMn -polyCM bin_sub // mulfV; last first. + by rewrite pnatr_eq0 -lt0n bin_gt0. +rewrite subKn // mulr1. +rewrite /relocate /recip size_polyXn ltnNge ltnS leqip /= shift_polyXn. +have -> // : forall c : R, c != 0 -> + (('X + (-1)%:P)^+ i) \scale c = ('X * c%:P + (-1)%:P)^+ i. + move=> c hc; rewrite scaleX_polyE size_factor_expr. + rewrite [(_ * _ + _) ^+ _]exprDn. + rewrite (reindex_inj rev_ord_inj) /=. + rewrite power_monom [LHS]poly_def; apply: eq_bigr => j _. + rewrite coef_poly subSS; have -> : (j < i.+1)%N by case j. + rewrite subKn; last by case j. + rewrite exprMn_comm; last by exact: mulrC. + rewrite -mulrA (mulrCA 'X^j) (mulrC 'X^j) -!polyC_exp !mul_polyC. + by rewrite scalerA !scalerMnl -(mulrC (c ^+ j)) mulrnAr bin_sub //; case j. +have -> // : forall c:R, c != 0 -> + reciprocal_pol (('X * c%:P + (-1)%:P) ^+ i) = (c%:P - 'X)^+i. + move=> c hc; rewrite reciprocalX reciprocal_monom // addrC. + by congr ((_ + _) ^+ _); rewrite mulrC mul_polyC scaleNr scale1r. +rewrite size_amul_expr // subSS /shift_poly comp_polyM !poly_comp_exp. +rewrite comp_polyD linearN /= !comp_polyX comp_polyC opprD -!polyCN opprK. +by rewrite polyCB addrAC !addrA addrK. +Qed. + +Lemma scaleS (p : {poly R}) (u v : R) : + (p \scale u) \scale v = p \scale (u * v). +Proof. +rewrite /scaleX_poly -comp_polyA comp_polyM !comp_polyC comp_polyX. +by rewrite -mulrA -polyCM [v * u]mulrC. +Qed. + +Lemma scaleZ (p : {poly R}) u v : (u *: p) \scale v = u *: (p \scale v). +Proof. +by rewrite /scaleX_poly linearZ. +Qed. + +Lemma scaleD (p q : {poly R}) u : (p + q) \shift u = p \shift u + (q \shift u). +Proof. +by apply: linearD. +Qed. + +(* TODO : move to another section and abstract over deg a b, maybe *) +Lemma recip0 : recip deg (0 :{poly R}) = 0. +Proof. +rewrite recipE; last by rewrite size_poly0. +by rewrite poly_def; apply: big1 => i _; rewrite polyseq0 nth_nil scale0r. +Qed. + +Lemma Mobius0 : Mobius deg a b (0 : {poly R}) = 0. +Proof. +by rewrite /Mobius /shift_poly linear0 /scaleX_poly !linear0 recip0 linear0. +Qed. + +Lemma recip_weighted_sum n (f : nat -> R) (g : nat -> {poly R}) : + (forall i : 'I_n, (size (g i) <= deg.+1)%N) -> + recip deg (\sum_(i < n) f i *: g i) = \sum_(i < n) f i *: (recip deg (g i)). +Proof. +elim: n => [ | n IH cg]; first by rewrite !big_ord0 recip0. +rewrite !big_ord_recr /=. +rewrite recipD; first last. + case fn0 : (f n == 0); first by rewrite (eqP fn0) scale0r size_poly0. + by rewrite size_scale ?fn0 // (cg ord_max). + apply: size_weighted_sum_leq. + by move=> [i ci] _; apply: (cg (Ordinal _)); rewrite ltnS ltnW. +rewrite IH ?recipZ //; first by apply: (cg ord_max). +by move=> [i ci]; apply: (cg (Ordinal _)); rewrite ltnS ltnW. +Qed. + +Lemma recip_sum n (g : nat -> {poly R}) : + (forall i : 'I_n, (size (g i) <= deg.+1)%N) -> + recip deg (\sum_(i < n) g i) = \sum_(i < n) recip deg (g i). +move=> cg; have bigc : forall i : 'I_n, true -> g i = 1 *: g i. + by move=> i _; rewrite scale1r. +rewrite (eq_bigr _ bigc). +rewrite (recip_weighted_sum (fun i => 1%R)); last by []. +by apply: eq_bigr=> i _; rewrite scale1r. +Qed. + +Lemma MobiusZ x (p : {poly R}) : +(* TODO: remove the size condition, but need to do it also for recipZ *) + (size p <= deg.+1)%N -> + Mobius deg a b (x *: p) = x *: Mobius deg a b p. +Proof. +move=> s; rewrite /Mobius /shift_poly /scaleX_poly /=. +rewrite !linearZ recipZ; last first. + rewrite /= !size_comp_poly2 //; first by rewrite size_XaddC. + by rewrite size_XmulC // subr_eq0 eq_sym. +by rewrite /= linearZ. +Qed. + +Lemma Mobius_weighted_sum n (f : nat -> R) (g : nat -> {poly R}) : + (forall i : 'I_n, (size (g i) <= deg.+1)%N) -> + Mobius deg a b (\sum_(i < n) f i *: g i) = + \sum_(i < n) f i *: Mobius deg a b (g i). +Proof. +rewrite /Mobius /shift_poly /scaleX_poly !linear_sum /= => cg. +have cbig : forall i: 'I_n, true -> + ((f i *: g i) \Po ('X + a%:P) \Po 'X * (b - a)%:P) = + f i *: ((g i \Po ('X + a%:P)) \Po 'X * (b - a)%:P). + by move=> i _; rewrite !linearZ. +rewrite (eq_bigr _ cbig). +rewrite (@recip_weighted_sum _ _ (fun i => (g i \shift a) \scale _)); + last first. + move=> i; rewrite !size_comp_poly2; first by apply: cg. + by apply: size_XaddC. + by apply: size_XmulC; rewrite subr_eq0 eq_sym. +by rewrite linear_sum; apply: eq_bigr => i _; rewrite linearZ. +Qed. + +Lemma relocate_weighted_sum n (f : nat -> R) (g : nat -> {poly R}) : + (forall i : 'I_n, (size (g i) <= deg.+1)%N) -> + relocate (\sum_(i < n) f i *: g i) = \sum_(i < n) f i *: relocate (g i). +Proof. +rewrite /relocate /shift_poly /scaleX_poly linear_sum /= => cg. +have s : (size (\sum_(i < n) (f i *: g i))%R <= deg.+1)%N. + apply: (leq_trans (size_sum _ _ _)). + by apply/bigmax_leqP => i _; apply/(leq_trans (size_scale_leq _ _))/cg. +rewrite ltnNge s linear_sum /=. +have s' : forall i : 'I_n, + (size (f i *: g i \Po ('X + (-1)%:P) \Po ('X * (b - a)%:P))%R <= deg.+1)%N. + move=> i; rewrite !size_comp_poly2. + by apply/(leq_trans (size_scale_leq _ _))/cg. + by apply: size_XaddC. + by apply: size_XmulC; rewrite subr_eq0 eq_sym. +rewrite (@recip_sum _ (fun i => (f i *: g i \shift -1) \scale (b - a)) s'). +rewrite linear_sum. +apply: eq_bigr => i _ /=. +rewrite ltnNge cg /=. +rewrite /shift_poly /scaleX_poly !linearZ recipZ ?linearZ //=. +rewrite !size_comp_poly2 //; first by apply: size_XaddC. +by apply: size_XmulC; rewrite subr_eq0 eq_sym. +Qed. + +Lemma scalep1 (p : {poly R}) : p \scale 1 = p. +Proof. +by rewrite /scaleX_poly mulr1 comp_polyXr. +Qed. + +Lemma MobiusK (q : {poly R}) : (size q <= deg.+1)%N -> + Mobius deg a b (relocate q) = (b-a) ^+deg *: q. +Proof. +move=> s; rewrite /relocate /Mobius ltnNge s /= /shift_poly. +rewrite -[X in (_ \Po (_ + _)) \Po (_ + X%:P)]opprK [(- - _)%:P]polyCN. +have ba : b - a != 0 by rewrite subr_eq0 eq_sym. +have bav : (b - a)^-1 != 0 by rewrite invr_eq0. +have s1 : (size (q \Po ('X + (-1)%:P)) <= deg.+1)%N. + by rewrite size_comp_poly2 // size_XaddC. +have rr : GRing.rreg ((b - a) ^+ deg). + by rewrite /GRing.rreg; apply: mulIf; rewrite expf_eq0 (negbTE ba) andbF. +rewrite comp_polyXaddC_K !recip_scale_swap //; last first. + by rewrite size_scaleX // mulrC rreg_size ?size_recip. + by rewrite mulrC rreg_size ?size_recip. +rewrite !mul_polyC recipZ; last first. + by apply: size_recip; rewrite size_comp_poly2 // size_XaddC. +rewrite !scalerA exprVn mulVf ?scale1r; last first. + by rewrite expf_eq0 (negbTE ba) andbF. +rewrite invrK recipK; last by rewrite size_comp_poly2 // size_XaddC. +rewrite !scaleZ scaleS mulfV // scalep1 linearZ /=. +rewrite -[X in (_ \Po _) \Po (_ + X%:P)]opprK (polyCN (-1)). +by rewrite comp_polyXaddC_K. +Qed. + +Lemma relocateK (q : {poly R}) : (size q <= deg.+1)%N -> + relocate (Mobius deg a b q) = (b-a) ^+deg *: q. +Proof. +move=> s; rewrite /relocate /Mobius. +rewrite size_comp_poly2; last by rewrite size_XaddC. +set sc := ((q \shift _) \scale _). +set sz := size _. +have dif : b - a != 0 by rewrite subr_eq0 eq_sym. +have t : (size sc <= deg.+1)%N. + by rewrite size_scaleX // size_comp_poly2 //; apply: size_XaddC. +have t' : (sz <= deg.+1)%N by apply: size_recip. +rewrite ltnNge t' /= -shift_polyD addNr. +rewrite [_ \shift 0]/shift_poly addr0 comp_polyXr. +(* TODO: we miss a scaleX_poly_linear canonical structure. + and lemma about composing scale operations. *) +rewrite recip_scale_swap // recipK // /sc mul_polyC /scaleX_poly linearZ /=. +rewrite -comp_polyA comp_polyM comp_polyX comp_polyC -mulrA -polyCM. +rewrite mulVf // mulr1 comp_polyXr. +transitivity ((b - a) ^+ deg *: ((q \shift a) \shift - a)). + exact: linearZ. +by rewrite /= shift_polyDK. +Qed. + +Lemma relocate0 (p : {poly R}) : (size p <= deg.+1)%N -> + (relocate p == 0) = (p == 0). +Proof. +move=> s; apply/idP/idP; last first. + move/eqP=> ->; rewrite /relocate /shift_poly /scaleX_poly !linear0. + by rewrite size_poly0 ltn0 recip0 linear0. +have bmax : (b - a) ^+ deg != 0 by rewrite expf_neq0 // subr_eq0 eq_sym. +move/eqP=> r0; rewrite -[p]mul1r -[1]/1%:P -(mulVf bmax) polyCM -mulrA. +rewrite !mul_polyC -MobiusK // r0 /Mobius /shift_poly /scaleX_poly !linear0. +by rewrite recip0 linear0 scaler0. +Qed. + +Lemma Mobius_bernp i : (i <= deg)%N -> + Mobius deg a b (bernp a b deg i) = ('C(deg, i))%:R *: 'X ^+ (deg - i). +Proof. +move=> ci; set u := _%:R; rewrite -(mul1r (bernp a b deg i)) -[1]/(1%:P). +have t : (b - a)^+deg/('C(deg, i))%:R != 0. + apply: mulf_neq0; first by rewrite expf_neq0 // subr_eq0 eq_sym. + by rewrite invr_neq0 // pnatr_eq0 -lt0n bin_gt0. +rewrite -(mulVf t) {t} polyCM -mulrA. +rewrite -bin_sub // -[X in bernp a b deg X](subKn ci) -bern_coeffs_mon; last first. + by rewrite leq_subr. +rewrite mul_polyC MobiusZ. + rewrite MobiusK; last first. + by rewrite size_polyXn ltnS leq_subr. + rewrite invfM scalerA mulrAC mulVf; last first. + by rewrite expf_neq0 // subr_eq0 eq_sym. + by rewrite mul1r invrK bin_sub. +(* TODO : make a seprate lemma from this goal. *) +rewrite /relocate. +rewrite ltnNge size_polyXn (leq_ltn_trans _ (ltnSn _)) ?leq_subr //=. +rewrite size_comp_poly2; last by rewrite size_XaddC. +rewrite size_recip // !size_comp_poly2 //. + by rewrite size_polyXn (leq_ltn_trans _ (ltnSn _)) // leq_subr. + by rewrite size_XaddC. +by rewrite size_XmulC // subr_eq0 eq_sym. +Qed. + +Lemma monomial_free n (l : nat -> R): + \sum_(i < n) l i *: 'X ^+i == 0 -> forall i, (i < n)%N -> l i = 0. +Proof. +elim:n => [ | n IH] /=; first by move=> _ i; rewrite ltn0. +rewrite big_ord_recr /=. +case r : (l n == 0). + rewrite (eqP r) scale0r addr0; move/IH=>{IH} II i. + rewrite ltnS leq_eqVlt => /predU1P[->|]. + exact/eqP. + exact: II. +rewrite addr_eq0 => abs. +case/negP: (negbT (ltnn n)). +rewrite [X in (X <= _)%N](_ : _ = size (l n *: 'X^n)); last first. + by rewrite -mul_polyC size_Cmul ?r // size_polyXn. +rewrite -size_opp -(eqP abs) size_weighted_sum_leq //. +by move=> [i ci]; rewrite /= size_polyXn. +Qed. + +Lemma bernp_free : forall (l : nat -> R), + \sum_(i < deg.+1) l i *: bernp a b deg i = 0 -> forall i : 'I_deg.+1, l i = 0. +Proof. +have bman0 : b - a != 0 by rewrite subr_eq0 eq_sym. +move/(expf_neq0 deg): (bman0) => bmadeg. +move=> l; rewrite -[X in X = 0]scale1r -(mulVf bmadeg) -scalerA. +rewrite -relocateK; last first. + apply (leq_trans (size_sum _ _ _)); apply/bigmax_leqP. + move=> i _; apply: (leq_trans (size_scale_leq _ _)). + by rewrite size_bernp ?leqnn //; case : i => i /=; rewrite ltnS. +move/eqP; rewrite scaler_eq0 invr_eq0 (negbTE bmadeg) orFb. +have t : forall i : 'I_deg.+1, (size (bernp a b deg i) <= deg.+1)%N. + by move=> [i ci] /=; rewrite size_bernp. +rewrite (Mobius_weighted_sum l t) {t}. +have xdi : forall i, (i < deg.+1)%N -> size (('X : {poly R}) ^+i) = i.+1. + by move=> i; rewrite -['X]subr0 size_exp_XsubC. +have t: forall i : nat, (i < deg.+1)%N -> Mobius deg a b (bernp a b deg i) = + ('C(deg, i)%:R)%:P * 'X ^+ (deg - i). + move=> i ci. + rewrite (_ : bernp a b deg i = + ('C(deg, i)%:R / (b - a)^+ deg)%:P * + (((b - a) ^+ deg / 'C(deg, deg - i)%:R)%:P * + bernp a b deg (deg - (deg - i)))); last first. + rewrite mulrA -polyCM !mulrA mulfVK //. + rewrite bin_sub // mulfV ?mul1r ?subKn // pnatr_eq0. + by rewrite -lt0n bin_gt0. + have di : (deg - i <= deg)%N by rewrite leq_subr. + rewrite -bern_coeffs_mon // !mul_polyC MobiusZ; last first. + rewrite /relocate /shift_poly /scaleX_poly xdi; last by rewrite ltnS. + rewrite ltnNge ltnS di /=. + rewrite size_comp_poly2; last by rewrite size_XaddC. + rewrite size_recip // !size_comp_poly2 ?xdi ?ltnS //. + by rewrite size_XaddC. + by rewrite size_XmulC. + by rewrite MobiusK ?xdi ?ltnS // -!mul_polyC mulrA -polyCM mulfVK. +rewrite relocate0; last first. + have T : forall i : 'I_deg.+1, + (size (Mobius deg a b (bernp a b deg i)) <= deg.+1)%N. + move=> [i ci]; rewrite t //. + rewrite size_Cmul; last by rewrite pnatr_eq0 -lt0n bin_gt0. + by rewrite xdi; rewrite ltnS leq_subr. + apply: size_weighted_sum_leq => i _; apply: T. +rewrite -(big_mkord (fun _ => true) + (fun i => l i *: Mobius deg a b (bernp a b deg i))) big_nat_rev /= add0n. +have t' : forall i, (0 <= i < deg.+1)%N -> + l (deg.+1 - i.+1)%N *: Mobius deg a b (bernp a b deg (deg.+1 - i.+1)) = + (l (deg - i)%N * ('C(deg, deg - i))%:R) *: 'X^i. + move=> i;case/andP=> _ ci. + rewrite subSS t; last by rewrite ltnS leq_subr. + by rewrite -!mul_polyC mulrA polyCM subKn. +rewrite (eq_big_nat _ _ t') big_mkord => t2. +have t3 := (@monomial_free _ + (fun i => l (deg - i)%N * ('C(deg, deg - i))%:R) t2). +move=> [i ci] /=. +have t4 : ('C(deg, i))%:R != 0 :> R. + by rewrite pnatr_eq0 -lt0n bin_gt0. +apply: (mulIf t4); rewrite mul0r. +have t5: (i <= deg)%N by rewrite -ltnS. +rewrite -(subKn t5); apply: t3. +by rewrite ltnS leq_subr. +Qed. + +End BernsteinPols. + +Section dicho_proofs. + +Variable R : rcfType. + +Lemma dicho'_delta_bern (a b m : R) k p (alpha := (b - m) * (b - a)^-1) + (beta := ((m - a) * (b - a)^-1)) : + a != b -> m != a -> (k <= p)%N -> + bernp a b p k = + \sum_(j < p.+1)((dicho' alpha beta (delta R k) j)%:P * bernp a m p j). +Proof. +move=> dab dma hlt1. +rewrite -(big_mkord +(fun _ => true) +(fun j => (dicho' alpha beta (delta R k) j)%:P * bernp a m p j)). +rewrite (big_cat_nat _ _ _ (leq0n k)) //=; last by apply: leq_trans hlt1 _; exact: leqnSn. +rewrite (_ : \sum_( _ <= i0 < _ ) _ = 0) /= ?add0r; last first. + rewrite big1_seq //= => j; rewrite mem_iota add0n subn0; case/andP=> _ h. + by rewrite dc_delta_head // polyC0 mul0r. +rewrite -{2}(add0n k) big_addn. +have h : forall i0, (0 <= i0 < p - k)%nat -> + (dicho' (m - a) (b - m) (delta R k) (i0 + k))%:P * bernp a m p (i0 + k) = + (( (m - a) ^+ i0) * (b - m) ^+ k)%:P * bernp a m p (i0 + k) *+ 'C(i0 + k, k). + by move=> j h; rewrite /dicho' addnC dc_delta_tail polyCMn -mulrnAl addnC. +have -> : bernp a b p k = + (('X - a%:P)^+k * ((b - a)^-k)%:P) * + ((b%:P - 'X )^+(p - k) * ((b - a)^-(p - k))%:P) *+'C(p, k). + rewrite /bernp -!mulrA. congr (_ *+ _). + rewrite [_ * (_)%:P]mulrC [((b - a)^-k)%:P * _]mulrA -polyCM. + by rewrite -invfM -exprD subnKC // !mulrA [_ %:P * _]mulrC. +have -> : (('X - a%:P) ^+ k * ((b - a) ^- k)%:P) = + (beta^+k)%:P * (('X - a%:P) ^+ k * ((m - a) ^- k)%:P). + rewrite /beta expr_div_n polyCM !mulrA -[_ * (_ ^+k)]mulrC !mulrA (mulrAC _ (((m - a) ^+ k)%:P)). + rewrite -!mulrA -polyCM mulfV ?polyC1 ?mulr1 ?expf_eq0 ?subr_eq0 //. + by move/negPf: dma => ->; rewrite andbF. +rewrite -(exprVn (b - a)) [(_ ^-1 ^+ _)%:P]polyC_exp. +rewrite -exprMn_comm; last by exact: mulrC. +have -> : (b%:P - 'X) * ((b - a)^-1)%:P = + ((m%:P - 'X) * (m - a)^-1%:P) + (alpha%:P * ('X - a%:P) * (m - a)^-1%:P). + (* a ring tactic would be nice here *) + rewrite [(m%:P - _) * _]mulrDl mulrDr [(alpha%:P * _ + _) * _]mulrDl. + rewrite (mulrC _ 'X) -(mulrA 'X) [_ + (- 'X * _)]addrC mulNr -mulrN. + rewrite addrAC addrA -mulrDr -mulN1r -mulrDl. + rewrite -(polyCN 1) -polyCD /alpha. + have -> : -1 = (a-b)/(b-a). + by rewrite -opprB mulNr mulfV // subr_eq0 eq_sym. + rewrite -mulrDl addrA addrNK -(opprB m a). + rewrite -polyCM !mulNr mulrAC mulfV ?mul1r; last by rewrite subr_eq0. + rewrite polyCN -addrA -mulrDl [_ * - a%:P]mulrC -[-a%:P]polyCN. + rewrite -polyCM -polyCD !mulrA. + have {2}-> : m = m * (b - a) / (b - a) by rewrite mulfK // subr_eq0 eq_sym. + rewrite -[_ + _ /(b-a)]mulrDl !mulrDr addrA addrAC [-a * -m]mulrN. + rewrite [-a * m]mulrC addrNK [_ + m * b]addrC -mulrDl -polyCM. + rewrite [_ * b]mulrC mulrAC mulfK; last by rewrite subr_eq0. + by rewrite mulrN -mulNr polyCM -mulrDl addrC. +rewrite [_^+ (p - k)]exprDn /= subSn //. +rewrite -(big_mkord (fun _ => true) (fun i => ((m%:P - 'X) * ((m - a)^-1)%:P) ^+ (p - k - i) * + (alpha%:P * ('X - a%:P) * ((m - a)^-1)%:P) ^+ i *+ 'C( + p - k, i))). +rewrite big_distrr /= (big_morph _ (mulrnDl ('C(p, k))) (mul0rn _ _)). +apply: congr_big_nat=> // i /= hi. +rewrite /dicho' [(i + k)%nat]addnC dc_delta_tail /bernp. +rewrite !mulrnAr polyCMn mulrnAl -!mulrnA; congr (_ *+ _); last first. + rewrite addnC -util_C ?leq_addr //. + by rewrite mulnC; congr (_ * _)%N; rewrite addnC addnK. + by move:hi; rewrite ltnS -(leq_add2l k) subnKC. +set Xa := ('X - a%:P); set Xb := (_ - 'X). +rewrite [alpha^+_ * _]mulrC [(beta^+_ * _)%:P]polyCM -!mulrA; congr (_ * _). +rewrite [(alpha%:P * _)]mulrC. +rewrite [(_ * alpha%:P)^+i]exprMn_comm; last by exact: mulrC. +set lhs := (alpha ^+ i)%:P * _; rewrite !mulrA. +rewrite [_ * alpha%:P ^+ i]mulrC /lhs polyC_exp; congr (_ * _)=> {lhs alpha}. +set lhs := _ * (_ * Xb ^+ (p - _)). +rewrite !exprMn_comm; try exact: mulrC. +rewrite [Xa^+i * _]mulrC !mulrA [_ * Xa^+ _]mulrC !mulrA. +rewrite -exprD /lhs [_ * (Xa^+ _ * _)]mulrA [_ * Xa^+ _]mulrC -!mulrA. +rewrite addnC; congr (_ * _)=> {lhs}. +rewrite !mulrA [_ * Xb^+ (p - k - i)]mulrC -!mulrA [Xb^+ _ * _]mulrC. +rewrite subnDA; congr (_ * _); rewrite -!polyC_exp -!polyCM; congr (_ %:P). +rewrite -!exprVn -!exprD; congr ((m -a)^-1 ^+ _). +rewrite subnK; last by []. +by rewrite addnC subnK; last by []. +Qed. + +Lemma dicho'_correct : forall (a b m : R)(alpha := (b - m) * (b - a)^-1) + (beta := ((m - a) * (b - a)^-1))(p : nat)(q : {poly R})(c : nat -> R), + a != b -> + m != a -> + q = \sum_(i < p.+1) c i *: bernp a b p i -> + q = \sum_(j < p.+1) dicho' alpha beta c j *: bernp a m p j. +Proof. +move=> a b m alpha beta p q c neqab neqma qdef. +have {neqma qdef} -> : q = + \sum_(j < p.+1) \sum_(i < p.+1) + (c i)%:P * (dicho' alpha beta (delta R i) j)%:P * bernp a m p j. + rewrite exchange_big /= qdef; apply: congr_big; [by [] | by [] |]. + case=> k hk _ /=. + have hk': (k <= p)%N by exact: hk. + rewrite (dicho'_delta_bern neqab neqma hk'). + rewrite -mul_polyC big_distrr /=; apply: congr_big; [by [] | by [] |]. + by case=> i hi _; rewrite !mulrA. +apply: congr_big; [by [] | by [] |]. +case=> i hi _ /=; rewrite -big_distrl /= -mul_polyC; congr (_ * _). +have -> : dicho' alpha beta c i = + dicho' alpha beta (fun k => \sum_(j < p.+1)(c j) * (delta R j k)) i. + apply: ext_dc=> k _; rewrite add0n => h. + have pk : (k < p.+1)%N by apply: leq_ltn_trans hi. + rewrite (bigD1 (Ordinal pk)) //= /delta eqxx mulr1 big1 ?addr0 //. + case=> j hj /=; move/negPf; case e : (j == k); last by rewrite mulr0. + suff : Ordinal hj = Ordinal pk by move/eqP->. + by apply: val_inj=> /=; apply/eqP. +elim: p i {hi} c alpha beta=> [| p ihp] i c alpha beta /=; set f := dicho' alpha beta. + rewrite big_ord_recl /= big_ord0 /dicho' /= addr0. + rewrite /f /dicho'. + have : forall k, + (0 <= k)%N -> (k <= 0 + i)%N -> + \sum_(j < 1) c j * delta R j k = (c 0%N) * (delta R 0) k. + by move=> k _ _; rewrite big_ord_recl /= big_ord0 addr0. + by move/ext_dc->; rewrite scal_dc polyCM. + rewrite (_ : f _ _ = + f + (fun k : nat => + (\sum_(j < p.+1) c j * delta R j k) + (c p.+1 * delta R p.+1 k)) i); + last first. + by apply: ext_dc=> k _; rewrite add0n=> hki; rewrite big_ord_recr. +rewrite /f /dicho' add_dc polyCD -ihp // big_ord_recr /=; congr (_ + _). +by rewrite scal_dc polyCM. +Qed. + +Lemma bern_swap p i (l r : R) : (i <= p)%N -> bernp r l p i = bernp l r p (p - i). +Proof. +move=> lip; rewrite /bernp subKn // bin_sub //; congr (_ *+ _). +rewrite -[l - r]opprB -[l%:P - 'X]opprB -['X - r%:P]opprB. +rewrite -mulN1r -[-(r%:P - 'X)]mulN1r -[- ('X - l%:P)]mulN1r. +rewrite !exprMn_comm; try exact: mulrC. +rewrite invfM polyCM [_ * ((r - l)^-p)%:P]mulrC. +rewrite -!mulrA; congr (_ * _). +rewrite -exprVn polyC_exp [(- 1)^-1]invrN invr1 polyCN. +rewrite [(r%:P - 'X)^+i * _]mulrC !mulrA polyC1 -!exprD. +by rewrite -addnA subnKC // -signr_odd oddD addbb /= expr0 mul1r. +Qed. + +Lemma bern_rev_coef : forall (p : nat)(a b : R)(c : nat -> R), + \sum_(i < p.+1) c i *: (bernp a b p i) = + \sum_(i < p.+1) c (p - i)%N *: (bernp b a p i). +Proof. +move=> p a b c. +pose t := \sum_(i < p.+1) c (p - i)%N *: bernp a b p (p - i)%N. +transitivity t. + by rewrite (reindex_inj rev_ord_inj) /=; apply: eq_bigl. +apply:eq_bigr => [[i hi]] _ /=. +by rewrite bern_swap ?subKn // leq_subr. +Qed. + +Lemma dicho_correct : forall (a b m : R)(alpha := (b - m) * (b - a)^-1) + (beta := ((m - a) * (b - a)^-1))(p : nat)(q : {poly R})(c : nat -> R), + a != b -> + m != b -> + q = \sum_(i < p.+1) c i *: bernp a b p i -> + q = \sum_(j < p.+1) dicho alpha beta p c j *: bernp m b p j. +Proof. +move=> a b m alpha beta p q c neqab neqmb qdef. +rewrite bern_rev_coef in qdef. +have neqba : b != a by rewrite eq_sym. +rewrite (@dicho'_correct _ _ _ _ _ (fun i => c (p - i)%N) neqba neqmb qdef). +rewrite -(big_mkord +(fun _ => true) (fun j => dicho' ((a - m) / (a - b)) ((m - b) / (a - b)) + (fun i : nat => c (p - i)%N) j *: bernp b m p j)). +rewrite big_nat_rev /= big_mkord; apply: congr_big; [by [] | by [] |]. +move=> [i hi] _ {qdef}; rewrite add0n subSS. +rewrite -bern_swap //; congr (_ *: _); rewrite /dicho' /dicho. +rewrite dc_reverse //= ?leq_subr // addn0 subKn //. +rewrite -opprB -[a - b]opprB -[a - m]opprB -mulN1r -[-(b - a)]mulN1r. +rewrite -[-(m - a)]mulN1r invfM [(- 1)^-1]invrN invr1 -mulrA. +rewrite [(b - m) * _]mulrC !mulrA mulNr mul1r opprK [-1 * _ ]mulrC 2!mulrN1. +by rewrite opprK -/beta mulrC mul1r. +Qed. + +End dicho_proofs. + +Section isolation_tree. + +Variable A : Type. + +Inductive root_info : Type := + | Exact (x : A) + | One_in (x y : A) + | Zero_in (x y : A) + | Unknown (x y : A). + +End isolation_tree. + +Section isolation_algorithm. + +Variable R0 : archiFieldType. + +Let R := {realclosure R0}. + +Definition head_root (f : R -> R) (l : seq (root_info R)) : Prop := + match l with + [::] => True + | Exact x::tl => True + | One_in x y::tl => f x != 0 + | Zero_in x y::tl => f x != 0 + | Unknown x y::tl => f x != 0 + end. + +Definition unique_root_for (f : R -> R) (x y : R) : Prop := + exists z, [/\ x < z < y, f z = 0 & forall u, x < u < y -> f u = 0 -> u = z ]. + +Definition no_root_for (f : R -> R) (x y : R) : Prop := + forall z, x < z < y -> f z != 0. + +Fixpoint read (f : R -> R) (l : seq (root_info R)) : Prop := + match l with + [::] => True + | Exact x::tl => f x = 0 /\ read f tl + | One_in x y::tl => unique_root_for f x y /\ head_root f tl /\ read f tl + | Zero_in x y::tl => no_root_for f x y /\ head_root f tl /\ read f tl + | Unknown x y::tl => read f tl + end. + +Fixpoint isol_rec n d a b (l : seq R) acc : seq (root_info R) := + match n with + O => Unknown a b::acc + | S p => + match changes (seqn0 l) with + | 0%nat => Zero_in a b::acc + | 1%nat => One_in a b::acc + | _ => + let c := (a + b)/2%:R in + let l2 := mkseq (dicho (2%:R^-1) (2%:R^-1) d (fun i => l`_i)) d.+1 in + isol_rec p d a c (mkseq (dicho' (2%:R^-1) (2%:R^-1) (fun i => l`_i)) d.+1) + (if l2`_0 == 0 then + Exact c::isol_rec p d c b l2 acc + else isol_rec p d c b l2 acc) + end + end. + +Lemma cons_polyK : forall p : {poly R}, + cons_poly p.[0] (\poly_(i < (size p).-1) p`_i.+1) = p. +move=> p; rewrite cons_poly_def addrC -[X in _ = X]coefK. +case sz : (size p) => [ | s]. + move/eqP: sz; rewrite size_poly_eq0 => /eqP => sz. + by rewrite sz horner0 polyC0 add0r /= polyseq0 !polyd0 mul0r. +rewrite [s.+1.-1]/= !poly_def big_ord_recl; congr (_ + _). + by rewrite expr0 alg_polyC horner_coef0. +rewrite big_distrl; apply: eq_bigr; move=> [i ci] _ /=. +by rewrite -scalerAl /bump leq0n add1n exprS mulrC. +Qed. + +Lemma poly_border (p : {poly R}) a b: + a < b -> (forall x, a < x < b -> 0 < p.[x]) -> 0 <= p.[a]. +Proof. +move=> ab cp; case p0: (p.[a] < 0); last by rewrite leNgt p0. +have := (cons_polyK (p \Po ('X + a%:P))); rewrite cons_poly_def. +have -> : (p \Po ('X + a%:P)).[0] = p.[a]. + by rewrite horner_comp hornerD hornerC hornerX add0r. +move=> qdec. +have : p = p \Po ('X + a%:P) \Po ('X - a%:P) by rewrite comp_polyXaddC_K. +rewrite -qdec comp_polyD comp_polyC comp_polyM comp_polyX. +set q := \poly_(_ < _) _; move=> pq. +have [ub pu] := (poly_itv_bound (q \Po ('X - a%:P)) a b). +have ub0 : 0 <= ub by rewrite (le_trans _ (pu a _)) // lexx andTb ltW. +set ub' := ub + 1. +have ub'0 : 0 < ub' by rewrite ltr_wpDl. +have ublt : ub < ub' by rewrite ltr_pwDr // ltr01. +pose x := minr (a - p.[a]/ub') (half (a + b)). +have xitv2 : a < x < b. + by case/andP: (mid_between ab)=> A B; rewrite lt_min ltr_pwDr ?A //= + ?gt_min ?B ?orbT // -mulNr mulr_gt0 // ?invr_gt0 // oppr_gt0. +have xitv : a <= x <= b by case/andP: xitv2 => *; rewrite !ltW //. +have := cp _ xitv2. +rewrite [X in X.[x]]pq hornerD hornerC hornerM hornerXsubC. +rewrite -[X in 0 < _ + X]opprK subr_gt0 => abs. +have : x - a <= -p.[a] / ub' by rewrite lerBlDl ge_min mulNr lexx. +rewrite -(ler_pM2r ub'0) mulfVK; last first. + by move:ub'0; rewrite lt0r=>/andP=>[[]]. +have xma :0 < x - a by rewrite subr_gt0; case/andP: xitv2. +move: (pu _ xitv); rewrite lter_norml; case/andP => _ {pu}. +rewrite -[_ <= ub](ler_pM2r xma) => pu2. +rewrite mulrC; have := (lt_le_trans abs pu2) => {pu2} {}abs ab'. +have := (le_lt_trans ab' abs); rewrite ltr_pM2r // ltNge;case/negP. +by rewrite ltW. +Qed. + +Lemma one_root1_unique : + forall q a b, one_root1 q a b -> unique_root_for (horner q) a b. +Proof. +move=> q a b [c [d [k [itv]]]]. +rewrite /pos_in_interval /neg_in_interval1 /slope_bounded2. +move=> itv1 itv2 sl. +case/andP: itv=> ac; case/andP=> cd; case/andP=> db k0. +have qd0 : q.[d] <= 0. + have : (0 <= (-q).[d]). + by apply: (poly_border db) => x xitv; rewrite hornerN lterNE itv2. + by rewrite hornerN lterNE. +have qc0 : 0 <= q.[c] by apply/ltW/itv1; rewrite ac lexx. +have qcd0 : (-q).[c] <= 0 <= (-q).[d] by rewrite !hornerN !lterNE qd0 qc0. +have [x xin] := (poly_ivt (ltW cd) qcd0). +rewrite /root hornerN oppr_eq0 =>/eqP => xr. +exists x; split. +- by case/andP: xin=> cx xd; rewrite (lt_le_trans ac cx) (le_lt_trans xd db). +- by []. +- move=> u; case/andP=> au ub qu0. + case cu : (u <= c). + have : a < u <= c by rewrite cu au. + by move/itv1; rewrite qu0 ltxx. + case ud : (d < u). + have : d < u < b by rewrite ud ub. + by move/itv2; rewrite qu0 ltxx. + have cu' : c <= u. + by apply: ltW; rewrite ltNge cu. + have ud' : u <= d. + by rewrite leNgt ud. + case/andP: xin=> cx xd. + case ux : (u <= x). + have := (sl _ _ cu' ux xd). + rewrite qu0 xr subrr -(mulr0 k) ler_pM2l // subr_le0 => xu. + by apply/eqP; rewrite eq_le ux. + have xu : x <= u. + by apply: ltW; rewrite ltNge ux. + have := (sl _ _ cx xu ud'). + rewrite qu0 xr subrr -(mulr0 k) ler_pM2l // subr_le0 => ux'. + by apply/eqP; rewrite eq_le ux'. +Qed. + +Lemma alternate_1_neq0 (p : {poly R}) : + alternate_1 p -> p != 0. +case/alternate_1P=> l1 [v [l2 [h1]]] _ _ _. +by rewrite -nil_poly h1 {h1}; case: l1 => //. +Qed. + +Lemma all_ge0_cat {R'' : realDomainType} : + {morph (@all_ge0 R'') : x y / x ++ y >-> x && y}. +Proof. by elim=> [ | a x IH y] //=; rewrite IH andbA. Qed. + +Lemma alternate_r d (p : {poly R}) a : + ( 0 < a) -> alternate p -> (size p <= d)%N -> alternate (p + a *: 'X ^+ d). +Proof. +move=> a0 /alternate_P [l1 [x [l2 [y [l3 [P1 P2 P3 P4]]]]]] ps. +apply/alternate_P; exists l1, x, l2, y. +exists (l3 ++ (mkseq (fun i => 0) (d - size p)) ++ [:: a]). +split => //; first last. + case: P4 => P4 P5 P6; split=> //. + rewrite !all_ge0_cat P6 andTb; apply/andP; split; last by rewrite /= ltW. + by apply/(all_nthP 0); move => i; rewrite size_mkseq => W; rewrite nth_mkseq. +(* With "apply/all_nthP" + The previous line introduces an existential that is uncaptured. *) +set m := mkseq _ _; set l := _ ++ _. +have reorg : l = p ++ m ++ [:: a] by rewrite P1 /m -!(catA, cat_cons). +have saxd : size (a *: 'X^d) = d.+1. + by rewrite -mul_polyC size_Cmul ?size_polyXn; last rewrite neq_lt a0 orbT. +have spax : size (p + a *: 'X^d) = d.+1. + by rewrite addrC size_addl // saxd ltnS. +have sreo : size (p ++ m) = d by rewrite size_cat /m size_mkseq addnC subnK. +apply: (@eq_from_nth _ 0). + by rewrite spax reorg catA size_cat sreo /= addn1. +move=> i; rewrite spax ltnS leq_eqVlt=> ib; rewrite coef_add_poly coefZ. +case/predU1P: ib => [->|iltd]. + rewrite [p`_d]nth_default // add0r coefXn eqxx mulr1 reorg catA. + by rewrite nth_cat sreo ltnn subnn. +move: (iltd); rewrite coefXn ltn_neqAle=> /andP [df _]; rewrite (negbTE df). +rewrite mulr0 addr0 reorg catA nth_cat sreo iltd nth_cat. +case tst: (i < size p)%N => //. +rewrite /m nth_mkseq. + by rewrite nth_default // leqNgt tst. +by rewrite ltn_subRL addnC subnK // leqNgt tst. +Qed. + +Lemma all_eq0_seqn0 (l : seq R) : (head 0 (seqn0 l) == 0) = (all_eq0 l). +Proof. +elim: l=> [ | a l IH]; first by rewrite eqxx. +by rewrite /=; case a0: (a == 0) => //=. +Qed. + +Lemma seqn0_last (l : seq R) : head 0 (seqn0 l) != 0 -> + exists l1 x l2, [&& l == l1 ++ x :: l2, x != 0 & all_eq0 l2]. +Proof. +elim: l => [ | a l IH] /=; first by rewrite eqxx. +case a0: (a == 0) => /=. + move/IH=> [l1 [x [l2 /andP [p1 p2]]]]; exists (a::l1), x, l2. + by rewrite (eqP p1) cat_cons eqxx p2. +move=> an0. +case h: (all_eq0 l). + by exists nil, a, l; rewrite /= an0 h eqxx. +move/negbT: h. +rewrite -all_eq0_seqn0; move/IH=>[l1 [x [l2 /andP [p1 p2]]]]. +by exists (a::l1), x, l2; rewrite (eqP p1) p2 cat_cons eqxx. +Qed. + +Lemma first_neg_no_change_all_le0 (l : seq R) : + head 0 (seqn0 l) < 0 -> changes (seqn0 l) = 0%N -> all_le0 l. +Proof. +elim: l=> [ | a l IH] //=; case a0: (a==0)=> /= hsn0. + by rewrite le_eqVlt a0 /=; apply: IH => //; apply/eqP. +case h0: (head 0 (seqn0 l) == 0); move: (h0). + rewrite all_eq0_seqn0 (ltW hsn0) /= => al0 _. + by move: al0; apply: sub_all => x x0; rewrite (eqP x0) lexx. +move=> _ /eqP; rewrite (ltW hsn0) addn_eq0 /= => /andP [p1]/eqP. +apply: IH. +rewrite lt_neqAle h0 /= -(ler_nM2l hsn0) mulr0. +by move: p1; rewrite eqb0 ltNge negbK. +Qed. + +Lemma first_pos_no_change_all_ge0 (l : seq R) : + 0 <= head 0 (seqn0 l) -> changes (seqn0 l) = 0%N -> all_ge0 l. +Proof. +elim: l=> [ | a l IH] //=; case a0: (a==0)=> /= hsn0. + by rewrite le_eqVlt eq_sym a0 /=; apply: IH => //; apply/eqP. +case h0: (head 0 (seqn0 l) == 0); move: (h0). + rewrite all_eq0_seqn0 hsn0 /= => al0 _. + by move: al0; apply: sub_all => x x0; rewrite (eqP x0) lexx. +move=> _ /eqP; rewrite hsn0 addn_eq0 /= => /andP [p1]/eqP. +apply: IH. +have hsn0' : 0 < a by rewrite lt_neqAle eq_sym a0. +rewrite -(ler_pM2l hsn0') mulr0. +by move: p1; rewrite eqb0 ltNge negbK. +Qed. + +Lemma changes1_alternate d (l : seq R) f : (size l <= d.+1)%N -> + (forall i, (i < d.+1)%N -> (0 < f i)) -> + changes (seqn0 l) = 1%N -> 0 <= (seqn0 l)`_0 = true -> + alternate (\sum_(i < d.+1) (l`_i * f i *: 'X^(d - i))). +Proof. +elim: d l f => [| d IH] /=. + case => /= [ | a [ | *]] // f cf _. + case: (a != 0) => //=; by rewrite mulr0 ltxx addn0. +case => [| a l] //= f; rewrite ltnS. +case h: (a!=0) => //=; last first. + rewrite -[X in 0 <= X]/((seqn0 l)`_0) => h1 h2 h3 h4. + rewrite big_ord_recl /=. + have := negbFE h => /eqP => ->; rewrite mul0r scale0r add0r. + have t : forall i : 'I_d.+1, true -> + l`_i * f (bump 0 i) *: 'X^(d.+1 - bump 0 i) = + l`_i * f (i.+1) *: 'X^(d - i). + by move=> i /=; rewrite /bump leq0n add1n subSS. + rewrite (eq_bigr _ t) {t}. + have h2' : forall i : nat, (i < d.+1)%N -> (0 < f i.+1). + by move=> i ci; apply: h2; rewrite ltnS. + by apply: IH h2' _ _. +case alt: (a * head 0 (seqn0 l) < 0)%R; last first. + rewrite add0n => h1 h2 h3 h4. + have h2' : forall i : nat, (i < d.+1)%N -> (0 < f i.+1). + by move=> i ci; apply: h2; rewrite ltnS. + have alt' : alternate (\sum_(i < d.+1) (l`_i * f i.+1) *: 'X^(d - i)). + apply: (IH l (fun i => f i.+1)) => //. + have agt0 : 0 < a by rewrite lt_neqAle eq_sym (negbTE h). + rewrite -(ler_pM2l agt0) mulr0 leNgt; apply: negbT; exact alt. + rewrite big_ord_recl subn0 nth0 /= addrC; apply: alternate_r => //. + rewrite pmulr_lgt0; first by rewrite lt_neqAle eq_sym h h4. + by apply: h2. + have asl : forall i : 'I_d.+1, + (size (('X^(d.+1 - bump 0 i):{poly R})) <= d.+1)%N. + by move=> i; rewrite /bump leq0n add1n subSS size_polyXn ltnS leq_subr. + apply: size_weighted_sum_leq=> i _; apply: asl. +rewrite add1n; move=> sl cf [c0] ap. +have negl : head 0 (seqn0 l) < 0. + have ap' : 0 < a by rewrite lt_neqAle eq_sym h ap. + by rewrite -(ltr_pM2l ap') mulr0 alt. +have int: head 0 (seqn0 l) != 0 by rewrite neq_lt negl. +move/seqn0_last: (int) => [l1 [x [l2 /andP [/eqP p1 /andP[p2 p3]]]]]. +apply/alternate_P; rewrite /= -/R. +have cfp : forall j, (j < d.+2)%N -> + (\sum_(i < d.+2) ((a :: l)`_i * f i) *: 'X^(d.+1 - i))`_j = + ((a :: l)`_(d.+1 - j) * f (d.+1 - j)%N). + move=> j cj. + have cut1 : (0 <= d.+1 - j)%N by rewrite leq0n. + have cut2 : (d.+1 - j <= d.+2)%N. + by rewrite (leq_trans _ (ltnW (ltnSn d.+1))) // leq_subr. + rewrite -(big_mkord (fun i => true) + (fun i => ((a :: l)`_i * f i) *: 'X^(d.+1 - i))). + rewrite (big_cat_nat _ xpredT _ cut1 cut2) /= coef_add_poly. + have cut3 : (d.+1 - j <= (d.+1 - j).+1)%N by rewrite leqnSn. + have cut4 : ((d.+1 - j) < d.+2)%N by rewrite ltnS leq_subr. + rewrite (big_cat_nat _ xpredT _ cut3 cut4) /= coef_add_poly. + rewrite big_nat1 coefZ subKn; last by rewrite -ltnS. + rewrite coefXn eqxx mulr1 [X in X + (_ + _)](_ : _ = 0). + rewrite add0r [X in _ + X](_ : _ = 0); first by rewrite addr0. + rewrite nth_default //. + apply: size_weighted_sum_leq=> i; rewrite mem_index_iota => /andP [ci c']. + rewrite size_polyXn. + move: ci; rewrite -(ltn_add2r j) subnK; last by rewrite -ltnS. + move=> ci; rewrite -(ltn_add2r i) subnK; first by rewrite addnC. + by rewrite -ltnS. + have t : forall i, (0 <= i < d.+1 - j)%N -> + ((a :: l)`_i * f i) *: 'X^(d.+1 - i) = + ((a :: l)`_i * f i) *: 'X^(d - j - i) * 'X^j.+1. + move=> i /andP [_ ci]; rewrite -scalerAl -exprD addnS subnAC subnK. + by rewrite subSn // -ltnS (leq_trans ci). + rewrite -(leq_add2r i) subnK; last first. + by rewrite -ltnS (leq_trans ci). + move: ci; rewrite -(ltn_add2r j) subnK. + by rewrite ltnS addnC. + by rewrite -ltnS. + by rewrite (@eq_big_nat _ _ _ _ _ _ _ t) -big_distrl coefMXn leqnn. +exists (mkseq (fun i => 0) (d.+1 - size l)++(rev l2)), (x * f (size l1).+1), + (mkseq (fun i => (rev l1)`_i * f ((size l1) - i)%N) (size l1)), + (a * f 0%N), [::]. +have am : all_eq0 (mkseq (fun _ => (0:R)) (d.+1 - size l)). + rewrite /all_eq0; apply/(all_nthP 0); rewrite size_mkseq=> i ci. + by rewrite nth_mkseq. +have apos : 0 < a * f 0%N. + by apply: mulr_gt0; first rewrite lt_neqAle ap eq_sym h //; apply: cf. +rewrite /all_eq0 /all_le0 all_cat -!all_rev -/(all_eq0 l2) p3 /=. +have al : all_le0 l by apply: first_neg_no_change_all_le0. +rewrite [all _ (mkseq _ _)]am apos /=. +have sl' : (size l1 + size l2 <= d)%N. + by move: sl; rewrite p1 size_cat /= addnS ltnS. +have sl1d : (size l1 <= d)%N. + by apply: leq_trans sl'; apply leq_addr. +have -> : x * f (size l1).+1 < 0. + rewrite pmulr_llt0; last by apply: cf; rewrite !ltnS. + rewrite lt_neqAle; rewrite p2 /=. + by move/allP: al=> al; apply al; rewrite p1 mem_cat in_cons eqxx orbT. +split => //; last split=>//. + have st : size (a * f 0%N *: 'X^d.+1) = d.+2. + rewrite -mul_polyC size_Cmul ?size_polyXn // mulf_neq0 //. + by rewrite neq_lt cf ?orbT. + set sg := \sum_(_ < _) _; have st' : size sg = d.+2. + rewrite /sg big_ord_recl /= subn0 size_addl; first by []. + rewrite st ltnS size_weighted_sum_leq ?st //. + by move=> [i C] _; rewrite /bump add1n subSS size_polyXn ltnS leq_subr. + apply: (@eq_from_nth _ 0). + move:sl; rewrite p1 !size_cat /= !size_cat /= !size_rev !addnS addn0=> T. + by rewrite !size_mkseq subSS -addnA [(size l2 + _)%N]addnC subnK. + move=> i; rewrite st' => ci; rewrite cfp // {st' sg st al apos am cfp}. + rewrite nth_cat size_cat size_mkseq size_rev. + case b1 : (i < d.+1 - size l + size l2)%N. + rewrite nth_cat size_mkseq. + case b2 : (i < d.+1 - size l)%N. + rewrite nth_mkseq // nth_default ?mul0r //=. + move: b2; rewrite -(ltn_add2r (size l)) subnK // => b2. + by rewrite -(ltn_add2r i) subnK // addnC. + have b2' : (d.+1 - size l <= i)%N by rewrite leqNgt b2. + rewrite nth_rev; last first. + by rewrite -(ltn_add2r (d.+1 - size l)) subnK // addnC. + case l2c : (l2) => [ | b l3] /=; first by move: b1; rewrite l2c addn0 b2. + move: p3 {b2}; rewrite /all_eq0=>/all_nthP=> l20. + rewrite -l2c (eqP (l20 0 _ _)); last first. + by rewrite subSS l2c /= ltnS leq_subr. + have b1' : (i < d - size l1)%N. + move: b1; rewrite p1 size_cat /= addnS subSS subnDA subnK //. + by rewrite -(leq_add2r (size l1)) subnK // addnC. + have di1 : (i <= d)%N by rewrite (leq_trans (ltnW b1')) // leq_subr. + rewrite subSn //= p1 nth_cat. + have dil1 : (d - i < size l1)%N = false. + apply: negbTE; rewrite -leqNgt -(leq_add2r i) subnK//. + move: b1; rewrite -(ltn_add2l (size l1)) => b1. + rewrite -ltnS (leq_trans b1) // p1 size_cat /= addnS subSS. + by rewrite !(addnC (size l1)) -addnA subnK // addnC. + rewrite dil1; move/negbT: dil1; rewrite -leqNgt=>dil1. + rewrite -subnDA addnC subnDA -subnSK //= (eqP (l20 _ _ _)) ?mul0r //. + rewrite -(ltn_add2r i.+1) subnK // addnS ltnS -leq_subLR. + by rewrite (leq_trans _ b2') // p1 size_cat /= addnS subSS subnDA. + move=>{p3 p2}. + move/negbT: b1; rewrite -leqNgt leq_eqVlt => /predU1P[b1 {ci}|b1]. + rewrite b1 subnn p1 /= -b1 p1 size_cat /= addnS subSS [(d - _)%N]subnDA. + rewrite subnK; last first. + by rewrite -(leq_add2r (size l1)) subnK // addnC. + by rewrite subSn ?leq_subr // subKn //= nth_cat ltnn subnn /=. + have sl2dml1: (size l2 <= d - size l1)%N. + by rewrite -(leq_add2r (size l1)) subnK // addnC. + have dml1i : (d - size l1 < i)%N. + by apply: leq_trans b1; rewrite p1 size_cat /= addnS subSS subnDA subnK. + rewrite -[(i - _)%N]subnSK //= nth_cat size_mkseq -subnDA. + rewrite subnSK //. + case b2 : (i - (d.+1 - size l + size l2) <= size l1)%N. + rewrite nth_mkseq; last by rewrite subnSK. + move: (b2); rewrite -(leq_add2r (d.+1 - size l + size l2)). + rewrite subnK; last by rewrite ltnW. + rewrite addnC p1 size_cat /= addnS subSS subnDA subnK // subnK // => b2'. + rewrite nth_rev; last first. + by rewrite -(ltn_add2r (d - size l1).+1) subnK // addnS addnC subnK. + rewrite subnSK // subSn //= subnBA; last by rewrite ltnW. + rewrite addnC subnK // subnBA // addnS addnC subnK // nth_cat. + have dmil1 : (d - i < size l1)%N. + rewrite -(ltn_add2r i) subnK //; move: dml1i. + by rewrite -(ltn_add2r (size l1)) subnK // addnC. + by rewrite dmil1 subSn. + move/negbT: b2; rewrite -ltnNge=> b2. + have difinal : i = d.+1. + apply: anti_leq; apply/andP; split; first by rewrite -ltnS. + move: b2; rewrite -(ltn_add2r (d.+1 - size l + size l2)). + rewrite subnK; last by rewrite ltnW. + by rewrite p1 size_cat /= addnS subSS subnDA subnK // addnC subnK. + rewrite difinal subnn addSn subSS p1 size_cat /= addnS subnDA subSS. + rewrite [(d - (size l1 + size l2))%N]subnDA subnK // subnBA //. + by rewrite addKn subnn. +apply/(all_nthP 0); rewrite size_mkseq => i C; rewrite nth_mkseq // pmulr_lle0. +move: al; rewrite /all_le0 p1 all_cat => /andP [al1 _]; rewrite nth_rev //. + by move/(all_nthP 0): al1 => -> //; rewrite subnSK // leq_subr. +apply: cf; rewrite ltnS (leq_trans _ (ltnW (ltnSn _))) ?(leq_trans _ sl1d) //. +by rewrite leq_subr. +Qed. + +Lemma seqn0_oppr (l : seq R) : + seqn0 (map (fun i => -i) l) = map (fun i => -i) (seqn0 l). +Proof. +elim: l => [// | a l IH] /=. +by rewrite oppr_eq0; case: (a != 0); rewrite /= IH //. +Qed. + +Lemma changes_oppr (l : seq R) : + changes [seq - x | x <- l] = changes l. +elim: l => [// | x [ | y l] IH] /=; first by rewrite !mulr0. +rewrite mulrNN; congr (_ + _)%N; exact: IH. +Qed. + +Lemma ch1_correct l d a b (q : {poly R}): + (size l <= d.+1)%N -> + a < b -> q = \sum_(i < d.+1) l`_i *: bernp a b d i -> + changes (seqn0 l) = 1%N -> unique_root_for (horner q) a b. +Proof. +wlog : l q / (0 <= (seqn0 l)`_0). + move=> main s ab qq c1. + case sg : (0 <= (seqn0 l)`_0). + apply: (main l q sg) => //. + have ur : unique_root_for (horner (-q)) a b. + apply: (main (map (fun x => -x) l) (-q)) => //. + rewrite seqn0_oppr (nth_map 0). + by rewrite lerNr oppr0 ltW // ltNge sg. + rewrite lt0n; apply/negP; move/eqP=>abs; move: sg. + by rewrite nth_default ?abs ?lexx. + by rewrite size_map. + rewrite -(mul1r q) -mulNr qq big_distrr; apply/eq_bigr. + move=> i _ /=; case ci : (i < size l)%N. + by rewrite (nth_map 0) // mulNr mul1r scaleNr. + move/negbT: ci; rewrite -leqNgt => ci. + rewrite !nth_default //; last by rewrite size_map. + by rewrite !scale0r mulr0. + by rewrite seqn0_oppr changes_oppr. + case: ur => [x [inx xr xu]]. + exists x; split; first by []. + by apply/eqP; rewrite -oppr_eq0 -hornerN; apply/eqP. + by move=> u inu /eqP; rewrite -oppr_eq0 -hornerN => /eqP; apply:xu. +move=> sg s ab qq c1. +suff : one_root1 q a b by apply: one_root1_unique. +apply: (@Bernstein_isolate _ d) => //. + rewrite lt0n size_poly_eq0; apply/negP => /eqP => abs. + move/eqP: qq; rewrite abs eq_sym=> /eqP. + move: (ab); rewrite lt_def eq_sym; case/andP => ab' _ sb. + have := bernp_free ab' sb => bf {ab' sb abs sg}. + have abs : (seqn0 l) = [::]. + move: l s bf {a b q ab c1}. + elim: d => [ | d IH]. + move=> [ | a l]; first by []. + case: l => /=; last by []. + by move=> _ l0; have := (l0 ord0) => /= => ->; rewrite eqxx /=. + move=> [ | a l] /=; first by []. + rewrite ltnS=> s l0; have := (l0 ord0) => /= => ->; rewrite eqxx /=. + apply: IH => //; move=> [i] /=; rewrite -ltnS => ci. + by have := (l0 (Ordinal ci)). + by move: c1; rewrite abs. + rewrite qq; apply: size_weighted_sum_leq. + move=> [i ci]; rewrite size_bernp ?leqnn //. + by move: ab; rewrite lt_def eq_sym; case/andP. +have anb : a != b. + by move: ab; rewrite lt_def eq_sym; case/andP. +rewrite qq Mobius_weighted_sum //; last by move=> [i ci]; rewrite size_bernp. +have t : forall i : 'I_d.+1, true -> l`_i *: Mobius d a b (bernp a b d i) = + (l`_i * ('C(d, i))%:R) *: 'X ^+ (d - i). + by move=> [i ci]; rewrite Mobius_bernp //= scalerA. +rewrite (eq_bigr _ t) {t}. +have binp : forall i, (i < d.+1)%N -> (0:R) < ('C(d, i))%:R. + by move => i ci; rewrite ltr0n bin_gt0 -ltnS. +apply: (changes1_alternate s binp) => //. +Qed. + +Lemma ch0_correct l d a b q : a < b -> q != 0 -> + q = \sum_(i < d.+1) l`_i *: bernp a b d i -> + changes (seqn0 l) = 0%N -> no_root_for (horner q) a b. +move=> ab. +wlog : l q / 0 <= head 0 (seqn0 l). +move=> wlh qn0 qq ch. + case pos : (0 <= head 0 (seqn0 l)); first by apply: (wlh l) => //. + have ssn0 : (0 < size (seqn0 l))%N. + rewrite lt0n; apply/negP=> s0. + case/negP: qn0; rewrite qq big1 //. + move=> i _; case sli: (size l <= i)%N. + by rewrite nth_default ?scale0r. + have : all_eq0 l by rewrite -all_eq0_seqn0 -nth0 nth_default // (eqP s0). + move/negbT: sli; rewrite -ltnNge=> sli /allP l0. + by have := mem_nth 0 sli => /l0/eqP=> li0; rewrite li0 scale0r. + move: ch; rewrite -changes_oppr -seqn0_oppr => ch. + move/negbT: pos; rewrite -ltNge -oppr_gt0 -nth0 -(nth_map 0 0) // nth0. + rewrite -seqn0_oppr=>pos. + have ssn0' : (0 < size (seqn0 [seq -x | x <- l]))%N. + by rewrite seqn0_oppr size_map. + move: qn0; rewrite -oppr_eq0 => qn0. + have := refl_equal (-q); rewrite [X in _ = - X]qq -[X in _ = -X]mul1r {qq}. + rewrite -mulNr big_distrr /=. + have t : forall i : 'I_d.+1, true -> + -1 * (l`_i *: bernp a b d i) = + [seq -x | x <- l]`_i *: bernp a b d i. + move=> i _; case ci : (i < size l)%N. + rewrite (nth_map 0) // -[-1]/(-(1%:P)) -polyCN mul_polyC scalerA. + by rewrite mulNr mul1r. + move/negbT: ci; rewrite -leqNgt=> ci. + rewrite !nth_default //; first by rewrite !scale0r mulr0. + by rewrite size_map. + rewrite (eq_bigr _ t) => qq {t ssn0}. + have {wlh qq ch qn0 pos ssn0'} := wlh _ _ (ltW pos) qn0 qq ch. + by move=> nx x inx; rewrite -[q.[x]]opprK -hornerN oppr_eq0 nx. +move=> h qn0 qq ch x inx; apply /negP; rewrite qq. +rewrite horner_sum psumr_eq0 /=. +move=> al0; case/negP: qn0; rewrite qq. + rewrite big1 //; move => i _; rewrite [l`_i](_ : _ = 0) ?scale0r //. + have : l`_i * (bernp a b d i).[x] == 0. + by have := (allP al0 i (mem_index_enum _)); rewrite hornerZ. + rewrite mulf_eq0. + case: i => i /=; rewrite ltnS => ci. + have := bernp_gt0 ci inx; set bf := (_.[_]) => b0. + have bn0 : (bf != 0) by rewrite neq_lt b0 orbT. + by rewrite (negbTE bn0) orbF => /eqP. +move=> i _; rewrite hornerZ. +apply: mulr_ge0; last first. + by apply/ltW/bernp_gt0=> //; case i. +case sli: (i < size l)%N; last first. + by move/negbT: sli; rewrite -leqNgt=> sli; rewrite nth_default //. +by move/allP: (first_pos_no_change_all_ge0 h ch)=> t; apply/t/mem_nth. +Qed. + +Lemma bern0_a : forall (a b : R) deg i, a != b -> (0 < deg)%N -> + (i <= deg)%N -> (bernp a b deg i).[a] == 0 = (i != 0)%N. +Proof. +move=> a b deg i anb dn0 id. +rewrite /bernp hornerMn !hornerE subrr. +rewrite mulrn_eq0 !mulf_eq0 !expf_eq0 eqxx andbT invr_eq0 expf_eq0 dn0 andTb. +rewrite subr_eq0 [b == a]eq_sym (negbTE anb) orFb lt0n andbF orbF. +by rewrite eqn0Ngt bin_gt0 id. +Qed. + +Lemma bernp_first_coeff0 l d (a b : R) q : + a != b -> (0 < d)%N -> + q = \sum_(i < d.+1) l`_i *: bernp a b d i -> + (l`_0 == 0) = (q.[a] == 0). +Proof. +move=> anb dn0 qq. +rewrite qq horner_sum big_ord_recl !hornerE. +rewrite (_ : \sum_(i < d) _ = 0). + by rewrite addr0 mulf_eq0 bern0_a // eqxx orbF. +apply: big1; move=> [i ci] _ /=; apply/eqP. +by rewrite hornerE mulf_eq0 bern0_a // [bump _ _ == _]eq_sym neq_bump orbT. +Qed. + +Lemma isol_rec_head_root : forall c l d a b q acc, + q.[a] != 0 -> head_root (horner q) (isol_rec c d a b l acc). +Proof. +elim=> [// | c IH l d a b q acc qa0 /=]. +by case tst : (changes (seqn0 l)) => [ | [ | cl]] //=; apply: IH. +Qed. + +Lemma isol_rec_correct : forall c l d a b q acc, + a < b -> (0 < d)%N -> q != 0 -> (size l <= d.+1)%N -> + q = \sum_(i < d.+1) l`_i *: bernp a b d i -> + read (horner q) acc -> head_root (horner q) acc -> + read (horner q) (isol_rec c d a b l acc). +Proof. +elim=> [// | c IH]. +move=> l d a b q acc altb dn0 qn0 sld qq ht hh /=. +have anb : a != b by rewrite neq_lt altb. +case tst : (changes (seqn0 l)) => [/= | [/= | nc]]. + by split=> //; apply (ch0_correct altb qn0 qq). + by split=> //; apply (ch1_correct sld altb qq). +have help : 2%:R^-1 = ((a + b) / 2%:R - a)/(b - a). + rewrite -[X in _ / _ - X]double_half -/(half (a + b)) half_lin half_lin1. + rewrite opprD addrCA !addrA addNr add0r /half mulrAC mulfV ?mul1r //. + by rewrite subr_eq0 eq_sym. +have help2 : 2%:R^-1 = (b - (a + b)/2%:R)/(b - a). + rewrite -[X in X - _ / _]double_half -/(half(a + b)) half_lin half_lin1. + rewrite opprD addrCA addrK [- _ + _]addrC /half mulrAC mulfV ?mul1r //. + by rewrite subr_eq0 eq_sym. +have qh' : + q = \sum_(i < d.+1) + (mkseq (dicho' 2%:R^-1 2%:R^-1 [eta nth 0 l]) d.+1)`_i *: + bernp a ((a + b) / 2%:R) d i. + have qt : forall i : 'I_d.+1, true -> + (mkseq (dicho' 2%:R^-1 2%:R^-1 [eta nth 0 l]) d.+1)`_i *: + bernp a ((a + b) / 2%:R) d i = + dicho' ((b - half (a + b))/(b - a)) + ((half (a + b) - a)/(b - a)) [eta nth 0 l] i *: + bernp a ((a + b) / 2%:R) d i. + by move => [i ci] _; rewrite -help -help2 /= nth_mkseq. + rewrite (eq_bigr _ qt); apply: dicho'_correct => //. + rewrite -[X in _ == X]double_half half_lin; apply/negP. + by move/eqP/half_inj/addrI/eqP; rewrite eq_sym; apply/negP. +have qh : + q = \sum_(i < d.+1) + (mkseq (dicho 2%:R^-1 2%:R^-1 d [eta nth 0 l]) d.+1)`_i *: + bernp ((a + b) / 2%:R) b d i. + have qt : forall i : 'I_d.+1, true -> + (mkseq (dicho 2%:R^-1 2%:R^-1 d [eta nth 0 l]) d.+1)`_i *: + bernp ((a + b) / 2%:R) b d i = + dicho ((b - half (a + b))/(b - a)) + ((half (a + b) - a)/(b - a)) d [eta nth 0 l] i *: + bernp ((a + b) / 2%:R) b d i. + by move => [i ci] _; rewrite -help -help2 /= nth_mkseq. + rewrite (eq_bigr _ qt); apply: dicho_correct; [exact: anb| |exact: qq]. + rewrite -[X in _ == X]double_half half_lin; apply/negP. + by move/eqP/half_inj/addIr/eqP; apply/negP. +apply: (IH); [|exact: dn0|exact: qn0| |exact: qh'| |]. + by case/andP : (mid_between altb) => it _; exact it. + by rewrite size_mkseq. + case ts0: (dicho 2%:R^-1 2%:R^-1 d [eta nth 0 l] 0 == 0). + rewrite /=; split. + apply/eqP; rewrite -(bernp_first_coeff0 _ dn0 qh). + by rewrite nth_mkseq. + rewrite -[X in _ == X]double_half half_lin; apply/negP. + by move/eqP/half_inj/addIr/eqP; apply/negP. + apply: IH => //. + by case/andP : (mid_between altb) => _ it; exact it. + by rewrite size_mkseq. + apply: IH => //. + by case/andP : (mid_between altb) => _ it; exact it. + by rewrite size_mkseq. +case ts0: (dicho 2%:R^-1 2%:R^-1 d [eta nth 0 l] 0 == 0); first by []. +apply: isol_rec_head_root. +rewrite -(bernp_first_coeff0 _ dn0 qh); last first. + rewrite -[X in _ == X]double_half half_lin; apply/negP. + by move/eqP/half_inj/addIr/eqP; apply/negP. +by rewrite nth_mkseq; move/negbT: ts0. +Qed. + +End isolation_algorithm. diff --git a/theories/civt.v b/theories/civt.v new file mode 100644 index 0000000..0cf0f63 --- /dev/null +++ b/theories/civt.v @@ -0,0 +1,449 @@ +Require Import (*QArith*) ZArith Zwf Lia. +From mathcomp Require Import ssreflect eqtype ssrbool ssrnat div fintype seq ssrfun order. +From mathcomp Require Import bigop fingroup choice ssralg ssrnum rat poly. +Require Export (*infra*) pol. + +Import GroupScope. +Import Order.Theory GRing.Theory Num.Theory. +Local Open Scope ring_scope. + +Set Printing Width 50. + +(******************************************************************************) +(* We want to prove a simple and contructive approximation of the + intermediate value theorem: if a polynomial is negative in a and positive in b, + and a < b, then for any positive epsilon, there exists c and d, so that + a <= c < d <= b, the polynomial is negative in c and positive and d, + and the variation between c and d is less than epsilon. To prove this, + we use a second polynomial, obtained by taking the the absolute value + of each coefficient. +*) +(******************************************************************************) + +Fixpoint abs_pol (l:list rat) :list rat := + match l with nil => nil | a::tl => `|a| :: abs_pol tl end. + +(* Theorem binding the slope between two points inside an interval. *) +(*Lemma cm2 (l : {poly rat}) b : + { c | forall x, 0 <= x -> x <= b -> `|l.[x] - l.[0]| <= c * x}. +Proof. +(*set al := \poly_(i < size l) `|l`_i|. +exists al.[b] => x x0 xb. +rewrite horner_poly horner_coef0 horner_coef. +have [/size0nil ->|] := eqVneq (size l) 0%N. + by rewrite !big_ord0/= normr0 mul0r. +rewrite -lt0n => l0. +rewrite -[in leLHS](prednK l0). +rewrite big_ord_recl/= expr0 mulr1 addrAC subrr add0r. +rewrite /bump. +under eq_bigr do rewrite leq0n/= add1n. +rewrite big_distrl/=. +rewrite (le_trans (ler_norm_sum _ _ _))//. +under eq_bigr do rewrite normrM. +rewrite -[in leRHS](prednK l0). +rewrite big_ord_recl/= expr0 /bump. +under [in leRHS]eq_bigr do rewrite leq0n/= add1n. +rewrite mulr1. +rewrite ler_paddl// ?mulr_ge0//. +apply: ler_sum => j _. +rewrite -mulrA. +rewrite ler_pmul//. +rewrite ger0_norm//; last first. + by rewrite exprn_ge0. +rewrite (@le_trans _ _ (b ^+ j.+1))//. +by rewrite ler_pexpn2r// nnegrE// (le_trans x0).*) +(*move=> l b; case: l =>[| a l]. +- by exists 0; move=> /= x; rewrite mul0r oppr0 addr0 normr0 lexx. +- exists (eval_pol (abs_pol l) b) => x px xb /=; rewrite mul0r addr0. + rewrite addrC addKr normrM ger0_norm // mulrC ler_wpM2r//. +(* NB(rei): ler_absr_eval_pol? *) +(* rewrite (le_trans (ler_absr_eval_pol _ _)) //. + by rewrite eval_pol_abs_pol_increase // ger0_abs. +Qed.*) (*TODO*)*) Admitted. *) + +(* Cannot be abstracted since not every ordered ring has a floor ring *) +(* +TODO? +Lemma QZ_bound : forall x:Q, (0 <= x)%Q -> {n : Z | x <= n#1}%Q. +intros [n d]; exists(Zdiv n (Zpos d)+1)%Z. +assert (dpos : (('d) > 0)%Z) by apply (refl_equal Gt). +unfold Qle; simpl; rewrite Zmult_1_r; rewrite Zmult_plus_distr_l. +rewrite Zmult_1_l {1}(Z_div_mod_eq n ('d)) //. +rewrite (Zmult_comm ('d)); apply Zplus_le_compat; auto with zarith. +destruct (Z_mod_lt n ('d)) as [_ H2]; auto. +by apply Zlt_le_weak. +Defined. +*) + +(* We will look at n points regularly placed between a and b, a satisfies + a property P and b does not, we want to find the first point among the + n points that satisfies P and has a neighbour that does not. *) +Definition find_pair : forall A:eqType, forall P:A->bool, forall Q:A->A->Prop, + forall l:seq A, forall a b:A, P a -> ~P b -> + (forall l1 l2 x y, a::l ++ b::nil= l1 ++ x :: y :: l2 -> Q x y) -> + {c :A & { d | Q c d /\ P c /\ ~P d}}. +Proof. +move => A P Q l; elim: l => [ | a l IHl] a' b' Pa Pb connect. + by exists a'; exists b'; split => //; apply: (connect [::] [::]). +case Pa1: (P a). + have tmp : + forall l1 l2 x y, a :: l ++ [:: b' ]= l1 ++ [::x, y & l2] -> Q x y. + by move => l1 l2 x y q; apply: (connect (a'::l1) l2); rewrite /= q. + by move: (IHl a b' Pa1 Pb tmp) => [c [d [cd Pc]]]; exists c; exists d. +exists a'; exists a; split; first by apply (connect nil (l++b'::nil)). +by rewrite Pa1. +Qed. + +Fixpoint nat_ns (p : Z)(n : nat) := + match n with + |0 => [:: p] + |m.+1 => (p - (Z_of_nat m.+1))%Z :: nat_ns p m + end. + +Definition ns p n := + match n with + |Zpos q => nat_ns p (nat_of_P q) + |_ => [:: p] + end. + +Lemma ltb_Zneg0 x : (Zneg x < 0)%Z. Proof. by []. Qed. + +Lemma leb_Zneg0N x : ~ (0 <= Zneg x)%Z. Proof. exact/Z.lt_nge/ltb_Zneg0. Qed. + +Lemma nat_ns_head : forall (p : Z) n, + exists l, nat_ns p n = (p - (Z_of_nat n))%Z :: l. +Proof. +move=> p; elim=>[|n [l Ih]] /=. + exists [::]. + by rewrite Z.sub_0_r. +by rewrite Ih; exists [:: (p - Z_of_nat n)%Z & l]. +Qed. + +Local Open Scope Z_scope. + +Lemma ns_head : forall p n :Z, (0 <= n) -> exists l, ns p n = (p - n) :: l. +Proof. +move=> p [|n|n] /=; last 1 first. +- by move/leb_Zneg0N. +- exists [::]. + by rewrite Z.sub_0_r. +- move=> _; set m := nat_of_P n; case: (nat_ns_head p m)=> l' ->; exists l'. + by rewrite /m Zpos_eq_Z_of_nat_o_nat_of_P. +Qed. + +Lemma nat_ns_step : forall p n, forall l1 l2 x y, + nat_ns p n = l1 ++ [:: x, y & l2] -> y = x + 1. +Proof. +move=> p; elim=> [|n Ihn] l1 l2 x y /=. + by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. +case: l1 => [|u l3] /=; last by case=> _; move/Ihn. +case=> <-; case: (nat_ns_head p n)=> [l' ->]; case=> <- _. +rewrite Zpos_P_of_succ_nat. +rewrite /Z.succ /=. +ring. +Qed. + +Lemma ns_step : forall p n, forall l1 l2 x y, 0 <= n -> + ns p n = l1 ++ [:: x, y & l2] -> y = x + 1. +Proof. +move=> p [|n|n] /=; last 1 first. +- by move=> ? ? ? ? /leb_Zneg0N. +- move=> ? ? ? ? ?. + by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. +- move=> l1 l2 x y _; exact: nat_ns_step. +Qed. + +Lemma nat_ns_tail : forall p n, exists l, nat_ns p n = l ++ [:: p]. +Proof. +move=> p; elim=> [|n [l' Ihn]] /=. +- by exists [::]; rewrite cat0s. +- rewrite Ihn. + eexists. + rewrite -cat_cons. + reflexivity. +Qed. + +Lemma ns_tail : forall p n, exists l, ns p n = l ++ p ::nil. +Proof. +move=> p [|n|n] /=. +- by exists [::]; rewrite cat0s. +- by case: (nat_ns_tail p (nat_of_P n))=> l' ->; exists l'. +- by exists [::]; rewrite cat0s. +Qed. + +Local Close Scope Z_scope. + +(* Lemmas about minus are missing in xssralg .. .*) +(* TODO + +Lemma nat_ns_bounds : forall p n x l1 l2, nat_ns p n = l1 ++ [:: x & l2] -> + (p - Z_of_nat n <= x)%Z && (x <= p). +Proof. +move=> p; elim=> [|n Ihn] x l1 l2 /= h. +- rewrite oppr0 addr0. + suff exp : p = x by rewrite exp lerr. + case: l1 h => /=; first by case. + move=> z s. + by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; + rewrite eqSS. +- case: l1 h => [| u l1] /=. + + by set sn := (' _)%Z; case=> h _; rewrite -h lerr lter_addlr /= oppr_lte0. + + case=> _; move/Ihn; case/andP=> h1 h2; rewrite h2 andbT; apply: ler_trans h1. + rewrite lter_add2r /= -lter_opp2 /= Zpos_P_of_succ_nat /Zsucc. + by rewrite -[Zplus _ _]/(Z_of_nat n + 1) lter_addrr /= ler01. +Qed. + +Lemma ns_bounds : forall p n x l1 l2, 0 <= n -> ns p n = l1 ++ x::l2 -> + (p - n <= x) && ( x <= p). +Proof. +move=> p [| n | n] x l1 l2 /=. +- move=> _ h; rewrite oppr0 addr0. + suff exp : p = x by rewrite exp lerr. + case: l1 h => /=; first by case. + move=> z s. + by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. +- by move=> _; move/nat_ns_bounds; rewrite Zpos_eq_Z_of_nat_o_nat_of_P. +- by rewrite leb_Zneg0N. +Qed. + +Lemma map_contiguous : +forall (A B : Type)(f : A -> B) l l1 l2 a b, + map f l = l1 ++ [:: a, b & l2] -> + {l'1 : seq A & + {l'2 : seq A & + {x : A & + {y : A | [/\ l1 = map f l'1, l2= map f l'2, a = f x, + b = f y & l = l'1 ++ [:: x, y & l'2]]}}}}. +Proof. +intros A B f; elim=> [|x l Ihl] /= l1 l2 a b h; first by case: l1 h. +case: l Ihl h => [|a' l'] /= h. +- by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. +- case: l1 h => [|a1 l1] /= h. + by case=> <- <- <-; exists [::]; exists l'; exists x; exists a' => /=. + case=> e1; move/h => [l1' [l2' [x' [y' [h1 h2 h3 h4 h5]]]]]. + exists [:: x & l1']; rewrite /= -h1 h2 e1; exists l2'; exists x'; exists y'. + by split=> //; rewrite h5. +Qed. + +(*This is map_cat. +Lemma map_app : + forall A B:Type, forall f : A -> B, forall l1 l2, map f (l1++l2) = map f l1 ++ map f l2. +intros A B f l1; induction l1; simpl; auto. +intros l2; rewrite IHl1; auto. +Qed. +*) + + +Lemma non_empty_tail : + forall (A : Type) (a : A) l, exists l', exists b, [:: a & l] = l' ++ [::b]. +Proof. +move=> A a l; elim: l a => [| x l Ihl] a. +- by exists [::]; exists a. +- case: (Ihl x)=> s [b Ihb]; rewrite Ihb; exists [:: a & s]; exists b. + by rewrite cat_cons. +Qed. + +(* wait and see ... +Lemma Qfrac_add_Z_l : forall a b c, + (a # 1) + (b # c)%Q = ( a * ' c + b # c)%Q :> Qcb. +intros;unfold Qeq; simpl; ring. +Qed. +*) + +Lemma leb_Z : forall x y:Z, x <= y -> Qcb_make x <= Qcb_make y. +Proof. +move => x y xy; apply/QcblebP; rewrite /qcb_val /Qcb_make /Qle /Qnum /Qden. +by rewrite 2!Zmult_1_r; apply/Zle_is_le_bool. +Qed. + +Lemma leb_0_Z : forall y, 0%Z <= y -> 0 <= Qcb_make y. +Proof. by move => y yp; apply: leb_Z. Qed. + +Lemma ltb_Z : forall x y:Z, x < y -> Qcb_make x < Qcb_make y. +Proof. + move => x y xy. apply/QcblebP; rewrite /qcb_val /Qcb_make /Qle /Qnum /Qden. +rewrite 2!Zmult_1_r; move/Zle_is_le_bool; rewrite -[Zle_bool y x]/(y <= x). +by rewrite ler_nlt xy. +Qed. + +Lemma ltb_0_Z : forall y, 0%Z < y -> 0 < Qcb_make y. +Proof. by move => y yp; apply: ltb_Z. Qed. + +Lemma Qcb_make_add : + forall x y, Qcb_make (x + y) == Qcb_make x + Qcb_make y. +move => x y; apply/Qcb_QeqP. +by rewrite -[(Qcb_make _ + _)%R]/(Q2Qcb(Qplus (qcb_val (Qcb_make x)) + (qcb_val (Qcb_make y)))) /Qcb_make + ?qcb_valE /Qplus /Qnum /Qden !Zmult_1_r Pmult_1_r /Q2Qcb ?qcb_valE + (eqP (Qcb_Z _)). +Qed. + +Lemma half_lt : forall a b :Qcb, 0 < a -> 0 < b -> + a / ((Qcb_make 2) * b) < a / b. +move => a b Ha Hb; rewrite ltef_mulpl // invr_mul //=; last first. + by rewrite unitfE eq_sym ltrWN. +by rewrite ltef_divp //= -{1}[_^-1]mulr1 ltef_mulp //= invf_cp0. +Qed. + +Lemma cut_epsilon : forall eps:Qcb, 0 < eps -> + exists eps1, exists eps2, 0 < eps1 /\ 0 < eps2 /\ eps1 + eps2 <= eps /\ + eps1 < eps /\ eps2 < eps. +move => eps p; exists (eps/Qcb_make 2); exists (eps/Qcb_make 2). +have p1 : 0 < eps/Qcb_make 2 by rewrite ltef_divp. +split; first done; split; first done; split. + rewrite -mulr_addr. + have q2 : (Qcb_make 2)^-1 + (Qcb_make 2)^-1 == 1 by []. + by rewrite (eqP q2) mulr1 lerr. +suff cmp : eps/Qcb_make 2 < eps by []. +by rewrite ltef_divp //= -{1}[eps]mulr1 ltef_mulp. +Qed. + + +Lemma constructive_ivt : + forall l x y, x < y -> eval_pol l x < 0%R -> 0%R <= eval_pol l y -> + forall epsilon, 0 < epsilon -> + exists x', exists y', - epsilon <= eval_pol l x' /\ + eval_pol l x' < 0 /\ 0 <= eval_pol l y' /\ + eval_pol l y' <= epsilon /\ x <= x' /\ x' < y' /\ y' <= y. +Proof. +move=> l a b ab nla plb. +have ba' : 0 < b - a by rewrite -(addrN a) lter_add2l. +(*have mpolapos : 0 < - eval_pol l a by rewrite gtr0_ltNr0 opprK.*) +have evalba : 0 < eval_pol l b - eval_pol l a. + rewrite -(lter_add2l (eval_pol l a)) add0r -addrA addNr addr0. + exact: lter_le_trans plb. +case: (translate_pol l a) => l' q. +case: (@cm3 (b - a) ba' l') => /= c pc. +have cpos : 0 < c. + rewrite -(ltef_mulp _ _ _ ba') /= mul0r -[b -a]addr0. + apply: lter_le_trans (pc 0 (b - a) _ _ _); rewrite ?lerr // ?(ltrW ba') //. + by rewrite -{2}(addrN a) -!q ger0_abs // ltrW. +move=> eps pe. +have pdiv : (0 < (b - a) * c / eps). + by rewrite ltef_divp // mul0r mulf_gte0 /= ba' cpos. +move: (pdiv); move/ltrW; move/QcblebP; case/QZ_bound => n qn. +(* assia : canonical structures are missing here for Z -> Qcb *) +have qn' : (((b - a) * c / eps) <= (Qcb_make n)). + by apply/QcblebP; rewrite /Qcb_make qcb_valE. +have fact1 : 0 < n. + have tmp : 0 < Qcb_make n. + by apply: lter_le_trans pdiv qn'. + move: tmp; move/QcblebP. rewrite /Qcb_make /=. + by move/Qle_bool_iff; rewrite /Qle_bool /= Zmult_1_r; move/negP. +have mkl: + exists l, forall l1 l2 x y, + [:: a & l] ++ [:: b] = l1 ++ [:: x, y & l2] -> + y - x = (b - a) / (Qcb_make n) /\ + exists k : Z, + x = a + (b - a)* (Qcb_make k)/ (Qcb_make n) /\ + (0<= k) /\ (k <= n - 1). + case en : (n == 1). + - rewrite (eqP en); exists [::] => l1 l2 x y /=; case: l1 => [| t1 ql1] /=. + case=> e1 e2 e3; rewrite e1 e2 Qcb_make1 invr1 mulr1; split=> //. + by exists 0; rewrite addrN lerr Qcb_make0 mulr0 mul0r addr0; split. + by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS. +- exists (map (fun x => a + (b-a)*((Qcb_make x)/(Qcb_make n))) (ns (n-1) (n-2))). + have fact8 : 0 <= n - 2%Z. + move/eqP: en; move: fact1; rewrite -[1]/1%Z -[0]/0%Z. + clear. rewrite /is_true. rewrite -Zle_is_le_bool-[(n-2%Z)%R]/(n - 2)%Z. + rewrite -[0%Z < n]/(~~(Zle_bool n 0)); move/negP. + rewrite /is_true -Zle_is_le_bool; omega. + have fact2 : 0 <= n - 1. + by rewrite ler_eqVlt (ler_lte_trans fact8) ?orbT // lter_add2r. + move=> l1 l2 x y; case: l1 => [|t1 ql1] /=. + case: (ns_head (n - 1) (n - 2) fact8) => a1 qa1. + rewrite qa1 /= (_ : (n - 1) - (n - 2)%Z = 1) ?Qcb_make1; last first. + by rewrite addrAC [-(n - 2%Z)]oppr_add addrA opprK addrN add0r. + case => -> <- /=; split. + by rewrite addrAC addrN add0r mulrA mulr1. + exists 0; rewrite Qcb_make0 mulr0 mul0r addr0 lerr; split=> //; split=> //. + case=> ->; case: l2 => [|d l2] /=. + rewrite -[[:: x, y & [::]]]/([::x]++[:: y]) catA. + rewrite !cats1 -!rot1_cons; move/rot_inj; case=> <-. + case: (ns_tail (n - 1) (n - 2))=> l3 ->; rewrite map_cat /=. + rewrite cats1 -rot1_cons; move/rot_inj; case=> <- h2. + have fact3 : (Qcb_make (n - 1) / Qcb_make n) = 1 - (Qcb_make n)^-1. + have nn0 : ~~ (Qcb_make n == 0). + by apply/negP => nis0; move/Qcb_QeqP: nis0; + rewrite /Qeq /= Zmult_1_r => nis0; move: fact1; + rewrite nis0 ltrr. + by apply/eqP; rewrite /= (eqP (Qcb_make_add _ _)) mulr_addl mulrV /= //. + rewrite fact3 mulr_addr mulr1 oppr_add !addrA oppr_add addrA addrN add0r. + rewrite -mulrN opprK; split=> //. + exists (n - 1); split; last by rewrite lerr. + by rewrite -mulrA fact3 mulr_addr mulr1 !addrA. + case: (non_empty_tail _ d l2) => l3 [e qe]; rewrite qe. + rewrite -[ql1 ++ [:: x, y & l3 ++ [:: e]]]/(ql1 ++ [:: x, y & l3] ++ [:: e]). + rewrite [_ ++ _ ++ [:: e]]catA !cats1 -!rot1_cons; move/rot_inj; case=> -> q''. + case: (map_contiguous _ _ (fun x => t1+(e-t1)*((Qcb_make x)/(Qcb_make n))) + _ _ _ _ _ q'') => [l'1 [l'2 [n1 [n2 [_ [_ [qx [qy st]]]]]]]]. + rewrite qx qy. + have n21 : n2 = n1 + 1 by apply: ns_step st. + split. + rewrite n21 [t1 + _]addrC -addrA oppr_add [t1 + _]addrA addrN add0r -mulrN + -mulr_addr -mulNr -[_ * _^-1 + _]mulr_addl. + have fact5: Qcb_make (n1 + 1) - Qcb_make n1 = 1. + by rewrite -[_ - _]/(Q2Qcb (Qcb_make _ + Qcbopp(Qcb_make _))) + /Qcbopp /Qcb_make ?qcb_valE /Qopp /Qden /Qnum /Q2Qcb ?qcb_valE + (eqP (Qcb_Z _)) /Qplus /Qden /Qnum /Pmult 2!Zmult_1_r -Zplus_assoc + [Zplus _ (Zopp _)]Zplus_comm Zplus_assoc Zplus_opp_r Zplus_0_l. + by rewrite fact5 mul1r. + exists n1; split; first by rewrite mulrA. + have bds : (1 <= n1) && (n1 <= (n-1)). + have fact9 : (n - 1) - (n - 2%Z) = 1 + by rewrite oppr_add opprK addrA [ _ - n]addrC addKr. + by rewrite -{1}fact9; apply: ns_bounds _ _ _ _ _ fact8 st. + move/andP: bds => [bds1 bds2];split; last by []. + have fact6: 0 <= n1 by apply: ler_trans bds1; apply: ltrW; apply ltr01. + by []. +case: mkl => [sl qsl]. +have fact7 : ~ eval_pol l b < 0. + by apply/negP; rewrite ltrNge. +case: (find_pair _ (fun x => (eval_pol l x) < 0) + (fun x y => y - x = (b-a)/Qcb_make n /\ + (exists k, x = a + (b-a)*Qcb_make k / Qcb_make n /\ + 0 <= k /\ k <= (n-1))) sl a b nla fact7 qsl) => + [a' [b' [[A1 [k [A4 A5]]] [A2 A3]]]] {qsl sl}. +exists a'; exists b'. +have aa' : a <= a'. + rewrite -(addr0 a) A4; apply: lter_add=> /=; first by apply lerr. + rewrite mulr_ge0pp //; first apply: mulr_ge0pp; rewrite ?(ltrW ba') //. + by apply: leb_0_Z; case: A5. + by rewrite invf_gte0 /=; apply: leb_0_Z; apply: ltrW. +have bb' : b' <= b. + have bdec : b = a + (b - a) * (Qcb_make n) / (Qcb_make n). + have nn0 : Qcb_unit (Qcb_make n). + apply/negP => nq0; move/Qcb_QeqP: nq0. + rewrite /Qeq Zmult_1_r /Qcb_make qcb_valE /Qnum Zmult_0_l => nq0. + by move: fact1; rewrite nq0 ltrr. + by rewrite mulrK // addrA [a + _]addrC addrK. + have b'a: b' = a' + (b' - a') by rewrite addrA [ a' + _]addrC addrK /=. + rewrite b'a A1 A4 -addrA {3}bdec -mulr_addl; apply: lter_add; rewrite /= ?lerr //=. + rewrite lter_mulpr //=; first by rewrite invf_gte0; apply: leb_0_Z; apply: ltrW. + rewrite -{2}[b - a]mulr1 -mulr_addr lter_mulpl //= ?(ltrW ba') //. + rewrite -Qcb_make1 -(eqP (Qcb_make_add _ _)) /=; apply: leb_Z. + by case: A5=> _; rewrite -(lter_add2l 1) addrNK. +have ab' : a' < b'. + by rewrite -(lter_add2l (- a')) addrN A1 /= mulf_gte0 /= invf_cp0 /= ltb_0_Z // ba'. +have epsban: (b-a)*c/Qcb_make n <= eps. + by rewrite ltef_divpl ?ltb_0_Z // [eps * _]mulrC -ltef_divpl. +have main: eval_pol l b' - eval_pol l a' <= eps. + rewrite !q -(@ger0_abs _ (_ - _)). + have b'a': c * (b' - a') <= eps by rewrite A1 mulrA (mulrC c). + apply: ler_trans b'a'; rewrite -{2}(addr0 b') -(addNr a) addrA + -(addrA (b' - a)) -(opprK (a - a')) oppr_add opprK (addrC (-a)). + apply: pc. + - by rewrite subr_gte0. + - by rewrite lter_add2l /= ltrW. + - by rewrite lter_add2l. + rewrite -!q lter_addpl //=; first by rewrite oppr_gte0 /= ltrW. + by rewrite -ltrNge; apply/negP. +split; last (split; first exact A2). + rewrite lter_oppl /=; apply: ler_trans main. + by rewrite lter_addrl /= -ltrNge; apply/negP. +split; first by rewrite -ltrNge; move/negP: A3. +split; last by auto. +apply: ler_trans main; rewrite -{1}(addr0 (eval_pol l b')); apply: lter_add; rewrite /= ?lerr //. +by rewrite /= oppr_gte0 /= ltrW. +Qed. +*) diff --git a/theories/conv.v b/theories/conv.v new file mode 100644 index 0000000..46b2a86 --- /dev/null +++ b/theories/conv.v @@ -0,0 +1,364 @@ +From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals normedtype order boolp classical_sets. +Require Import counterclockwise. + +(******************************************************************************) +(* a <| t |> b := t *: a + (1 - t) *: b where a,b : lmodType R *) +(* for instance, a <| 0 |> b = b, etc. *) +(* between x y z := x \in [y,z] *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing Num.Theory Order.POrderTheory Order.TotalTheory. + +Local Open Scope order_scope. +Local Open Scope ring_scope. + +Section In01. +Variable R : realType. + +Definition in01 (t : R) := 0 <= t <= 1. + +Lemma in010 : in01 0. +Proof. by rewrite/in01 lexx ler01. Qed. + +Lemma in011 : in01 1. +Proof. by rewrite/in01 lexx ler01. Qed. + +Lemma in01_ge0 t : in01 t -> 0 <= t. +Proof. by move=>/andP[]. Qed. + +Lemma in01M_ge0 (t : R) : in01 t = (0 <= t * (1-t)). +Proof. +apply/idP/idP. + by move=>/andP[t0 t1]; apply mulr_ge0=>//; rewrite subr_ge0. +move=>ge0; apply/andP; split; rewrite leNgt; apply/negP=>ti; move:ge0. + by rewrite nmulr_rge0// subr_le0=>t1; move:(lt_trans ltr01 (le_lt_trans t1 ti)); rewrite ltxx. +by move:(ti); rewrite -subr_lt0=>t1'; rewrite nmulr_lge0// =>t0; move:(lt_trans (le_lt_trans t0 ltr01) ti); rewrite ltxx. +Qed. + +Lemma in01_onem t : in01 t = in01 (1 - t). +Proof. by rewrite 2!in01M_ge0 opprB addrCA subrr addr0 mulrC. Qed. + +Lemma in01M t u : in01 t -> in01 u -> in01 (t * u). +Proof. +move=>/andP[t0 t1]/andP[u0 u1]; apply/andP; split; first by apply mulr_ge0. +by apply mulr_ile1. +Qed. + +Lemma in01M1 t u : in01 t -> in01 u -> (t * u == 1) = (t == 1) && (u == 1). +Proof. +move=>/andP[t0 t1]/andP[u0 u1]. +apply/idP/idP; last by move=>/andP[/eqP-> /eqP->]; rewrite mulr1. +case tn1: (t == 1); first by move:tn1=>/eqP->; rewrite mul1r. +case un1: (u == 1); first by move:un1=>/eqP->; rewrite mulr1 tn1. +move=>/eqP tu1/=. +suff: t * u < 1 by rewrite tu1 ltxx. +by apply mulr_ilt1=>//; rewrite -subr_gt0 lt0r subr_eq0 subr_ge0 eq_sym ?t1 ?u1 ?tn1 ?un1. +Qed. + +Lemma in01_convA t u : in01 t -> in01 u -> in01 (t / (1-(1-t)*(1-u))). +Proof. +move=> t01 u01. +have c0 : 0 <= 1 - (1 - t) * (1 - u). + by move:t01 u01; rewrite in01_onem=>t01; rewrite in01_onem=>/(in01M t01); rewrite in01_onem=>/andP[]. +apply/andP; split. + by apply divr_ge0=>//; move:t01=>/andP[]. +have [->|e0] := eqVneq (1 - (1 - t) * (1 - u)) 0; first by rewrite invr0 mulr0; exact ler01. +rewrite -{4}(divff e0). +rewrite ler_wpM2r ?invr_ge0//. +rewrite mulrBr mulr1 mulrBl -addrA opprD addrA subrr add0r opprB opprK -mulrBl -subr_ge0 -addrA subrr addr0; apply mulr_ge0; last by move:u01=>/andP[]. +by move:t01; rewrite in01_onem=>/andP[]. +Qed. + +End In01. + +Section Conv. +Variable R : realType. +Variable E : lmodType R. + +Definition conv (t : R) (a b : E) := t *: a + (1 - t) *: b. + +End Conv. + +(* NB(rei): same notation as infotheo *) +Reserved Notation "x <| p |> y" (format "x <| p |> y", at level 49). +Notation "a <| p |> b" := (conv p a b). (* TODO(rei): needs scope *) + +Section Conv. +Variable R : realType. +Variable E : lmodType R. +Implicit Types (t u v : R) (a b c d : E). + +Lemma conv0 a b : a <| 0 |> b = b. +Proof. by rewrite/conv scale0r add0r subr0 scale1r. Qed. + +Lemma conv1 a b : a <| 1 |> b = a. +Proof. by rewrite/conv scale1r subrr scale0r addr0. Qed. + +Lemma convmm t a : a <| t |> a = a. +Proof. by rewrite/conv -scalerDl addrCA subrr addr0 scale1r. Qed. + +Lemma convC t a b : a <| t |> b = b <| 1 - t |> a. +Proof. by rewrite/conv opprB addrCA subrr addr0 addrC. Qed. + +Lemma convlr t a b : a <| t |> b = a + (1 - t) *: (b-a). +Proof. by rewrite scalerDr scalerN addrCA -{2}[a]scale1r -scalerBl opprB addrCA subrr addr0 addrC. Qed. + +Lemma convrl t a b : a <| t |> b = b + t *: (a - b). +Proof. by rewrite convC convlr opprB addrCA subrr addr0. Qed. + +End Conv. + +Section Conv. +Variable R : realType. +Variable E : lmodType R. +Implicit Types (t u v : R) (a b c d : E). + +Lemma convA t u a b c : in01 t -> in01 u -> + a <| t |> (b <| u |> c) = + (a <| t / ((1 : R^o) <| t |> u) |> b) <| (1 : R^o) <| t |> u |> c. +Proof. +move=> t01 u01. +have -> : (1 : R^o) <| t |> u = 1 - (1 - t) * (1 - u). + by rewrite (convlr _ (1 : R^o)) -[u-1]opprB scalerN. +rewrite/conv scalerDr addrA 2!scalerA opprB addrCA subrr addr0; congr add. +have [/eqP|tu1] := eqVneq (1 - (1 - t) * (1 - u)) 0. + rewrite {1}subr_eq0 eq_sym in01M1 -?in01_onem// -2![_-_ == 1]subr_eq0. + rewrite 2![1-_-1]addrAC subrr 2!add0r 2!oppr_eq0=>/andP[/eqP-> /eqP->]. + by rewrite mulr0 subr0 mulr1 subrr 3!scale0r addr0. +rewrite scalerDr 2!scalerA [(1-_*_)*(1-_)]mulrBr mulrCA divff// 2!mulr1 mulrBr. +by rewrite mulr1 addrAC opprB addrCA subrr addr0. +Qed. + +Lemma convA' t u a b c : in01 t -> in01 u -> + (a <| u |> b) <| t |> c = + a <| t * u |> (b <| t * (1 - u) / ((1 - u : R^o) <| t |> 1) |> c). +Proof. +move=>t01 u01. +rewrite convC (convC u) convA. + 2, 3: by rewrite -in01_onem. +rewrite -convC convC (convC _ c). +have -> : (1 - u : R^o) <| t |> 1 = 1 - t * u. + by rewrite (convrl _ _ 1) addrAC subrr add0r scalerN. +rewrite opprB addrCA subrr addr0. +have [/eqP|tu1] := eqVneq (1 - t * u) 0. + by rewrite subr_eq0 eq_sym in01M1// =>/andP[/eqP-> /eqP->]; rewrite 2!mul1r 2!conv1. +congr (_ <| _ |> (_ <| _ |> _)). +by apply (mulfI tu1); rewrite mulrBr mulr1 2![(1-t*u)*(_/_)]mulrCA divff// 2!mulr1 opprB addrCA addrAC subrr add0r mulrBr mulr1. +Qed. + +Lemma in01_conv (t u v : R) : in01 t -> in01 u -> in01 v -> + in01 ((u : R^o) <| t |> v). +Proof. +move=>/andP[t0 t1] /andP[u0 u1] /andP[v0 v1]; apply/andP; split. + apply addr_ge0; apply mulr_ge0=>//. + by rewrite subr_ge0. +have<-: t + (1-t) = 1 by rewrite addrCA subrr addr0. +apply: lerD; rewrite -subr_ge0. + rewrite -{1}[t]mulr1 -mulrBr; apply mulr_ge0=>//. + by rewrite subr_ge0. +by rewrite -{1}[1-t]mulr1 -mulrBr; apply mulr_ge0; rewrite subr_ge0. +Qed. + +Lemma in01_convl (t u : R) : 0 <= t*u -> in01 (t / (t+u)). +Proof. +have H: forall a b : R, 0 <= a*b -> 0 <= a/(a+b) by move=>a b ab0; rewrite -sgr_ge0 sgrM sgrV -sgrM sgr_ge0 mulrDr -expr2; apply addr_ge0=>//; apply sqr_ge0. +move=>tu0. +have [->|tun0] := eqVneq (t + u) 0. + by rewrite invr0 mulr0; apply in010. +apply/andP; split; first by apply H. +rewrite -{1}[t](addr0) -(subrr u) addrA mulrBl divff// -subr_ge0 opprB addrCA subrr addr0 addrC; apply H. +by rewrite mulrC. +Qed. + +Lemma conv_onem (t u v : R) : + (1-u : R^o) <| t |> (1-v) = + 1 - (u : R^o) <| t |> v. +Proof. +rewrite/conv 2!scalerBr addrACA opprD; congr add. +have sm: forall u, u *: (1 : R^o) = u*1 by []. +by rewrite 2!sm 2!mulr1 addrCA subrr addr0. +Qed. + +Lemma convACA (t u v : R) (a b c d : E) : in01 t -> in01 u -> in01 v -> + (a <| u |> b) <| t |> (c <| v |> d) = + (a <| t * u / ((u : R^o) <| t |> v) |> c) + <| (u : R^o) <| t |> v |> + (b <| t * (1 - u) / ((1 - u : R^o) <| t |> (1 - v)) |> d). +Proof. +move=>/andP[t0 t1]/andP[u0 u1]/andP[v0 v1]. +move:t0; rewrite le0r => /orP[|]. + by move=>/eqP->; rewrite !mul0r !conv0. +move=>t0; move:t1; rewrite -subr_ge0 le0r => /orP[|]. + rewrite subr_eq0=>/eqP<-; rewrite !mul1r !conv1. + move:u0; rewrite le0r => /orP[|]. + by move=>/eqP->; rewrite subr0 !conv0 divff ?oner_neq0// conv1. + rewrite lt0r=>/andP[u0 _]; rewrite divff// conv1. + move:u1; rewrite -subr_ge0 le0r => /orP[|]. + by rewrite subr_eq0=>/eqP<-; rewrite 2!conv1. + by rewrite lt0r=>/andP[t1 _]; rewrite divff// conv1. +move=>t1. +have c0: forall x y : R, 0 <= x -> 0 <= y -> (x : R^o) <| t |> y = 0 -> x = 0 /\ y = 0. + move=>x y; rewrite le0r => /orP[|]. + move=>/eqP-> _ /eqP. + rewrite/conv scaler0 add0r mulf_eq0 => /orP[|]. + by move=>t1'; move:t1; rewrite lt0r=>/andP[/negPf]; rewrite t1'. + by move=>/eqP->. + move=>x0 y0 c0. + suff: 0 < (x : R^o) <| t |> y by rewrite c0 ltxx. + rewrite /conv -(addr0 0) ; apply: ltr_leD. + by apply mulr_gt0. + by apply mulr_ge0=>//; apply ltW. +have [|uv0] := eqVneq ((u : R^o) <| t |> v) 0. + by move=>/(c0 _ _ u0 v0) [-> ->]; rewrite convmm !conv0 subr0 convmm -mulrA divff ?oner_neq0// mulr1. +move:u1 v1; rewrite -2![_ <= 1]subr_ge0=>u1 v1. +have [|uv0'] := eqVneq ((1 - u : R^o) <| t |> (1 -v)) 0. + by move=> /(c0 _ _ u1 v1)[/eqP]; rewrite subr_eq0=>/eqP<- /eqP; rewrite subr_eq0=>/eqP<-; rewrite convmm !conv1 -mulrA divff ?oner_neq0// mulr1. +rewrite{1 2 3 4 6 8}/conv 4!scalerDr 2!addrA !scalerA -conv_onem. +rewrite 2![((_ : R^o) <| _ |> _) * (1 - _)]mulrBr 2![_ * (_ * _ / _)]mulrC -!mulrA 2![_^-1 * _]mulrC divff// divff// !mulr1 /conv [t *: _ + _ + _]addrAC subrr add0r [t *: _ + _ + _]addrAC subrr add0r; congr add. +by rewrite -2!addrA; congr add; rewrite addrC. +Qed. +End Conv. + +Section between. +Variable R : realType. +Let Plane : vectType _ := (R^o * R^o)%type. + +Lemma det_conv (p p' q r : Plane) (t : R) : + det (p <| t |> p') q r = (det p q r : R^o) <| t |> det p' q r. +Proof. +have sm t' u : t' *: (u : R^o) = t' * u by []. +rewrite/conv !sm -det_cyclique -[det p q r]det_cyclique -[det p' q r]det_cyclique 3!det_scalar_productE -2!scalar_productZL -scalar_productDl; congr scalar_product. +rewrite 2!scalerBr -!addrA; congr GRing.add. +rewrite !addrA [-_ + _]addrC -addrA; congr GRing.add. +by rewrite -[-(t*:r)]scaleNr -scalerBl -opprB opprK -addrA [-t+t]addrC subrr addr0 scaleN1r. +Qed. + +Lemma det0_aligned (p q r: Plane) : det p q r = 0%R <-> + (p = q \/ exists t, p <| t |> q = r). +Proof. +rewrite det_scalar_productE. +symmetry; split. + case. + by move=>->; rewrite subrr -(scaler0 _ 0) scalar_productZL mul0r. + by move=> [t <-]; rewrite convlr addrAC subrr add0r rotateZ scalar_productZR scalar_product_rotatexx mulr0. +wlog: p q r / p == 0%R. + move=> h; rewrite -[q-p]subr0 -[r-p]subr0. + move=>/(h 0%R (q-p) (r-p) (eqxx 0%R)); case=>[ /eqP | [t] ]. + by rewrite eq_sym subr_eq0 eq_sym=>/eqP=>pq; left. + by rewrite{1}/conv scaler0 add0r=>/(f_equal (fun x=> p+x)); rewrite [r-p]addrC addrA subrr add0r=><-; right; exists t=>//; apply convlr. +move=>/eqP p0; subst p; rewrite !subr0/scalar_product/= mulrN=>/eqP; rewrite subr_eq0=>/eqP e. +have [q0|q0] := eqVneq q 0%R; first by left. +right. +move:q0; rewrite -pair_eqE /= negb_and => /orP[|] q0. + exists (1 - xcoord r / xcoord q)=>//. + rewrite -convC convrl add0r subr0; apply /eqP; rewrite -pair_eqE; apply /andP; split=>/=. + - apply/eqP. + transitivity ((xcoord r / xcoord q) * q.1) => //. + by rewrite -mulrA [_^-1*_]mulrC divff // mulr1. + - apply/eqP. + transitivity ((xcoord r / xcoord q) * q.2) => //. + by rewrite mulrC mulrA -e mulrC mulrA [_^-1*_]mulrC divff // mul1r. +exists (1 - ycoord r / ycoord q)=>//. + rewrite -convC convrl add0r subr0; apply /eqP; rewrite -pair_eqE; apply /andP; split=>/=. + - apply/eqP. + transitivity ((ycoord r / ycoord q) * q.1) => //. + by rewrite mulrC mulrA e mulrC mulrA [_^-1*_]mulrC divff // mul1r. + - apply/eqP. + transitivity ((ycoord r / ycoord q) * q.2) => //. + by rewrite -mulrA [_^-1*_]mulrC divff // mulr1. +Qed. + +Definition between (x y z : Plane) := [&& (det x y z == 0)%R, + (0%R <= scalar_product (x - y) (z - y)) , + (0%R <= scalar_product (x - z) (y - z)) & + ((y == z) ==> (x == z))]. + +Lemma between_conv x y z : between x y z <-> + exists t, in01 t && (x == y <| t |> z). +Proof. +case yz: (y == z). + rewrite/between yz; move:yz=>/eqP yz; rewrite yz subrr -(scale0r 0) scalar_productZR mul0r det_cyclique det_alternate eqxx lexx/=. + split; first by move=>/eqP->; exists 0; rewrite in010 convmm/=. + by move=>[t /andP[_]]; rewrite convmm. +rewrite /between yz/= andbT. +move:yz=>/negbT yz. +have zye: forall t (y z: Plane), t *: y + (1-t) *: z - y = (1-t) *: (z-y). + by move=>t y' z'; rewrite {1}[_*:_+_]addrC -addrA scalerBr; congr +%R; rewrite -scaleNr opprB scalerBl scale1r. +have yze: forall t (y z: Plane), t *: y + (1-t) *: z - z = t *: (y-z). + by move=>t y' z'; rewrite -addrA scalerBr; congr +%R; rewrite scalerBl scale1r [_-_*:_]addrC -addrA subrr addr0. +split. + rewrite det_cyclique =>/and3P[/eqP/det0_aligned]; case; first by move=> yz'; move:yz' yz=>->; rewrite eqxx. + move=>[t <-]. + rewrite yze zye 2!scalar_productZL=> yp zp; exists t; apply/andP; split=>//. + apply/andP; split. + by move:zp; rewrite pmulr_lge0//; apply scalar_productrr_gt0; rewrite subr_eq0. + by move:yp; rewrite pmulr_lge0 ?subr_ge0//; apply scalar_productrr_gt0; rewrite subr_eq0 eq_sym. +move=>[t] /andP [/andP [t0 t1]] /eqP->. +rewrite yze zye 2!scalar_productZL; apply/and3P; split. +- by rewrite det_cyclique; apply/eqP; apply det0_aligned; right; exists t. +- by rewrite mulr_ge0// ?subr_ge0// scalar_productrr_ge0. +- by rewrite mulr_ge0// scalar_productrr_ge0. +Qed. + +Lemma betweenC (a b c : Plane) : between a b c = between a c b. +Proof. +rewrite /between det_inverse -det_cyclique oppr_eq0; congr andb; rewrite !andbA; congr andb. + by apply andbC. +by rewrite eq_sym; apply implyb_id2l=>/eqP->. +Qed. + +Lemma betweenl (a b : Plane) : between a a b. +Proof. rewrite/between det_alternate eqxx/= subrr -(scale0r 0) scalar_productZL mul0r lexx/= Bool.implb_same andbT; apply scalar_productrr_ge0. Qed. + +Lemma betweenr (a b : Plane) : between a b a. +Proof. rewrite betweenC; apply betweenl. Qed. + +Lemma between_depl (a b c : Plane) : between a b c <-> + exists (d : Plane) (t u : R), + (t*u <= 0) && (b == a + t *: d) && (c == a + u *: d). +Proof. +split. + move=>/between_conv[t] /andP[t01]. + have aconv: a = t *: a + (1-t) *: a by rewrite -scalerDl addrCA subrr addr0 scale1r. + rewrite {1}aconv -subr_eq0 opprD addrACA -2!scalerBr. + case t1: (t == 1). + move:t1=>/eqP->; rewrite subrr scale1r scale0r addr0 subr_eq0=>/eqP->. + exists (c-b), 0, 1. + by rewrite mul0r lexx scale0r addr0 eqxx scale1r addrCA subrr addr0 eqxx. + rewrite addr_eq0 -scalerN opprB=>/eqP e. + exists (b-a), 1, (-t / (1-t)). + move:t1=>/negbT; rewrite eq_sym -subr_eq0=>tn1. + move:t01=>/andP[t0 t1]; rewrite mul1r mulNr oppr_le0 scale1r addrCA subrr addr0 eqxx mulrC scaleNr -scalerN opprB -scalerA e scalerA [_*(1-t)]mulrC divff// scale1r addrCA subrr addr0 eqxx 2!andbT; apply mulr_ge0=>//. + by rewrite invr_ge0 subr_ge0. +move=>[d][t][u]/andP[/andP[tu0]]. +wlog: d t u tu0 / 0 < t. + move=>h. + have [t0|t0] := ltP 0 t; first by apply h. + move:t0; rewrite le_eqVlt => /orP[|]. + by move=>/eqP->; rewrite scale0r addr0=>/eqP-> _; apply betweenl. + by rewrite -oppr_gt0 -(opprK d) 2![_ *: - - _]scalerN -2!scaleNr; apply h=>//; rewrite mulrN -mulNr opprK. +move=>t0 /eqP be /eqP ce. +move:tu0; rewrite pmulr_rle0// =>u0. +have tugt0: 0 < t-u by rewrite subr_gt0; exact (le_lt_trans u0 t0). +have tun0: t-u != 0 by apply/negP=>/eqP tu0; move:tugt0; rewrite tu0 ltxx. +apply/between_conv; exists (-u/(t-u)); apply/andP; split. + apply/andP; split. + by rewrite mulr_ge0 ?oppr_ge0// invr_ge0 ltW. + by rewrite -subr_ge0 -(pmulr_rge0 _ tugt0) mulrBr mulrCA divff// 2!mulr1 -addrA subrr addr0; apply ltW. +by rewrite/conv be ce 2!scalerDr addrACA -scalerDl [_ + (1-_)]addrCA subrr addr0 scale1r -subr_eq0 opprD addrA subrr add0r oppr_eq0 2!scalerA -scalerDl mulrBl mul1r addrCA -mulrBr mulrAC -mulrA divff// mulr1 subrr scale0r. +Qed. + +Lemma between_trans (a b c d e : Plane) : + between c a b -> between d a b -> between e c d -> between e a b. +Proof. +move=>/between_conv[t]/andP[t01 /eqP->] /between_conv[u]/andP[u01 /eqP->] /between_conv[v]/andP[v01 /eqP->]. +rewrite convACA// 2!convmm. +apply between_conv; exists ((t : R^o) <| v |> u); apply/andP; split=>//. +by apply in01_conv. +Qed. + +End between. diff --git a/theories/convex.v b/theories/convex.v new file mode 100644 index 0000000..c4370a7 --- /dev/null +++ b/theories/convex.v @@ -0,0 +1,545 @@ +From HB Require Import structures. +From mathcomp Require Import all_ssreflect all_algebra lra. +From mathcomp Require Import mathcomp_extra boolp Rstruct classical_sets. +From mathcomp Require Import reals ereal interval_inference. +From infotheo Require Import realType_ext fdist convex. +Require Import preliminaries. + +Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory preliminaries. +Import fdist convex. +Local Open Scope ring_scope. + +Local Close Scope N_scope. +Delimit Scope nat_scope with N. +Delimit Scope int_scope with Z. +Delimit Scope ring_scope with R. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Definition R := Rdefinitions.R. + +Section convex. +Variable (E : convType R). + +Local Open Scope classical_set_scope. +Local Open Scope convex_scope. + +Definition convex_set_of (A : set E) : is_convex_set A -> {convex_set E}. +by move=> Aconv; exists A; constructor; constructor. +Defined. + +Lemma is_convex_setI (C D : {convex_set E}) : is_convex_set (C `&` D). +Proof. +apply/asboolP =>x y p [Cx Dx] [Cy Dy]; split. + by move/asboolP: (convex_setP C); apply. +by move/asboolP: (convex_setP D); apply. +Qed. + +Lemma hullX (F : @convType R) (C : set E) (D : set F) : + hull (C `*` D) = hull C `*` hull D. +Proof. +rewrite eqEsubset; split. + move=>+ [n][/=g][/=d][gCD]-> =>_. + rewrite Convn_pair; split=>/=; + exists n; [exists (Datatypes.fst \o g) | exists (Datatypes.snd \o g)]; exists d; split=> // + [i] _ <- =>_ /=; + (suff: ((C `*` D) (g i)) by move=>[]); + by apply gCD; exists i. +move=>[+ +][]/=[n][g][d][gC->][m][f][e] [fD->]=>_ _. +exists (n * m)%N, (fun i=> let (i, j) := split_prod i in (g i, f j)), (fdistmap (unsplit_prod (n:=m)) (d `x e)%fdist); split. + move=>+ [i] _ <- =>_. + by case: (split_prod i)=>a b; split; [apply gC | apply fD]. +rewrite Convn_pair/comp/=; congr pair; + apply: (S1_inj R); rewrite [LHS]S1_Convn [RHS]S1_Convn big_prod_ord/=. + apply eq_big => // i _. + rewrite -(scale1pt (scalept _ _)) scaleptA // -(FDist.f1 e). + rewrite mulr_suml. + pose h x := e x * d i. + have h0 x : 0 <= h x by rewrite /h mulr_ge0. + under eq_bigr => j _ do rewrite -[e j * d i]/(h j). + rewrite scalept_sum//; apply eq_big=>// j _. + rewrite /h /= fdistmapE. + have -> : (\sum_(a in {: 'I_n * 'I_m} | + a \in preim (@unsplit_prod _ m) (pred1 (Ordinal (unsplit_prodp i j)))) + (fdist_prod d (fun=> e)) a = + \sum_(a in {: 'I_n * 'I_m} | a \in pred1 (i, j)) + (fdist_prod d (fun=> e)) a)%R. + apply eq_big=>// k; congr andb; rewrite 3!inE. + by apply: (eqtype.inj_eq _ k (i, j)); exact: (can_inj (@unsplit_prodK _ _)). + rewrite (big_pred1 (i, j))// fdist_prodE/= mulrC; congr (scalept _ (S1 (g _))). + by move: (unsplit_prodK (i, j)) => /(congr1 Datatypes.fst)/esym. +rewrite (exchange_big_dep xpredT)//=; apply: eq_bigr => j _. +rewrite -(scale1pt (scalept _ _)) scaleptA// -(FDist.f1 d). +rewrite mulr_suml. +pose h x := d x * e j. +have h0 x : 0 <= h x by rewrite /h mulr_ge0. +under eq_bigr => i _ do rewrite -[d i * e j]/(h i). +rewrite scalept_sum//; apply: eq_big => // i _. +rewrite /h/= fdistmapE. +have -> : (\sum_(a in {: 'I_n * 'I_m} | + a \in preim (unsplit_prod (n:=m)) (pred1 (Ordinal (unsplit_prodp i j)))) + (fdist_prod d (fun=> e)) a = + \sum_(a in + {: 'I_n * 'I_m} | a \in pred1 (i, j)) + (FDist.f (fdist_prod d (fun=> e))) a)%R. + apply: eq_big=>// k; congr andb; rewrite 3!inE. + by apply: (eqtype.inj_eq _ k (i, j)); exact (can_inj (@unsplit_prodK _ _)). +rewrite (big_pred1 (i, j))// fdist_prodE/=; congr (scalept _ (S1 (f _))). +by move:(unsplit_prodK (i, j))=>/(congr1 Datatypes.snd)/esym. +Qed. + +End convex. +Import LmoduleConvex. +Lemma add_affine (E : lmodType R) : affine (fun p : E * E => p.1 + p.2). +Proof. +move=>p/= [x0 x1] [y0 y1]/=. +by rewrite/conv/= addrACA -2!scalerDr. +Qed. + +Lemma scale_affine (E : lmodType R) (t : R) : affine (fun x : E => t *: x). +Proof. +move=> p/= x y. +by rewrite/conv/= scalerDr; congr GRing.add; rewrite 2!scalerA mulrC. +Qed. + +Section C. +Variable E F: lmodType R. +Variable f : {linear E -> F}. + +Local Open Scope fun_scope. +Local Open Scope ring_scope. +Local Open Scope convex_scope. + +Lemma ker_convex: is_convex_set (preimage f [set 0]). +Proof. +apply/asboolP=>x y p /= fx0 fy0. +by rewrite linearD 2!linearZZ fx0 fy0 2!GRing.scaler0 addr0. +Qed. + +End C. + +Section face. +Variable E : convType R. + +Local Open Scope fun_scope. +Local Open Scope ring_scope. + +Definition ext (A : set E) := [set x | forall u v, u \in A -> v \in A -> + x \in segment u v -> x = u \/ x = v]%classic. + +Definition face (A F: set E) := [/\ (F `<=` A)%classic, is_convex_set F & + forall x u v, x \in F -> u \in A -> v \in A -> x \in segment u v -> + x != u -> x != v -> u \in F /\ v \in F]. + +Definition face' (A F: set E) := [/\ (F `<=` A)%classic, is_convex_set F & + forall x u v, x \in F -> u \in A -> v \in A -> x \in segment u v -> x != v -> u \in F]. + +Lemma face'P (A F: set E): face A F <-> face' A F. +Proof. +split => [[FA Fconv Fface]|[FA Fconv Fface]]. + split=> // x u v xF uA vA xuv xv; have [xu|xu] := eqVneq x u. + by rewrite xu in xF. + by move: (Fface x u v xF uA vA xuv xu xv) => []. +split => // x u v xF uA vA xuv xu xv; split; [ apply (Fface x u v) | apply (Fface x v u) ] =>//. +by rewrite segmentC. +Qed. + +End face. + +(* TODO: rm, will be fixed in infotheo 0.7.1 *) +Module LinearAffine. +Section linear_affine. +Open Scope ring_scope. +Variables (E F : lmodType R) (f : {linear E -> F}). +Import LmoduleConvex. +Let linear_is_affine: affine f. +Proof. by move=>p x y; rewrite linearD 2!linearZZ. Qed. + +#[export] HB.instance Definition _ := isAffine.Build _ _ _ _ linear_is_affine. + +End linear_affine. +End LinearAffine. +HB.export LinearAffine. + +Section face. + +Variable E: lmodType R. + +Local Open Scope fun_scope. +Local Open Scope ring_scope. +Local Open Scope convex_scope. + +Lemma probinvn1 : probinvn 1 = (1 / 2%R : R)%:pr. +Proof. +apply: val_inj => /=. +by rewrite div1r. +Qed. + +Lemma onem_half: onem 2^-1 = 2^-1 :> R. +Proof. +rewrite /onem. +rewrite [X in X - _ = _](splitr 1). +by rewrite div1r addrK. +Qed. + +Lemma ext_carac (A : {convex_set E}) (x: E): x \in A -> [<-> x \in ext A; + forall u v, u \in A -> v \in A -> x = u <| probinvn 1 |> v -> u = v; + is_convex_set (A `\ x)%classic; + face A [set x]]. +Proof. +move=>xA. +have ne20: (2 : R) != 0. + by rewrite pnatr_eq0. +have ge20: (0 : R) <= 2. + by rewrite ler0n. +split. + move=>xext u v uA vA xe. + move: xext=>/set_mem /(_ u v uA vA). + have xuv: x \in segment u v. + by apply mem_set; subst x; exists (probinvn 1). + move=>{uA} {vA} /(_ xuv) {xuv}. + wlog: u v xe / x = u. + move=> h; case=> xe'. + by apply h=>//; left. + apply /esym; apply h=>//; last by left. + rewrite xe convC; congr (v <| _ |> u). + apply val_inj=>/=. + set tmp : R := (1 + 1)%:R. + rewrite (_ : tmp = 2%R)//. + by rewrite onem_half. + move: xe=> -> + _. + move=> /(congr1 (fun x => 2 *: x)). + rewrite scalerDr probinvn1/=. + rewrite div1r. + rewrite onem_half 2!scalerA divff// 2!scale1r. + by rewrite scaler_nat mulr2n =>/addrI/esym. +split. + move=>xext. + apply/asboolP=>u v t [uA ux] [vA vx]. + split; first by move:(convex_setP A)=>/asboolP; apply. + wlog: u v t xext xA uA ux vA vx / Prob.p t <= 2^-1. + move=>h. + have [tle|tle] := leP (Prob.p t) (2^-1); first exact: (h u v t). + rewrite convC. + apply (h v u (onem t)%:pr)=>//. + rewrite -onem_half; apply: lerB=>//. + exact/ltW. + move=>tle. + have t01: ((Rdefinitions.IZR BinNums.Z0) <= 2%:R * (Prob.p t : R)) && + (2*(Prob.p t : R) <= Rdefinitions.IZR (BinNums.Zpos 1%AC)). + apply/andP; split. + by apply mulr_ge0=>//. + by move:tle=>/(ler_wpM2l ge20); rewrite divff. + move=>/esym xE. + move: xext=>/(_ (u <| Prob.mk t01 |> v) v). + rewrite -convA' convmm. + have ->: p_of_rs (Prob.mk t01) (probinvn 1) = t. + apply val_inj. + rewrite/= p_of_rsE/=. + have tE: (2*(Prob.p t : R))/2 = Prob.p t. + by rewrite mulrAC divff// mul1r. + by rewrite -{2}tE. + have wA: u <| Prob.mk t01 |> v \in A. + by apply mem_set; move:(convex_setP A)=>/asboolP; apply. + move: vA=>/mem_set vA /(_ wA vA xE) /(congr1 (fun x => x-v)). + rewrite subrr /conv/= -addrA -{2}(scale1r v) -scalerBl addrAC subrr add0r scaleNr -scalerBr. + apply /eqP; rewrite scaler_eq0; apply /negP=>/orP; case. + rewrite mulf_eq0 pnatr_eq0/= =>/eqP t0. + move:xE. + have ->: t = 0%:pr by apply val_inj. + by rewrite conv0=>/esym. + rewrite subr_eq0=>/eqP uv; subst v. + by move:xE; rewrite convmm=>/esym. +split. + move=>/asboolP Axconv. + split; [ by move=>u /= ->; apply set_mem | by apply is_convex_set1 | ]=> y u v /set_mem -> /set_mem uA /set_mem vA /set_mem [p _ xE] xu xv; exfalso. + have uAx: (A `\ x)%classic u by split=>//= ux; subst u; move: xu; rewrite eq_refl. + have vAx: (A `\ x)%classic v by split=>//= vx; subst v; move: xv; rewrite eq_refl. + have: (A `\ x)%classic x by rewrite -{2}xE; apply (Axconv _ _ _ uAx vAx). + by move=>[_ /= f]. +move=>xface; apply /mem_set=>u v uA vA xuv. +suff: (x == u) || (x == v) by move=>/orP; case=> /eqP ->; [ left | right ]. +apply /negP=>/negP; rewrite negb_or=>/andP [xu xv]. +move: xface=> [_ _ /(_ x u v)]. +have xx: x \in [set x]%classic by apply /mem_set. +move=>/(_ xx uA vA xuv xu xv) [/set_mem /= ux /set_mem /= vx]; subst u. +by move: xu; rewrite eq_refl. +Qed. + +Lemma face_trans (A : set E) (F : set E) (G : set E) : face A F -> face F G -> face A G. +Proof. +move=>[AF Fconv Fface] [FG Gconv Gface]. +split => //. +- by move=> x Gx; apply AF, FG. +- move=>// x u v xG uA vA xuv xu xv. + have [uF vF]: (u \in F /\ v \in F). + apply (Fface x)=>//. + by apply mem_set, FG, set_mem. + by apply (Gface x). +Qed. + +Definition supporting_hyperplane (A : set E) (f: {linear E -> R^o}) (a: R) := + (exists x, x \in A /\ f x = a) /\ + ((forall x, x \in A -> f x <= a) \/ (forall x, x \in A -> a <= f x)). + +Lemma is_convex_set_preimage [T U : convType R] (f : {affine T -> U}) (A : {convex_set U}) : + is_convex_set (f @^-1` A)%classic. +Proof. +apply/asboolP=>x y p/= Ax Ay. +by rewrite affine_conv -in_setE; apply/mem_convex_set; rewrite in_setE. +Qed. + +(* TOTHINK : lemmas prove is_convex_set but use {convex_set _}. *) +Lemma supporting_hyperplan_face (A : {convex_set E}) (f: {linear E -> R^o}) (a: R) : + supporting_hyperplane A f a <-> + (exists x, x \in A /\ f x = a) /\ face A (A `&` (f @^-1` [set a])). +Proof. +split; move=>[hex hface]; split=>//. + wlog: f a hex hface / (forall x : E, x \in A -> f x <= a). + move=>h; move: (hface); case=>hf. + by apply (h f a). + move: h=>/(_ (f \o (@GRing.opp E)) (- a)). + have hf' (x : E) : x \in A -> (f \o (@GRing.opp E)) x <= - a. + by move=> xA /=; rewrite -scaleN1r linearZZ scaleN1r lerNl opprK; apply hf. + have hex': exists x : E, x \in A /\ (f \o (@GRing.opp E)) x = - a. + by move: hex=>[x [xA fx]]; exists x; split=>//=; rewrite -fx -scaleN1r linearZZ scaleN1r. + move=>/(_ hex' (or_introl hf') hf'); congr (face A (A `&` _)). + by rewrite eqEsubset; split=>x /= /eqP; rewrite -scaleN1r linearZZ scaleN1r; [ rewrite eqr_opp | rewrite -eqr_opp ]=>/eqP. + move=> hf; apply face'P; split; [ by apply subIsetl | |]. + exact: (is_convex_setI _ (convex_set_of (is_convex_set_preimage f (set1 a)))). + move=> x u v /set_mem [xA xa] uA vA /set_mem [t _ tx] xv; apply mem_set; (split; [ by apply set_mem |]); apply /eqP; rewrite -lte_anti; apply /andP; (split; [ by apply hf |]). + have t0 : (Prob.p t : R) != 0. + by apply/eqP=>/val_inj t0; subst t; move: tx xv; rewrite conv0 => ->; rewrite eqxx. + have tgt : 0 < (Prob.p t : R) by rewrite lt0r t0=>/=. + move: tx=>/(f_equal (fun x=> (Prob.p t : R)^-1 *: (x - (onem t) *: v))). + rewrite -addrA subrr addr0 scalerA mulVf // scale1r=>->. + rewrite linearZZ linearD xa -scaleNr linearZZ ler_pdivlMl// addrC -subr_ge0 -addrA -mulNr -{1}[a]mul1r -mulrDl scaleNr -scalerN -mulrDr; apply mulr_ge0 => //. + by rewrite addrC Num.Internals.subr_ge0; apply hf. +have : forall x y, x \in A -> y \in A -> f x < a -> a < f y -> False. + move=> u v uA vA fua afv. + move: (Order.POrderTheory.lt_trans fua afv); rewrite -subr_gt0=>fufv. + have t01: (Rdefinitions.IZR BinNums.Z0 <= (f v - a) / (f v - f u))%R && + (((f v - a) / (f v - f u))%R <= Rdefinitions.IZR (BinNums.Zpos 1%AC)). + apply/andP; split. + by apply divr_ge0; apply ltW=>//; rewrite subr_gt0. + rewrite ler_pdivrMr// mul1r -subr_ge0 opprB addrAC addrCA subrr addr0 subr_ge0. + by apply ltW. + move: hface=>/face'P [_ _ /(_ (u <| Prob.mk t01 |> v) u v)]. + have inuv: u <| Prob.mk t01 |> v \in segment u v. + by apply mem_set; exists (Prob.mk t01). + have uva: f (u <| Prob.mk t01 |> v) = a. + rewrite/= affine_conv/=/conv/=. + move: fufv; rewrite lt0r=>/andP [fufv _]. + apply (mulfI fufv). + rewrite/GRing.scale/=. + rewrite mulrDr mulrAC mulrCA mulrAC divff// mulr1. + rewrite [onem _ * _]mulrBl mul1r mulrBr mulrAC mulrCA mulrAC divff// mulr1. + rewrite -mulrBl opprB addrAC addrCA subrr addr0. + rewrite 2!mulrBl mulrC addrAC addrCA subrr addr0. + by rewrite -mulrBr mulrC. + have Aa: u <| Prob.mk t01 |> v \in (A `&` f @^-1` [set a])%classic. + apply mem_set; split=>//. + by move:(convex_setP A)=>/asboolP; apply; rewrite -in_setE. + move=>/(_ Aa uA vA inuv). + have nev: u <|{| Prob.p := ((f v - a) / (f v - f u))%R; Prob.Op1 := t01 |}|> v != v. + rewrite -subr_eq0 -{4}(scale1r v) -addrA -scalerBl addrAC subrr add0r scaleNr -scalerBr scaler_eq0 subr_eq0. + apply/negP=>/orP; case=>/eqP. + move=>/= t0. + move:uva; rewrite/conv/= t0 scale0r add0r onem0 scale1r=>fva. + by move:afv; rewrite fva ltxx. + by move=>uv; move:fufv; rewrite uv subrr ltxx. + by move=>/(_ nev) /set_mem [_ /= fuae]; move: fua; rewrite fuae -subr_gt0 lt0r subrr eq_refl. +move=>h. +move: (boolp.EM (exists x: E, x \in A /\ f x < a)); case. + move: (boolp.EM (exists x: E, x \in A /\ a < f x)); case. + by move=>[y [yA afy]] [x [xA fxa]]; elim (h x y xA yA fxa afy). + by move=>allge _; left=> x xA; rewrite leNgt; apply /negP=>fxa; apply allge; exists x; split. +by move=>allge; right=> x xA; rewrite leNgt; apply /negP=>fxa; apply allge; exists x; split. +Qed. + +End face. +Section cone. + +Variable E: lmodType R. + +Local Open Scope fun_scope. +Local Open Scope ring_scope. +Local Open Scope convex_scope. + +Definition cone0 (A : set E) := + ([set t%:num *: a | t in (@setT {posnum R}) & a in A] `<=` A)%classic. + +Definition cone (x: E) (A: set E) := cone0 [set a - x | a in A]%classic. + +Lemma cone0_convex (A: set E): cone0 A -> + (is_convex_set A <-> ([set a+b | a in A & b in A] `<=` A)%classic). +Proof. +have ne20: (2 : R) != 0. + by rewrite pnatr_eq0. +have gt20 : ((0 : R) < 2)%R. + by rewrite ltr0n. +move=>Acone; split=>Aconv. + move=>x [u uA] [v vA] <-. + have uA2: A (2 *: u). + by apply: Acone => /=; exists 2%:pos => //; exists u. + have vA2: A (2 *: v) by apply Acone; exists 2%:pos =>//; exists v. + move:Aconv=>/asboolP/(_ _ _ (probinvn 1) uA2 vA2); congr A. + rewrite probinvn1/=. + rewrite /conv/=. + rewrite div1r. + by rewrite onem_half 2!scalerA mulVf// 2!scale1r. +apply/asboolP. +move=>x y t xA yA. +move:(prob_ge0 t); rewrite le0r=>/orP; case. + by rewrite/conv/= =>/eqP ->; rewrite scale0r add0r onem0 scale1r. +move=> t0; move: (prob_le1 t); rewrite -subr_ge0 le0r=>/orP; case. + by rewrite subr_eq0 /conv/= =>/eqP <-; rewrite onem1 scale0r addr0 scale1r. +move=> t1; apply Aconv; exists ((Prob.p t : R) *: x); + [| exists ((onem t) *: y) ]=>//; apply Acone. + by exists (PosNum t0) =>//; exists x. +by exists (PosNum t1)=>//; exists y. +Qed. + +(* Note: cone0_of A is NOT pointed due to lemma cone0_of_convE. *) +(* TODO: maybe change the 0 <= k i to 0 < k i in the definition of conv. *) + +Definition cone0_of (A: set E) : set E := + [set a | exists n (s : 'I_n.+1 -> E) (k: 'I_n.+1 -> {posnum R}), + \sum_i (k i)%:num *: (s i) = a /\ (range s `<=` A)%classic]. + +Lemma cone0_of_cone0 (A: set E): cone0 (cone0_of A). +Proof. +move=>x [t /= _] [a [n [s [k [<- sA]]]]] <-. +rewrite scaler_sumr; exists n, s, (fun i => (t%:num * (k i)%:num)%:pos); split => //. +by apply congr_big=>// i _; apply /esym; apply scalerA. +Qed. + +Lemma cone0_of_hullE (A : set E) : + cone0_of A = [set t%:num *: a | t in (@setT {posnum R}) & a in (hull A)]%classic. +Proof. +rewrite eqEsubset; split=>x. + move=>[n [s [k [<- kA]]]]; set t := \sum_i (k i)%:num. + have k0' (i : 'I_n.+1) : true -> 0 <= (k i)%:num by move=> _; apply/ltW. + have: 0 <= t by apply sumr_ge0. + rewrite le0r=>/orP; case. + move=>/eqP /psumr_eq0P; move=> /(_ k0') /(_ ord0 Logic.eq_refl) /eqP. + by rewrite gt_eqF. + move=>t0. + have tk0 i : (Rdefinitions.IZR BinNums.Z0 <= [ffun i => t^-1 * (k i)%:num] i). + by rewrite ffunE; apply/mulr_ge0; [ apply ltW; rewrite invr_gt0 | apply k0' ]. + have tk1 : \sum_(i < n.+1) [ffun i => t^-1 * (k i)%:num] i = 1. + transitivity (\sum_(i < n.+1) t^-1 * (k i)%:num). + by apply congr_big=>// i _; rewrite ffunE. + rewrite -mulr_sumr mulrC divff//. + by move:t0; rewrite lt0r=>/andP[]. + move:(t0)=> t0'; exists (PosNum t0')=>//; exists (t^-1 *: \sum_i (k i)%:num *: s i). + exists n.+1, s, (@FDist.make _ _ (finfun (fun i=> t^-1 * (k i)%:num)) tk0 tk1); split=> //. + rewrite scaler_sumr avgnrE. + apply congr_big=>// i _. + by rewrite scalerA ffunE. + by rewrite scalerA divff ?gt_eqF// scale1r. +move=>[t /= _] [a [n [s [d [sA ->]]]]] <-. +rewrite avgnrE scaler_sumr. +rewrite (@bigID_idem _ _ _ _ _ _ (fun i=> 0 < d i))/=; [| exact: addr0]. +have ->: \sum_(i | true && ~~ (0 < d i)) t%:num *: (d i *: s i) = \sum_(i | true && ~~ (0 < d i)) 0 *: 0. + apply congr_big=>// i /andP [_]; rewrite lt0r negb_and negbK. + move:(FDist.ge0 d i)=>->; rewrite orbF=>/eqP->. + by rewrite 2!scale0r GRing.scaler0. +rewrite -[\sum_(_ < _ | _) 0 *: 0]scaler_sumr scale0r addr0 -big_filter /=. +remember [seq i <- index_enum 'I_n | 0 < d i] as I; move: HeqI=>/esym HeqI. +case: I HeqI=> [| i I] HeqI. + exfalso; move: (FDist.f1 d) (oner_neq0 R); rewrite (@bigID_idem _ _ _ _ _ _ (fun i=> 0 < d i))/=; [|apply addr0 ]. + rewrite -big_filter HeqI big_nil/=. + rewrite add0r=><- /eqP; apply. + transitivity (\sum_(i < n | true && ~~ (0 < d i)) (0*0:R)). + 2: by rewrite -mulr_sumr mul0r. + apply congr_big=>// i /= dile; move: (FDist.ge0 d i); rewrite le0r. + rewrite (negbTE dile) orbF => /eqP ->. + by rewrite mul0r. +have: subseq (i::I) (index_enum 'I_n) by rewrite -HeqI; apply filter_subseq. +case: n s d sA i I HeqI=> [| n] s d sA i I HeqI. + by inversion i. +move=> /subseq_incl; move=> /(_ ord0); rewrite size_index_enum card_ord; move=> [f [fn flt]]. +rewrite /cone0_of/=. +exists (size I), (s \o (nth ord0 (i :: I))). +simple refine (ex_intro _ _ _). + move=> j. + apply: (fun x : {posnum R} => (t%:num * x%:num)%:pos). + simple refine (PosNum _). + exact (d (nth ord0 (i :: I) j)). + rewrite -HeqI. + apply/(@nth_filter _ (fun i=> 0 < d i)). + by rewrite HeqI. +split. + rewrite [in RHS]HeqI. + rewrite -[in RHS](mask_true (s:=i :: I) (leqnn (size I).+1)) big_mask. + apply congr_big=>// j. + by rewrite nth_nseq; case:j=>/= j ->. + move=>_ /=. + by rewrite scalerA (tnth_nth ord0)/=. +move=>+/= [j] _ <- =>_. +by apply sA; eexists. +Qed. + +Lemma cone0_of_sub_cone0_convex (A: set E) (B: {convex_set E}) : + (A `<=` B -> cone0 B -> cone0_of A `<=` B)%classic. +Proof. +rewrite cone0_of_hullE=>AB Bcone x [t t0 [a aA <-]]. +apply Bcone; exists t=>//; exists a=>//. +by apply (hull_sub_convex AB). +Qed. + +End cone. + + +Section Fun. +Variable E : convType R. +Variable f : E -> \bar R. + +Local Open Scope fun_scope. +Local Open Scope ring_scope. +Local Open Scope ereal_scope. +Local Open Scope convex_scope. + +Definition fconvex := forall (x y: E) (t: {prob R}), + f (x <|t|> y) <= EFin (Prob.p t : R) * f x + EFin (onem t)%R * f y. + +Definition fconvex_strict := forall (x y: E) (t: oprob R), x <> y -> + f (x <|t|> y) < EFin (Prob.p t : R) * f x + EFin (onem t)%R * f y. + +Lemma fconvex_max_ext (C: {convex_set E}) (x: E): + fconvex_strict -> + x \in C -> + f x < +oo -> + (forall y, y \in C -> f y <= f x) -> + x \in ext C. +Proof. +move=> fconv xC fxoo xmax. +rewrite in_setE/ext/= =>u v /xmax uC /xmax vC /set_mem [t] _ xE; subst x. +move: (prob_ge0 t); rewrite le0r=>/orP; case. + by move=>/eqP/val_inj ->; right; rewrite conv0. +move=>t0. +move: (prob_le1 t); rewrite -subr_ge0 le0r=>/orP; case. + rewrite subr_eq0=>/eqP t1. + rewrite (_ : t = 1%:pr)//; last first. + by apply/val_inj. + by left; rewrite conv1. +rewrite subr_gt0=>t1. +have t01: (Rdefinitions.IZR BinNums.Z0 < Prob.p t)%R && + (Prob.p t < Rdefinitions.IZR (BinNums.Zpos 1%AC))%R. + by apply/andP; split. +have [->|/eqP uv] := eqVneq u v; first by rewrite convmm; left. +move:(fconv u v (OProb.mk t01) uv)=>/=. +have fle: (Prob.p t)%:E * f u + (onem (Prob.p t))%:E * f v <= f (u <|t|> v). + have ->: f (u <|t|> v) = (Prob.p t)%:E * f (u <|t|> v) + (onem (Prob.p t))%:E * f (u <|t|> v). + rewrite -ge0_muleDl ?lee_fin /onem ?RminusE -?EFinD. + - by rewrite addrCA subrr addr0 mul1e. + - by apply ltW. + - by rewrite subr_ge0; apply/prob_le1. + apply: leeD; rewrite (@lee_pmul2l R)//= lte_fin. + by rewrite subr_gt0. +by move=>/(Order.POrderTheory.le_lt_trans fle); rewrite ltxx. +Qed. + +End Fun. diff --git a/theories/counterclockwise.v b/theories/counterclockwise.v new file mode 100644 index 0000000..461feb6 --- /dev/null +++ b/theories/counterclockwise.v @@ -0,0 +1,380 @@ +Require Export axiomsKnuth. +From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals. +From mathcomp Require Import normedtype order lra. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(******************************************************************************) +(* | 1 p_x p_y | *) +(* det p q r == | 1 q_x q_y | *) +(* | 1 r_x r_y | *) +(* ccw p q r := counterclockwise *) +(* wccw p q r := counterclockwise or aligned (0 <= det p q r) *) +(******************************************************************************) + +From mathcomp.algebra_tactics Require Import ring. +From mathcomp.zify Require Import zify. + +Import GRing Num.Theory Order.POrderTheory Order.TotalTheory. + +Local Open Scope order_scope. +Local Open Scope ring_scope. + +Section Plane. +Variable R : realType. +Definition Plane : vectType _ := (R^o * R^o)%type. + +(* ------------------ Definitions ------------------- *) + +Definition xcoord (p : Plane) : R := p.1. +Definition ycoord (p : Plane) : R := p.2. + +Definition get_coord (i : 'I_3) := + match val i with + | 0 => xcoord + | 1 => ycoord + | _ => fun=> 1 + end. + +Definition get_pt (p q r : Plane) := fun j : 'I_3 => nth 0 [:: p; q; r] j. + +Let det_mx (p q r : Plane) := + \matrix_(i < 3, j < 3) get_coord i (get_pt p q r j). + +Definition det (p q r : Plane) : R := \det (det_mx p q r). + +Definition ccw (p q r : Plane) : bool := 0 < det p q r. + +Definition wccw (p q r : Plane) := (0 <= det p q r)%R. + +Lemma direct_distincts (p q r : Plane) : ccw p q r -> p <> q. +Proof. +move=> pqr pq; subst q; move: pqr; rewrite /ccw /det. +have n: (ord0: 'I_3) != lift ord0 ord0 by apply/eqP=>e; inversion e. +rewrite -det_tr (determinant_alternate n). + by rewrite ltxx. +by move=>i; rewrite !mxE. +Qed. + +Lemma det2 (R': comRingType) (M: 'M_2): (\det M: R') = + M ord0 ord0 * M (lift ord0 ord0) (lift ord0 ord0) - + M ord0 (lift ord0 ord0) * M (lift ord0 ord0) ord0. +Proof. +rewrite (expand_det_row M ord0) !big_ord_recl big_ord0 /cofactor !det_mx11. +rewrite !mxE/= /bump /= !(addn0,expr0,mul1r,add0n,addr0,expr1,mulN1r,mulrN)/=. +congr (_ - (_ * M _ _)). +exact: val_inj. +Qed. + +Lemma develop_det (p q r: Plane): det p q r = + xcoord r * (ycoord p - ycoord q) - + ycoord r * (xcoord p - xcoord q) + + xcoord p * ycoord q - ycoord p * xcoord q. +Proof. +rewrite /det (expand_det_col (det_mx p q r) (lift ord0 (lift ord0 (@ord0 0)))). +rewrite !big_ord_recl big_ord0 !mxE/= -!addrA; congr (_ * _ + _). + by rewrite /cofactor !det2 !mxE /get_coord/get_pt /=; ring. +by rewrite -mulrN; congr (_ * _ + _); + rewrite /cofactor !det2 !mxE /get_coord/get_pt /=; ring. +Qed. + +(* ---------------- produit scalaire (avec le deuxième argument tourné de pi/2) ----------------- *) +Definition scalar_product (p q: Plane) := p.1 * q.1 + p.2 * q.2. + +Definition rotate (p : Plane) := (p.2, -p.1). + +Definition swap (p : Plane) := (p.2, p.1). + +Lemma det_scalar_productE (p q r: Plane): + det p q r = scalar_product (q-p) (rotate (r-p)). +Proof. +rewrite develop_det /scalar_product /=. +rewrite /xcoord /ycoord /=. +ring. +Qed. + +Lemma scalar_productC (p q: Plane): scalar_product p q = scalar_product q p. +Proof. by rewrite /scalar_product /= [p.1*_]mulrC [p.2*_]mulrC. Qed. + +Lemma scalar_productZL (q r: Plane) (t: R): + scalar_product (t *: q) r = t * scalar_product q r. +Proof. by rewrite /scalar_product /= -!mulrA -mulrDr. Qed. + +Lemma scalar_productZR (q r: Plane) (t: R): + scalar_product q (t *: r) = t * scalar_product q r. +Proof. by rewrite scalar_productC scalar_productZL scalar_productC. Qed. + +Lemma scalar_productDl (p q r: Plane): + scalar_product (p + q) r = scalar_product p r + scalar_product q r. +Proof. by rewrite /scalar_product /=; ring. Qed. + +Lemma scalar_productDr (p q r : Plane): + scalar_product r (p + q) = scalar_product r p + scalar_product r q. +Proof. by rewrite scalar_productC scalar_productDl; congr add; apply scalar_productC. Qed. + +Lemma scalar_productrr_ge0 p : 0 <= (scalar_product p p). +Proof. by rewrite /scalar_product; apply addr_ge0; apply sqr_ge0. Qed. + +Lemma scalar_productrr_gt0 u : u != 0 -> 0 < scalar_product u u. +Proof. +move=>u0. +rewrite lt0r; apply/andP; split; last by apply scalar_productrr_ge0. +apply/negP; rewrite /scalar_product paddr_eq0. + 2, 3: by apply sqr_ge0. +rewrite 2!sqrf_eq0=>/andP[/eqP u10 /eqP u20]. +by move: u0=>/negP; apply; rewrite -pair_eqE; apply/andP; split; apply/eqP. +Qed. + +Lemma rotateZ (p : Plane) (t : R) : rotate (t *: p) = t *: rotate p. +Proof. +rewrite /rotate; apply pair_equal_spec; split=>//=. +by rewrite scalerN. +Qed. + +Lemma rotateD (p q : Plane) : rotate (p + q) = rotate p + rotate q. +Proof. +rewrite /rotate; apply pair_equal_spec; split=>//=. +by rewrite opprD. +Qed. + +Lemma rotate_rotate (p : Plane) : rotate (rotate p) = -p. +Proof. by case p=>a b; apply pair_equal_spec; split=>//. Qed. + +Lemma rotate_antisym (p q : Plane) : + scalar_product (rotate p) q = - scalar_product p (rotate q). +Proof. by rewrite /scalar_product/rotate/=; ring. Qed. + +Lemma scalar_product_rotatexx (p : Plane) : scalar_product p (rotate p) = 0. +Proof. by rewrite /scalar_product/rotate/=; ring. Qed. + +Lemma scalar_product_rotate (p q : Plane) : + scalar_product (rotate p) (rotate q) = scalar_product p q. +Proof. by rewrite/scalar_product/rotate/=; ring. Qed. + +Lemma swapD (p q : Plane) : swap (p+q) = swap p + swap q. +Proof. by apply pair_equal_spec. Qed. + +Lemma swapZ (p : Plane) (t : R) : swap (t *: p) = t *: swap p. +Proof. by apply pair_equal_spec. Qed. + +Lemma swapN (p : Plane) : swap (- p) = - swap p. +Proof. by rewrite -mulN1r swapZ scaleN1r. Qed. + +Lemma swapB (p q : Plane) : swap (p-q) = swap p - swap q. +Proof. by rewrite swapD swapN. Qed. + +Lemma swap_swap (p : Plane) : swap (swap p) = p. +Proof. by rewrite /swap/=; apply/esym; apply surjective_pairing. Qed. + +Lemma swap_inj : injective swap. +Proof. by move=>p q /(f_equal swap); rewrite 2!swap_swap. Qed. + +Lemma swap_sym (p q : Plane) : + scalar_product (swap p) q = scalar_product p (swap q). +Proof. by rewrite/scalar_product/swap/=; ring. Qed. + +Lemma scalar_product_swap (p q : Plane) : + scalar_product (swap p) (swap q) = scalar_product p q. +Proof. by rewrite swap_sym swap_swap. Qed. + +Lemma det_swap (p q r : Plane) : det (swap p) (swap q) (swap r) = - det p q r. +Proof. by rewrite 2!develop_det/swap/= /xcoord/ycoord/=; ring. Qed. + +Lemma decompose_base (p q : Plane) : q != 0 -> + p = (scalar_product p q) / (scalar_product q q) *: q + + (scalar_product p (rotate q)) / (scalar_product q q) *: rotate q. +Proof. +move=>q0. +move: (scalar_productrr_gt0 q0)=>/lt0r_neq0 q0'. +(* Is there an injectivity lemma I could use here ? *) +move: (q0')=>/negPf q0''. +apply/eqP; rewrite -subr_eq0 -[_ == 0]/(false || _) -q0'' -scaler_eq0 scalerDr scalerN subr_eq0 /= scalerDr !scalerA !mulrA ![_ q q * _ p _]mulrC -!mulrA divff ?q0'// !mulr1 -pair_eqE /scalar_product. +apply/andP; split; apply/eqP=>/=; cbn; ring. +Qed. + +(* ------------------ calcul de determinants ------------------- *) + +Lemma decompose_det (p q r t : Plane) : + det p q r = (det t q r) + (det p t r) + (det p q t). +Proof. by rewrite !develop_det; ring. Qed. + +Lemma det_inverse (p q r : Plane) : det p q r = - (det p r q). +Proof. by rewrite !develop_det; ring. Qed. + +Lemma det_cyclique (p q r : Plane) : det p q r = det q r p. +Proof. by rewrite !develop_det; ring. Qed. + +Lemma detDl (p1 p2 p3 q1 q2 q3 r1 r2 r3 : R) : + det (p1+p2, p3) (q1+q2, q3) (r1+r2, r3) = + det (p1, p3) (q1, q3) (r1, r3) + det (p2, p3) (q2, q3) (r2, r3). +Proof. by rewrite !develop_det/=; ring. Qed. + +Lemma detDr (p1 p2 p3 q1 q2 q3 r1 r2 r3 : R) : + det (p1, p2+p3) (q1, q2+q3) (r1, r2+r3) = + det (p1, p2) (q1, q2) (r1, r2) + det (p1, p3) (q1, q3) (r1, r3). +Proof. by rewrite !develop_det/=; ring. Qed. + +Lemma detZl (p1 p2 q1 q2 r1 r2 t : R) : + det (t * p1, p2) (t * q1, q2) (t * r1, r2) = + t * det (p1, p2) (q1, q2) (r1, r2). +Proof. by rewrite !develop_det/=; ring. Qed. + +Lemma detZr (p1 p2 q1 q2 r1 r2 t : R) : + det (p1, t * p2) (q1, t * q2) (r1, t * r2) = + t * det (p1, p2) (q1, q2) (r1, r2). +Proof. by rewrite !develop_det/=; ring. Qed. + +Lemma det_alternate (p q : Plane) : det p p q = 0. +Proof. +apply/eqP; rewrite -[_ == 0]/(false || _) . +have<-: (2%:R : R) == 0 = false by rewrite pnatr_eq0. +by rewrite -mulf_eq0 mulr_natl 2!det_cyclique mulr2n {2}det_inverse subrr. +Qed. + +Lemma det0_colinear (p q r : Plane) : det p q r = 0 <-> + exists (t : Plane), t != 0 /\ scalar_product t q = scalar_product t p /\ + scalar_product t r = scalar_product t p. +Proof. +rewrite det_scalar_productE; move: p q r. +suff: forall p q : Plane, scalar_product p (rotate q) = 0 <-> (exists (t : Plane), t != 0 /\ scalar_product t p = 0 /\ scalar_product t q = 0). + move=>h p q r; move: h=> /(_ (q-p) (r-p)) ->; split. + by move=>[t [t0 ts]]; exists t; split=>//; split; apply/eqP; rewrite -subr_eq0 -mulN1r -scalar_productZR -scalar_productDr scaleN1r; apply /eqP; apply ts; rewrite !in_cons eq_refl ?orbT. + by move=>[t [t0 [qp rp]]]; exists t; split=>//; rewrite -scaleN1r 2!scalar_productDr scalar_productZR mulN1r qp rp subrr. +move=> p q; split. + 2: by move=>[t [t0 [p0 q0]]]; rewrite (decompose_base p t0) [_ p t]scalar_productC p0 mul0r scale0r add0r scalar_productZL scalar_product_rotate q0 mulr0. +move=>pq. +case p0: (p == 0). + move: p0=>/eqP p0; subst p. + case q0: (q == 0). + move: q0=>/eqP q0; subst q. + exists (1, 0); split. + by rewrite negb_and; apply/orP; left=>/=; apply: oner_neq0. + by rewrite -(scale0r (0 : Plane)) scalar_productZR mul0r. + exists (rotate q); split. + apply/eqP=>/pair_equal_spec [q2 /eqP]; rewrite oppr_eq0=>/eqP q1. + by move: q0; rewrite -pair_eqE/pair_eq q1 q2 eq_refl. + by rewrite scalar_productC [_ _ q]scalar_productC scalar_product_rotatexx. +exists (rotate p); split. + apply/eqP=>/pair_equal_spec [p2 /eqP]; rewrite oppr_eq0=>/eqP p1. + by move: p0; rewrite -pair_eqE/pair_eq p1 p2 eq_refl. +split. + by rewrite scalar_productC scalar_product_rotatexx. +by rewrite rotate_antisym pq oppr0. +Qed. + +Lemma direct_uniq p q r : ccw p q r -> uniq [:: p; q; r]. +Proof. +move=>pqr. +apply/andP; split. + 2: by rewrite in_cons 2!in_nil orbF 2!andbT; apply/eqP; apply (@direct_distincts q r p); rewrite /ccw 2!det_cyclique. +rewrite negb_or orbF; apply/andP; split. + by apply/eqP; exact (direct_distincts pqr). +by rewrite eq_sym; apply/eqP; apply (@direct_distincts r p q); rewrite /ccw det_cyclique. +Qed. + +Lemma convex_combination p q r s t : + det t q r * det t s p + + det t r p * det t s q + det t p q * det t s r = + 0. +Proof. by rewrite !develop_det; ring. Qed. + + + +(***** Misc *) +Local Open Scope order_scope. +Import Order. +Lemma subr_gtlex0 (p q : Plane) : ((0%:R : R *l R) < q-p) = ((p : R *l R) < q). +Proof. +rewrite/lt/=/ProdLexiOrder.lt; congr (_ && (_ ==> _)). +- by rewrite subr_ge0. +- by rewrite subr_le0. +- by rewrite subr_gt0. +Qed. + +End Plane. + +Module ccw_KA <: KnuthAxioms. +Section Dummy. +Variable (R : realType). +Definition Plane := Plane R. +Definition OT := ccw (R:=R). + +Theorem Axiom1 (p q r : Plane) : OT p q r -> OT q r p. +Proof. +congr (_ < _). +rewrite !develop_det; ring. +Qed. + +Theorem Axiom2 (p q r : Plane) : OT p q r -> ~ OT p r q. +Proof. +rewrite /OT /ccw lt0r=>/andP [_ pqr]. +rewrite det_inverse oppr_gt0. +by rewrite ltNge pqr. +Qed. + +Theorem Axiom4 (p q r t : Plane) : + OT t q r -> OT p t r -> OT p q t -> OT p q r. +Proof. +rewrite /OT /ccw (decompose_det p q r t)=> tqr ptr pqt. +apply addr_gt0=>//. +apply addr_gt0=>//. +Qed. + +Theorem Axiom5 t s p q r : + OT t s p -> + OT t s q -> + OT t s r -> OT t p q -> OT t q r -> OT t p r. +Proof. +rewrite /OT /ccw => tsp tsq tsr tpq tqr. +have->: det t p r = - det t r p by rewrite !develop_det; ring. +rewrite ltNge oppr_le0; apply /negP=>trp. +suff: 0 < det t q r * det t s p + det t r p * det t s q + det t p q * det t s r. + by rewrite convex_combination ltxx. +rewrite addrC. +apply ltr_wpDr; [| by apply mulr_gt0]. +by apply addr_ge0; apply mulr_ge0=>//; apply ltW. +Qed. + +Local Open Scope order_scope. +Import Order. + +Theorem Axiom5' (pivot p q r : Plane) : + (pivot : R *l R) < p -> + (pivot : R *l R) < q -> + (pivot : R *l R) < r -> + ccw pivot p q -> + ccw pivot q r -> + ccw pivot p r. +Proof. +rewrite /ccw 3!det_scalar_productE/scalar_product/= !mulrN !subr_gt0 -![(pivot : R *l R) < _]subr_gtlex0 {1 2 3}/lt/=/ProdLexiOrder.lt/= !implybE -!ltNge !le_eqVlt ![(_==_)||_]orbC -!Bool.orb_andb_distrib_r=>/orP; case=>p0. + move=>/orP; case=>q0. + move=>/orP; case=>r0. + rewrite -(ltr_pdivrMl _ _ p0) mulrA -(ltr_pdivlMr _ _ q0) [_^-1*_]mulrC -(ltr_pdivrMl _ _ q0) mulrA -(ltr_pdivlMr _ _ r0) [_^-1*_]mulrC -(ltr_pdivrMl _ _ p0) mulrA -(ltr_pdivlMr _ _ r0) [_^-1*_]mulrC=>qlt rlt; exact (lt_trans qlt rlt). + move:r0=>/andP[/eqP<- r0]. + by rewrite 2!mulr0 pmulr_rgt0// pmulr_rgt0//. + move:q0=>/andP[/eqP<- q0]/orP; case. + move=>r0 _; rewrite mul0r pmulr_rlt0// =>r0'. + by move: (lt_trans r0 r0'); rewrite ltxx. + by move=>/andP[/eqP<- _] _; rewrite mul0r mulr0 ltxx. +move:p0=>/andP[/eqP<- p0]. +rewrite 2!mul0r pmulr_rlt0// pmulr_rlt0// =>/orP; case. + by move=>q0 _ q0'; move:(lt_trans q0 q0'); rewrite ltxx. +by move=>/andP[/eqP<- q0]; rewrite ltxx. +Qed. + +End Dummy. +End ccw_KA. + +(*Lemma Axiom5bis : + forall t s p q r : Plane, + OT s t p -> + OT s t q -> + OT s t r -> OT t p q -> OT t q r -> OT t p r. +Proof. +move=> t s p q r; rewrite /OT/sensDirect -![det s t _]det_cyclique ![det _ s t]det_inverse ![det _ t s]det_cyclique !oppr_gt0=>tsp tsq tsr tpq tqr. +rewrite det_inverse oppr_gt0 -(nmulr_lgt0 _ tsq). +have ->: det t r p * det t s q = - (det t q r * det t s p + det t p q * det t s r) by rewrite !develop_det; ring. +by rewrite opprD; apply addr_gt0; rewrite oppr_gt0 nmulr_llt0. + Qed.*) diff --git a/theories/desc.v b/theories/desc.v new file mode 100644 index 0000000..30e5ffa --- /dev/null +++ b/theories/desc.v @@ -0,0 +1,1260 @@ +From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype order. +From mathcomp Require Import binomial bigop ssralg poly ssrnum ssrint rat archimedean. +From mathcomp Require Import polyrcf. +Require Import pol. + +(** Defining function over lists of rationals that find lists containing + exactly one alternation, from negative to positive values. *) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import GRing.Theory. +Import Order.Theory Num.Theory Num.Def. +Local Open Scope ring_scope. + +(** ** Sign changes *) + +Section SignChange. + +Variable R :realDomainType. +Implicit Type l: (seq R). + +Definition all_eq0 l := all (fun x => x == 0) l. +Definition all_ge0 l:= all (fun x => 0 <= x) l. +Definition all_le0 l := all (fun x => x <= 0) l. +Definition all_ss a l := all (fun x => 0 <= x * a) l. +Definition opp_seq l := [seq - z | z <- l]. + +Fixpoint alternate_1 l := + if l is a::tl then + if 0 < a then all_ge0 tl else alternate_1 tl + else false. + +Fixpoint alternate l := + if l is a::tl then + if a < 0 then alternate_1 tl else + if a == 0 then alternate tl else false + else false. + +Fixpoint schange_index_aux l i y := + if l is x::l' then + if (((y==0) && (x != 0)) || (x*y < 0)) then i :: schange_index_aux l' i.+1 x + else schange_index_aux l' i.+1 y + else [::]. + +Definition schange_index l := schange_index_aux l 0 0. + +Notation SIA := schange_index_aux. (* local short notation *) + + +(** Some helper lemmas *) + +Lemma product_neg (a b : R): a * b < 0 -> a != 0 /\ b != 0. +Proof. +move => h. +case bz: (b!=0); last by move: h; rewrite (eqP (negbFE bz)) mulr0 ltxx. +case az: (a!=0); last by move: h; rewrite (eqP (negbFE az)) mul0r ltxx. +done. +Qed. + +Lemma schange_simpl (a b x: R): b * a < 0 -> 0 <= x * b -> x * a <= 0. +Proof. +move => pa. +rewrite - (nmulr_lle0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lle0 //. +by rewrite lt0r sqr_ge0 sqrf_eq0 (proj1 (product_neg pa)). +Qed. + + +Lemma schange_simpl1 (a b x: R): b * a < 0 -> 0 < x * b -> x * a < 0. +Proof. +move => pa. +rewrite - (nmulr_llt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_llt0 //. +by rewrite lt0r sqr_ge0 sqrf_eq0 (proj1 (product_neg pa)). +Qed. + + +Lemma schange_simpl2 (a b x: R): b * a < 0 -> x * b < 0 -> 0 < x * a. +Proof. +move => pa. +rewrite - (nmulr_lgt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lgt0 //. +by rewrite lt0r sqr_ge0 sqrf_eq0 (proj1 (product_neg pa)). +Qed. + +Lemma all_rev l p: all p l = all p (rev l). +Proof. by elim:l => [// | a l hr]; rewrite rev_cons all_rcons /= hr. Qed. + +Lemma has_split p l: has p l -> + exists l1 a l2, [/\ l = l1 ++ a :: l2, p a & all (fun z => ~~(p z)) l1]. +Proof. +elim:l => // a l Hrec /=; case ha: (p a) => /=. + by move => _; exists [::], a, l; split => //. +move /Hrec => [l1 [b [l2 [-> pb pc]]]]. +by exists (a::l1),b,l2; split => //=; rewrite ha pc. +Qed. + +Lemma has_split_eq l: has (fun z => z != 0) l -> + exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l1]. +Proof. +move/has_split => [l1 [a [l2 [-> pa pb]]]]; exists l1,a,l2; split => //. +by apply /allP => x; move /(allP pb); case (x==0). +Qed. + +Lemma has_split_eq_rev l: has (fun z => z != 0) l -> + exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l2]. +Proof. +have <- : (has (fun z : R => z != 0)) (rev l) = has (fun z : R => z != 0) l. + by elim:l => [// | a l hr]; rewrite rev_cons has_rcons /= hr. +move/has_split_eq => [l1 [a [l2 [lv pa pb]]]]; exists (rev l2),a,(rev l1). +by rewrite -(cat1s a) catA cats1 -rev_cons -rev_cat -lv revK /all_eq0 -all_rev. +Qed. + +Lemma opp_seqK l :opp_seq (opp_seq l) = l. +Proof. +by rewrite/opp_seq -map_comp; apply map_id_in => a /=; rewrite opprK. +Qed. + +(** We give here a specification for alternate *) + +Lemma alternate1_p l1 x l2: + all_eq0 l1 -> x <0 -> alternate_1 l2 -> alternate (l1++x :: l2). +Proof. +elim:l1; first by move => _ xn h //=; rewrite xn. +by move => a l Hrec /= /andP [az lz] xz; rewrite az (eqP az) ltxx; apply: Hrec. +Qed. + +Lemma alternate_1P (l: seq R): + reflect (exists l1 x l2, + [/\ l = l1 ++ ( x :: l2), all_le0 l1, all_ge0 l2 & x > 0] ) + (alternate_1 l). +Proof. +apply: (iffP idP). + elim:l => [// | a l Hrec /=]; case: (ler0P a) => sa. + move => /Hrec [l1 [x [l2 [-> l1n l2p xp]]]]. + by exists (a::l1), x, l2 => /=;rewrite sa. + by move => h1; exists [::], a, l. +move=> [l1 [x [l2 [-> l1n l2p xp]]]]. +move: l1 l1n; elim; first by move => _ /=; rewrite xp. +by move => a l1' Hrec /= /andP [] ap / Hrec aux;rewrite ltNge ap. +Qed. + +Lemma alternate_P (l: seq R): + reflect (exists l1 x l2 y l3, + [/\ l = l1 ++ x :: l2 ++ (y :: l3), x<0, y> 0 + & [/\ all_eq0 l1, all_le0 l2& all_ge0 l3]]) + (alternate l). +Proof. +apply: (iffP idP); last first. + move => [l1 [x [l2 [y [l3 [-> xn yp [l1p l2p l3p]]]]]]]. + have h:alternate_1 (l2 ++y :: l3) by apply /alternate_1P; exists l2, y, l3. + move: l1p; elim l1; first by rewrite /= xn h. + by move => a l' hrec /= /andP [ az] /hrec ->; rewrite lt_neqAle az. +elim: l => // a l Hrec /=. +rewrite lt_neqAle; case az: (a==0). + rewrite andFb => /Hrec [l1 [x [l2 [y [l3 [-> xn yn [l1n l2z l3p]]]]]]]. + exists (a :: l1), x, l2, y,l3; split => //; split => //. + apply /allP => t; rewrite in_cons; case /orP; last by move/(allP l1n). + move /eqP;move/eqP: az => -> -> //. +case ane:(a <= 0) => //= /alternate_1P [l1 [x [l2 [-> l1n l2p xp]]]]. +by exists [::], a, l1, x,l2; rewrite lt_neqAle az ane. +Qed. + +Lemma schangei_Sn l n a: SIA l n.+1 a = [seq z.+1 | z <- SIA l n a]. +Proof. +move: n a; elim: l => [ n z // | a l hrec n y /=]. +by case hyp: ((y == 0) && (a != 0) || (a * y < 0))=> //=; rewrite hrec. +Qed. + +Lemma schangei_addm l n m a: + SIA l (n+m)%N a = [seq (z+m)%N | z <- SIA l n a]. +Proof. +move: n a; elim: l => [ n z // | a l hrec n y /=]. +by case hyp: ((y == 0) && (a != 0) || (a * y < 0))=> //=; rewrite - addSn hrec. +Qed. + +Lemma schangei_opp l: schange_index l = schange_index (opp_seq l). +Proof. +rewrite /schange_index - {2}oppr0; move: 0 0%N; elim: l; first by done. +by move => a l hrec y n /=; rewrite mulrNN - hrec - hrec ! oppr_eq0. +Qed. + +Lemma schangei_s0 l1 l2: all_eq0 l1 -> + schange_index (l1 ++ l2) = SIA l2 (size l1) 0. +Proof. +elim l1 => // a l hrec /= /andP [/eqP -> /hrec]. +by rewrite /schange_index /= mul0r eqxx ltxx andbF orbF !schangei_Sn => ->. +Qed. + +Lemma schangei0 l: all_eq0 l <-> schange_index l = [::]. +Proof. +split; first by move /schangei_s0 => h; move: (h [::]); rewrite /= cats0. +suff: forall l n, SIA l n 0 = [::] -> all_eq0 l by apply. +elim => [ // | a l' hrec n]. +by rewrite /= eqxx mulr0 ltxx orbF andTb; case az: (a==0) => //= /hrec. +Qed. + +Lemma schangei_s0n l1 a l2: a !=0 -> all_eq0 l1 -> + schange_index (l1 ++a :: l2) = size l1 :: (SIA l2 (size l1).+1 a). +Proof. by move => anz alz; rewrite (schangei_s0 _ alz) /= eqxx anz. Qed. + +Lemma schangei_snn l i s: + schange_index l = i::s -> exists l1 a l2, + [/\ l = l1 ++a :: l2, a != 0, i = size l1, all_eq0 l1 & + SIA l2 (size l1).+1 a = s]. +Proof. +case alt: (all_eq0 l); first by move /schangei0:alt => -> //. +move: (allPn (negbT alt)) => /hasP /has_split_eq [l1 [a [l2 [ -> az al0]]]]. +rewrite (schangei_s0n _ az al0) => /eqP;rewrite eqseq_cons. +by move => /andP [/eqP <- /eqP <-];exists l1, a, l2. +Qed. + +Lemma schangei_rec a l1 l2 n: a != 0 -> all_ss a l1 -> + SIA (l1++l2) n a = SIA l2 (n + size l1)%N a. +Proof. +move => anz; move: n; elim : l1;first by move =>n /=; rewrite addn0. +move =>b l hrec n /= /andP [pa pb]. +by rewrite ltNge pa (negbTE anz) /= (hrec _ pb) addnS addSn. +Qed. + +Lemma schangei_reca a l n: a != 0 -> ((all_ss a l) = (SIA l n a == [::])). +Proof. +move => anz; move: n; elim: l => [// | b l h n]. +by rewrite /= (negbTE anz)/= (h n.+1) ltNge; case sab: (0 <= b * a). +Qed. + +Lemma schangei_recb a l1 b l2 n: b * a < 0 -> all_ss a l1 -> + SIA (l1++ b::l2) n a = (n+size l1)%N :: SIA l2 (n + size l1).+1 b. +Proof. +move => h1 h2; move : (product_neg h1) => [bz az]. +by rewrite (schangei_rec _ _ az h2) /= bz h1 orbT. +Qed. + +Lemma schangei_recc a l i s n: a!= 0 -> + SIA l n a = i :: s -> exists l1 b l2, + [/\ l = l1 ++ b :: l2, b *a <0, b!= 0, (all_ss a l1) & + (i = n+size l1)%N /\ SIA l2 (n + size l1).+1 b = s]. +Proof. +move => anz;case alz: (all_ss a l). + by move: alz; rewrite (schangei_reca _ n anz) => /eqP ->. +move: (negbT alz); rewrite - (has_predC) => /has_split [l1 [b [l2 [-> pb pc]]]]. +move: pb => /=; rewrite - ltNge => abn. +case bz: (b!=0); last by move: abn; rewrite (eqP (negbFE bz)) mul0r ltxx. +have pc': all_ss a l1 by apply /allP => t /(allP pc) /= /negbNE. +rewrite (schangei_recb l2 n abn pc') => /eqP h. +by exists l1,b, l2; move: h; rewrite eqseq_cons => /andP [/eqP <- /eqP ->]. +Qed. + +Definition schange l := (size (schange_index l)).-1. + +Lemma schange_index_alternate l: (schange l = 1%N) <-> + (alternate l \/ alternate (opp_seq l)). +Proof. +have aux0 : (schange l = 1%N) <-> size (schange_index l) = 2%N. + rewrite /schange; split; last by move => ->. + by case (size (schange_index l)) => // n /= ->. +apply:(iff_trans aux0). +have aux: forall l, alternate l -> size (schange_index l) = 2%N. + move => l0 /alternate_P [l1 [x [l2 [y [l3 [-> xn yp [l1p l2p l3p]]]]]]]. + move: (xn); rewrite lt_neqAle => /andP [xnz _]. + move: (yp); rewrite lt0r => /andP [ynz _]. + have yxn: y * x < 0 by rewrite pmulr_rlt0. + have l2p': all_ss x l2 by apply /allP => z/(allP l2p); rewrite nmulr_lge0. + have l3p': all_ss y l3 by apply /allP => z/(allP l3p); rewrite pmulr_lge0. + move: l3p'; rewrite (schangei_reca l3 ((size l1).+1 + size l2).+1 ynz). + by rewrite (schangei_s0n _ xnz l1p) (schangei_recb _ _ yxn l2p') => /eqP->. +have p1a: forall a l, a <0 -> all_ss a l -> all_le0 l. + by move => a l1 anz h; apply /allP => x /(allP h); rewrite nmulr_lge0. +have p1b: forall b l, 0 all_ss b l -> all_ge0 l. + by move => a l1 anz h; apply /allP => x /(allP h); rewrite pmulr_lge0. +have px: forall a l, a !=0 -> all_ss a l -> all_ss (-a) (opp_seq l). + move => a l1 anz h; apply /allP => x /mapP [y /(allP h) h1 ->]. + by rewrite mulrNN. +split; last first. + by case; move /aux => //; rewrite - schangei_opp. +move=> h. +have [i [j]]: exists a b, (schange_index l) = [:: a; b]. + move: h; set s := (schange_index l); case: s => // a; case => // b. + by case => // _; exists a, b. +move /schangei_snn => [l1 [a [l2 [lv anz iv pr1 pr2]]]]. +move: (schangei_recc anz pr2); move =>[l3 [b [l4 [l2v ban bz l3p [jv]]]]]. +move /eqP; rewrite - (schangei_reca _ _ bz) => l4p. +move:anz; rewrite neq_lt; case /orP => sa; [left | right];apply /alternate_P. + exists l1, a, l3, b, l4; move: ban;rewrite lv l2v (nmulr_llt0 b sa) => sb. + split => //;split; [ exact| apply: (p1a _ _ sa l3p)| apply: (p1b _ _ sb l4p)]. +exists (opp_seq l1), (-a), (opp_seq l3), (-b), (opp_seq l4); move: ban. +rewrite (pmulr_llt0 b sa) => bn. +have man: - a < 0 by rewrite oppr_lt0. +have mbp: 0 < - b by rewrite oppr_gt0. +split => //. + by rewrite lv l2v /opp_seq map_cat map_cons map_cat map_cons. +split. + by apply /allP => x /mapP [y /(allP pr1) /eqP -> ->]; rewrite oppr0 eqxx. + by apply (p1a (- a)) => //; apply px => //; move: sa; rewrite lt0r;case /andP. +by apply (p1b (- b)) => //; apply px. +Qed. + +Lemma schange_cat l1 a l2: a != 0 -> + schange (l1++a::l2) = (schange (l1++[::a]) + schange (a::l2)) %N. +Proof. +have aux: forall a b l n m, a * b >0 -> size (SIA l n a) = size (SIA l m b). + move => c1 c2 l n m cp. + rewrite -(add0n n) - (add0n m) !schangei_addm ! size_map. + elim: l => // => u v Hrec /=. + move: cp; case c1z: (c1 == 0); first by rewrite (eqP c1z) mul0r ltxx. + case c2z: (c2 == 0); first by rewrite (eqP c2z) mulr0 ltxx. + rewrite (mulrC u) (mulrC u). + move => cp; have ->: (c1 * u < 0) = (c2 * u < 0). + apply/idP/idP => h; [ rewrite mulrC in cp |];exact :(schange_simpl1 h cp). + simpl; case: (c2 * u < 0) => //. + by rewrite - (add0n 1%N) !schangei_addm ! size_map Hrec. +rewrite /schange -cat1s catA => anz. +have: has (fun z => z != 0) (l1 ++ [:: a]). + by apply /hasP; exists a => //; rewrite mem_cat mem_head orbT. +move /has_split_eq => [l3 [b [l4 [lv bnz al0]]]]. +rewrite lv (schangei_s0n l4 bnz al0) -catA cat_cons (schangei_s0n _ bnz al0). +rewrite /schange_index cat1s {3} /SIA eqxx anz /= - /SIA. +have : a = last b l4 by move: (f_equal (last a) lv); rewrite !last_cat. +move: (size l3).+1 => n; move: {2} (SIA l4 n b) (erefl (SIA l4 n b)) => s. +clear lv l1; move: n b l4 bnz. +elim: s. + move => n b l4 bnz h alb; rewrite h add0n. + have asb: all_ss b l4 by rewrite (schangei_reca _ n bnz) h eqxx. + rewrite schangei_rec //; apply: aux; rewrite lt0r (mulf_neq0 bnz anz)/=. + have: a \in b :: l4 by rewrite alb mem_last. + rewrite inE; case /orP; first by move /eqP -> ; rewrite sqr_ge0. + by move /(allP asb); rewrite mulrC. +move => i s Hrec n b l4 bnz. +move /(schangei_recc bnz) => [l1 [c [l5 [lv pa pb pc [pd pe]]]]] pf. +have pg: a = last c l5 by rewrite pf lv last_cat last_cons. +rewrite lv - catA cat_cons ! (schangei_recb _ _ pa pc) /=. +by rewrite (Hrec (n + size l1).+1 c l5 pb pe pg) addSn. +Qed. + +Lemma schange_index_tail1 s i l n a: a !=0 -> SIA l n a = rcons s i -> + exists l1 b l2, [/\ l = l1 ++ b :: l2, b !=0, i = (n + size l1)%N & + all_ss b l2 ]. +Proof. +move: l n a; elim:s. + move => l n b bnz /= h. + move: (schangei_recc bnz h)=> [l1 [c [l2 [-> pa cz pb [pc pd]]]]]. + by exists l1,c,l2; split => //; move:pd => /eqP; rewrite - schangei_reca. +move => a l Hrec l2 n b bnz;rewrite rcons_cons. +move /(schangei_recc bnz) => [l1 [c [l3 [-> pa cz pb [pc]]]]]. +move /(Hrec _ _ _ cz) => [l0 [d [l4 [-> qa -> qc]]]]. +by exists ( l1 ++ c :: l0), d,l4; rewrite -catA cat_cons addSnnS size_cat addnA. +Qed. + +Lemma schange_index_tail2 s i l: schange_index l = rcons s i -> + exists l1 (a : R) l2, + [/\ l = l1 ++ a :: l2, a != 0, i = size l1 & all_ss a l2]. +Proof. +case: s. + move /schangei_snn => [l1 [a [l2 [ -> pb pc pd pe]]]]; exists l1, a, l2. + by split => //; move: pe => /eqP; rewrite -schangei_reca. +move => j s; move /schangei_snn => [l1 [a [l2 [-> pb pc _]]]]. +move /(schange_index_tail1 pb) => [l0 [b [l3 [-> qb -> qd]]]]. +exists (l1++a::l0),b,l3; rewrite - catA cat_cons addSnnS size_cat //=. +Qed. + + +Lemma schange_index_tail l i s : + schange_index l = rcons s i -> exists l1 a l2, + [/\ l = l1 ++ a :: l2, (i <= size l1)%N, 0 < a * l`_i & all_eq0 l2]. +Proof. +move => /schange_index_tail2 [l1 [a [l2 [-> pa pb pc]]]]. +have:has (fun z => z != 0) (a::l2) by rewrite /= pa. +move /has_split_eq_rev => [la [b [lb [qa qb qc]]]]. +exists (l1 ++ la),b, lb. + rewrite pb size_cat leq_addr nth_cat ltnn subnn /= qa catA; split => //. +rewrite lt0r (mulf_neq0 qb pa) /=. +have: b \in a :: l2 by rewrite qa mem_cat mem_head orbT. +rewrite in_cons =>/orP []; first by move /eqP => ->; rewrite sqr_ge0. +by move /(allP pc). +Qed. + +Lemma schange_odd1 x l y: x * y < 0 -> odd (schange (x::l ++ [::y])). +Proof. +move => xy; rewrite /schange. +move: (product_neg xy) => [xnz ynz]. +set s := schange_index (x :: l ++ [:: y]). +move: (refl_equal s); rewrite {1} /s; case: s. + have xl: x \in x :: l ++ [:: y] by rewrite mem_head. + by move /schangei0 => h; move: xnz; move/(allP h):xl => /eqP ->; rewrite eqxx. +move => i s /=. +rewrite /schange_index /= eqxx xnz orTb => /eqP; rewrite eqseq_cons => /andP. +move => [ _] /eqP. +have ->: (size s)= (((x * y>=0)%R) + size s)%N by rewrite leNgt xy. +clear i xy;move: x xnz 1%N l; elim: s. + move => x xnz n l => /eqP; rewrite -(schangei_reca _ _ xnz) => ss. + have: y \in (l ++ [:: y]) by rewrite mem_cat inE eqxx orbT. + by move /(allP ss); rewrite mulrC => ->. +move => a s Hrec x xnz n l. +move/(schangei_recc xnz)=> [l1 [c [l2 [lv pa cnz pb [pc]]]]]. +have cp:0 < c * c by rewrite lt0r sqr_ge0 sqrf_eq0 (proj1 (product_neg pa)). +have ->: (0 <= x * y) = ~~(0 <= c * y). + rewrite - (nmulr_rle0 (c * y) pa) mulrACA (pmulr_rle0 _ cp). + by rewrite - ltNge lt_neqAle eq_sym (mulf_neq0 xnz ynz). +move: (f_equal (last c) lv); rewrite !last_cat !last_cons /= addnS. +case l2; first by move => ->; rewrite (ltW cp) /= => <-. +move => i1 l4; rewrite last_cons (lastI i1 l4) - cats1 => <-. +move /(Hrec c cnz (n + size l1).+1 _). +by case b:((0 <= c * y)%R) => //= ->. +Qed. + +Lemma schange_index_correct l (i: nat): + i \in (schange_index l) -> (l`_i != 0 /\ l`_i * (0::l)`_i <= 0). +Proof. +move: {2 3} (schange_index l) (refl_equal (schange_index l)); case => //. +have aux: forall i l n a, + i \in SIA l n a -> exists2 j:nat, j \in SIA l 0 a & i = (j + n)%N. + by move => i' l' n a; rewrite -(add0n n) schangei_addm; move /mapP. +move => k s /schangei_snn [l1 [a [l2 [-> anz il1 l1z sv]]]]. +rewrite inE; case/ orP. + move /eqP ->; rewrite !nth_cat il1 ltnn subnn /=; split => //. + rewrite -cat_cons nth_cat /= ltnS leqnn -last_nth. + suff : (last 0 l1 == 0) by move => /eqP ->; rewrite mulr0. + by move: (mem_last 0 l1); rewrite inE => /orP; case => //; move /(allP l1z). +rewrite - sv => isv. +move : (aux i l2 (size l1).+1 a isv) => [j j2 j1]. +rewrite j1 addnC nth_cat - cat_cons nth_cat addSn - addnS ltnNge leq_addr /=. +rewrite addnC addnK /= addSn ltnNge ltnS leq_addl /= -addnS addnK. +move: j2; clear il1 l1z isv j1 sv k s l1 l i. +move: {1} 0%N {1} (SIA l2 0 a) (refl_equal (SIA l2 0 a)) => n s. +move:s l2 a n j anz; elim. + by move => l2 a n j _; rewrite -(add0n n) schangei_addm; case (SIA l2 0 a). +move => a s Hrec l b n j bnz => eq1;symmetry in eq1. +move: (schangei_recc bnz eq1)=> [l1 [c [l3 [pa pb cz pc [pd pe]]]]] => js. +have: (j + n)%N \in SIA l n b. + by rewrite-{2} (add0n n) schangei_addm; apply /mapP; exists j. +rewrite eq1 in_cons => /orP []. + rewrite pd addnC eqn_add2l => /eqP ->. + rewrite pa - cat_cons nth_cat ltnn subnn; split => //. + rewrite /= - (cat_cons) nth_cat /= ltnS leqnn -last_nth. + move: (mem_last b l1)=> /orP;case; first by move/eqP => ->;apply: ltW. + by rewrite mulrC; move/(allP pc); apply schange_simpl; rewrite mulrC. +rewrite - pe - addnS (addnC n) schangei_addm; move /mapP. +move => [j0 ka] /eqP; rewrite eqn_add2r => /eqP => ->. +move: ka; rewrite -(add0n (size l1).+1) schangei_addm => /mapP [k jv ->]. +symmetry in pe; move: (Hrec l3 c (n + size l1).+1 k cz pe jv). +rewrite pa - cat_cons ! nth_cat - addSnnS leqNgt ltnS leq_addl /=. +by rewrite addnK /= addSnnS leqNgt ltnS leq_addl /= addnK. +Qed. + +Lemma schange_monotone l l' (s:= schange_index l): + (forall k, k \in s ->l`_k * l'`_k <0) -> + l`_ (last 0%N s) * l'`_(size l) > 0 -> + (schange l < schange l') %N. +Proof. +have: schange_index l = s by []. +case: s. + move/schangei0 => alz _; rewrite /last. + suff: l`_0 = 0 by move => ->; rewrite mul0r ltxx. + by move: alz; case l => // a l1 /= /andP [/eqP ->]. +have rec0: forall l1 l2, l2`_0 != 0 -> (schange (l2) <= schange (l1++l2))%N. + by move => l1; case => // a l2 /= anz; rewrite (schange_cat _ _ anz) leq_addl. +have rec1: forall l i j, l`_i * l`_j < 0 -> (0 < (schange l))%N. + move => l1 i j; wlog : i j / (i<= j)%N. + by case /orP:(leq_total i j)=> cij h; [ | rewrite mulrC]; apply:h. + move => lij ov. + move: (product_neg ov) => [anz bnz]. + have st: size (take i l1) = i. + rewrite size_take; case (ltnP i (size l1)) => // sl. + by move: anz; rewrite (nth_default 0 sl) eqxx. + move: (cat_take_drop i l1) => eq1. + have e2: l1`_i = (drop i l1)`_0 by rewrite - {1} eq1 nth_cat st ltnn subnn. + have e3: (drop i l1)`_0 != 0 by rewrite - e2. + have e4: l1`_j = (drop i l1)`_(j-i) by rewrite -{1}eq1 nth_cat st ltnNge lij. + move:ov; rewrite e2 e4; set l3 := (drop i l1); set k:= (j - i)%N => ov. + move: (rec0 (take i l1) l3 e3); rewrite eq1; apply: leq_trans. + have st': size (take k l3) = k. + rewrite size_take; case (ltnP k (size l3)) => // sl. + by move: bnz; rewrite e4 (nth_default 0 sl) eqxx. + move: (cat_take_drop k l3) => eq2. + have l3k: l3`_k = (drop k l3)`_0 by rewrite - {1} eq2 nth_cat st' ltnn subnn. + have l3knz: l3`_k != 0 by rewrite /l3 /k - e4. + have [v eq6]: exists v, (drop k l3) = l3`_k:: v. + move:l3knz; rewrite l3k ;case (drop k l3); last by move => a b _; exists b. + by rewrite eqxx. + have [u eq7]: exists u, (take k l3) = l3`_0:: u. + move: st'; rewrite -{3} eq2; case (take k l3). + by move => /= kz; move: ov; rewrite -kz ltNge sqr_ge0. + by move => a b _; exists b. + rewrite -eq2 eq6 schange_cat // eq7 cat_cons. + by move: (schange_odd1 u ov); set w :=schange _; case w. +have ncat: forall l1 l2 b, (l1++l2)`_( (size l1) +b) = l2`_b. + by move=> l1 l2 b; rewrite nth_cat addKn -ltn_subRL subnn. +move => i s sil ha hb. +rewrite {1} /schange sil /=; move: sil ha hb. +move /schangei_snn => [l1 [a [l2 [->pa pb pc pd]]]] ha hb. +have he: (l1 ++ a :: l2)`_i = a by rewrite nth_cat pb ltnn subnn. +have skm: forall k, (l1 ++ a :: l2)`_(k + i) = (a::l2)`_k. + by move => k; rewrite addnC pb ncat. +have hc: a * l'`_i < 0 by rewrite -he;apply: ha; rewrite mem_head. +have[l2a [l2b [l2v sl]]]: exists l2a l2b, l2a ++ l2b = l' /\ size l2a = i. + exists (take i l'), (drop i l'); split; first by exact: cat_take_drop. + apply: size_takel; case /orP:(leq_total i (size l')) => //. + by move/(nth_default 0) => h; move: hc; rewrite h mulr0 ltxx. +move: (hc); rewrite -l2v nth_cat -sl ltnn subnn => hc'. +apply: (leq_trans _ (rec0 l2a l2b (proj2 (product_neg hc')))). +have sv: [seq (z + i)%N | z <- SIA l2 1 a] = s by rewrite pb -pd -schangei_addm. +have: forall k, k \in (SIA l2 1 a) -> (a::l2)`_(k-0)%N * l2b`_(k-0%N) < 0. + move => k ka; rewrite - skm subn0. + have ->: l2b`_k = l'`_(k+i) by rewrite -l2v - sl addnC ncat. + by apply: ha;rewrite inE - sv (mem_map (@addIn i)) ka orbT. +have: 0 < (a :: l2)`_((last 0%N (SIA l2 1 a)) -0) * l2b`_(size l2).+1. + move: hb; rewrite -sv /= (last_map (fun z=> (z + i)%N) (SIA l2 1 a) 0%N). + by rewrite subn0 skm - l2v size_cat -pb - sl ncat. +rewrite - sv size_map. +clear he sv skm pb pc pd ha sl s hb l2v hc l2a he l1 l l' i. +move: {2 3 4 5} (SIA l2 1 a) pa (erefl (SIA l2 1 a)) hc'. +rewrite - (addn0 1%N); move: {2 4 5 6 7} 0%N. +move => n s; move: s a n l2 l2b; elim. + move => a n l l' _ anz pnz;set j := (size l).+1 %N. + rewrite /last subnn {1}/nth mulrC ; move => lt2 _. + move:(schange_simpl1 pnz lt2);apply: rec1. +move => i s Hrec a n l l' anz. +move /(schangei_recc anz)=> [l1 [b [l2 [-> pa pb pc [pd pe]]]]]. +move => qa qb qc /=. +have imn: (i - n = (size l1).+1) %N by rewrite pd addnAC add1n addnK. +have: (i\in i :: s) by rewrite mem_head. +move /qc; rewrite imn -cat1s catA nth_cat subnn ltnn - imn => e1. +set ni := (i - n )%N. +move: (cat_take_drop ni l'). +set l1' := take ni l'; set l2' := drop ni l' => e2. +have e3: size l1' = ni. + move: e1;rewrite size_take; case (leqP (size l') ni) => //. + by move/(nth_default 0) => ->; rewrite mulr0 ltxx. +move: (schange_simpl2 qa pa); rewrite mulrC => e4. +move: (schange_simpl1 e1 e4) => e5. +move: (proj2 (product_neg e5)); set w := l'`_ni => wnz. +have [u l2v]: exists u, l2' = w::u. + move: wnz;rewrite /w - e2 nth_cat e3 ltnn subnn. + case l2'; [ by rewrite eqxx | by move => a1 b1 _; exists b1]. +move: (schange_cat l1' u wnz); rewrite - l2v e2 => ->. +suff: ((size s) < schange l2')%N. + set l1'' := (l1' ++ [:: w]). + have : l1''`_0 * l1''`_ni < 0. + move: e5; rewrite -e2 l2v /l1'' !nth_cat e3 ltnn subnn; case i => //. + by move/rec1 => e6 e7; move: (leq_add e6 e7); rewrite add1n. +clear u l2v. +have r0: b * l2'`_0 < 0 by move: e1; rewrite - e2 nth_cat e3 ltnn subnn. +move: pe; rewrite -pd - add1n => r1. +have r2 : (forall k, + k \in s -> (b :: l2)`_(k - i) * l2'`_(k - i) < 0). + move => k ks; have: k \in i::s by rewrite inE ks orbT. + move: ks; rewrite -{1} r1 schangei_addm; move /mapP => [k' k'v kv]. + have ->: (k - i)%N = k' by rewrite kv addnK. + move/ qc; rewrite - e2 - cat1s catA. + have ->: (k - n = k' + (size l1).+1)%N. + by rewrite kv pd addnAC add1n addnA addnK. + by rewrite addnC ncat -imn -/ni -e3 ncat. +have r3: 0 < (b :: l2)`_(last i s - i) * l2'`_(size l2).+1. + move:qb; rewrite - e2 size_cat - addSn - imn -/ni -e3 ncat. + suff: ((last n (i :: s) - n) = ni + (last i s - i)) %N. + by move => ->; rewrite /ni imn - cat1s catA ncat. + have lni: (n<=i) %N by rewrite pd addnAC leq_addl. + rewrite -r1 schangei_addm; case (SIA l2 1 b); first by rewrite /= subnn addn0. + move => n0 l0 /=; set la := last _ _. + have eq1: (i <= la)%N. + by rewrite /la (last_map (fun z=> (z + i)%N)) leq_addl. + by rewrite - {1} (subnK eq1) - (addnBA _ lni) addnC. +exact: (Hrec b i l2 l2' pb r1 r0 r3 r2). +Qed. + +Lemma pol_mul_cs (p: {poly R}) (x: R): + p !=0 -> x > 0 -> ( (schange p) < (schange (p * ('X - x%:P))%R))%N. +Proof. +move => pnz xn. +set q := _ * _. +have spp: size p = (size p).-1.+1. + by move: pnz; rewrite -size_poly_eq0; case sz:(size p). +have lcpnz: lead_coef p != 0 by rewrite lead_coef_eq0. +set s := (schange_index p). +suff: (forall k, k \in s -> p`_k * q`_k < 0) /\ + 0 < p`_(last 0%N s) * q`_(size p). + by move => [pa pb];apply: schange_monotone. +have -> : q`_(size p) = lead_coef p. + move: (monicXsubC x) => mc; rewrite- (lead_coef_Mmonic p mc) lead_coefE. + by rewrite (size_Mmonic pnz mc) size_XsubC addn2. +have lpp: lead_coef p \in polyseq p by apply: mem_nth; rewrite {2} spp. +have [heads [lasts sv]]: exists a b, s = rcons a b. + move: (eq_refl s); rewrite {1}/s; case s. + by move /eqP /schangei0 => ap; move:lcpnz; move /(allP ap): lpp => ->. + by move => n l _; rewrite lastI; exists (belast n l), (last n l). +move:(schange_index_tail sv) => [l1 [a [l2 [pv sl1 pn alz]]]]. +have ->: last 0%N s = lasts by rewrite sv last_rcons. +have: lead_coef p = last 0 p by rewrite (last_nth 0) spp. +rewrite {1 3} pv last_cat last_cons; move: alz. +case l2; last first. + move => b l az /= lpv; move: lcpnz. + have: lead_coef p \in (b :: l) by rewrite lpv mem_last. + by move /(allP az) => ->. +move => _ /= ->; split; last first. + move: pn; rewrite pv - cat1s catA mulrC (nth_cat 0 (l1 ++ [:: a])). + by rewrite size_cat addn1 ltnS sl1. +clear heads lasts sl1 a l2 pv sl1 pn sv. +move => k ks. +move: (schange_index_correct ks) => [eq1 eq2]. +have rhsp: 0 < p`_k * (p`_k * x). + by rewrite mulrA (pmulr_lgt0 _ xn) lt0r sqr_ge0 sqrf_eq0 eq1. +rewrite /q mulrBr coefB coefMC mulrBr subr_lt0 coefMX (le_lt_trans _ rhsp) //. +by move: eq2; case k. +Qed. + +End SignChange. + +Section DescOnOrderedRing. +Variable R :realDomainType. + +(** The definitions *) + +Definition pol_increasing (p : {poly R}) := {homo (horner p): x y / x <= y}. + +Definition slope_bounded (x k: R) (f: R -> R):= + forall y z, x <= y <= z -> k * (z - y) <= f z - f y. + +(* on a< t = -k *) +Definition slope_bounded2 (a b k: R) (f: R -> R):= + forall y z, a <= y -> y <= z -> z <= b -> k * (z - y) <= f y - f z. + +Definition neg_in_interval1 (a b: R) (f: R -> R) := + forall z, a f z < 0. +Definition neg_in_interval2 (a b: R) (f: R -> R) := + forall z, a f z < 0. + +Definition pos_in_interval (a b: R) (f: R -> R) := + forall z, a 0 < f z. + + +Definition le_below_x (x: R) (f: R -> R) := + (forall y, 0 <= y -> y <= x -> f y <= f x). + +(* Here inv stands for "invariant" *) + +Definition inv (p: {poly R}) := + forall epsilon, 0 < epsilon -> + { x | + [/\ (le_below_x x (horner p)), + {in <=%R x &, pol_increasing p} & + (0 < x) && (x * p.[x] <= epsilon)] }. + +Definition inv2 (p : {poly R}) := + forall epsilon, 0 < epsilon -> + {x | + [/\ (le_below_x x (horner p)), + {in <=%R x &, pol_increasing p} & + [&& 0 < x, 0 < p.[x] & x * p.[x] <= epsilon]] }. + + +(* initial definition said nothing on b *) +Definition one_root1 (p : {poly R}) (a b : R) := + exists c d k, + [/\ [&& a < c, c < d, d < b & 0 < k], + (pos_in_interval a c (horner p)), + (neg_in_interval1 d b (horner p)) & + (slope_bounded2 c d k (horner p))]. + +Definition one_root2 (p : {poly R}) (a : R) := + { ck | + [/\ (a < ck.1) && (0 < ck.2), + (neg_in_interval2 a ck.1 (horner p)) & + (slope_bounded ck.1 ck.2 (horner p))] }. + +(** ** Basic properties *) + +Lemma slope_product_x (f : R -> R) x k: + 0 <= x -> 0 <= k -> + slope_bounded x k f -> + forall y z, x <= y <= z -> + (x * k + f y) * (z - y) <= z * f z - y * f y. +Proof. +rewrite /slope_bounded; move =>x0 kf0 incf y z /andP [xy yz]. +rewrite -[z * _] (addrNK (z * f y)) -mulrBr -addrA -mulrBl mulrDl (mulrC (f y)). +move: (le_trans xy yz) => xz. +rewrite lerD2r; apply: le_trans (_ : z * (k * (z - y)) <= _). + by rewrite - mulrA ler_wpM2r // mulr_ge0 // subr_ge0. +by rewrite ler_wpM2l ? incf ?xy ? yz//;apply:(le_trans x0). +Qed. + +(* Note that {poly R} is automatically converted into (seq R) *) + +Lemma all_pos_positive (p : {poly R}) x: + all_ge0 p -> 0 <= x -> p.[x] >= 0. +Proof. +move=> h x0; rewrite horner_coef. +apply: sumr_ge0 => [] [i his _] /=. +apply: mulr_ge0; rewrite ?exprn_ge0 //; apply: (allP h); exact: mem_nth. +Qed. + + +Lemma all_pos_increasing (p : {poly R}): + all_ge0 p -> {in <=%R 0 &, pol_increasing p}. +Proof. +move=> posp x y le0x le0y lexy; rewrite !horner_coef. +apply: ler_sum => [] [i ihs] /= _. +apply: ler_wpM2l => //; first by apply: (allP posp); exact: mem_nth. +by apply: lerXn2r. +Qed. + +Lemma one_root1_uniq p a b: one_root1 p a b -> + uniqueness (fun z => a < z < b /\ root p z). +Proof. +move => [c [d [k [leqs pa nb dab]]]]. +move => z1 z2 [/andP [z1a z1b] /eqP rz1] [/andP [z2a z2b] /eqP rz2]. +move: leqs => /and4P [ac cd db k0]. +case: (lerP z1 c) => z1c. + have aux:(a < z1 <= c) by rewrite z1a z1c. + by move: (pa z1 aux); rewrite rz1 ltxx. +case: (lerP z2 c) => z2c. + have aux:(a < z2 <= c) by rewrite z2a z2c. + by move: (pa z2 aux); rewrite rz2 ltxx. +case: (lerP z1 d) => z1d; last first. + have aux: (d < z1 < b) by rewrite z1d z1b. + by move: (nb z1 aux); rewrite rz1 ltxx. +case: (lerP z2 d) => z2d; last first. + have aux: (d < z2 < b) by rewrite z2d z2b. + by move: (nb z2 aux); rewrite rz2 ltxx. +case /orP: (le_total z1 z2) => cp. + apply/eqP; rewrite eq_le; apply/andP; split => //. + move: (dab _ _ (ltW z1c) cp z2d). + by rewrite rz1 rz2 addrN (pmulr_rle0 _ k0) subr_le0. +move: (dab _ _ (ltW z2c) cp z1d). +rewrite rz1 rz2 addrN (pmulr_rle0 _ k0) subr_le0. +move=> z1z2. +by apply/eqP; rewrite eq_le cp z1z2. +Qed. + +Lemma one_root2_uniq p a: one_root2 p a -> + uniqueness (fun z => a < z /\ root p z). +Proof. +move => [pp]; set c:=pp.1; set k := pp.2. +move => [/andP [ac kp] nii slk]. +move => z1 z2 [az1 /eqP rz1][az2 /eqP rz2]. +case: (lerP z1 c) => z1c. + have aux: (a < z1 <= c) by rewrite az1 z1c. + by move: (nii _ aux); rewrite rz1 ltxx. +case: (lerP z2 c) => z2c. + have aux: (a < z2 <= c) by rewrite az2 z2c. + by move: (nii _ aux); rewrite rz2 ltxx. +case /orP: (le_total z1 z2) => cp; apply/eqP; rewrite eq_le; apply/andP; split => //. + have aux:(c <= z1 <= z2) by rewrite (ltW z1c) cp. + move: (slk _ _ aux). + by rewrite rz1 rz2 addrN (pmulr_rle0 _ kp) subr_le0. +have aux:(c <= z2 <= z1) by rewrite (ltW z2c) cp. +move: (slk _ _ aux). +by rewrite rz1 rz2 addrN (pmulr_rle0 _ kp) subr_le0. +Qed. + +End DescOnOrderedRing. + +Section DescOnOrderedField. + +Variable R :realFieldType. +Implicit Type (p: {poly R}). + +Lemma all_pos_inv p: all_ge0 p -> inv p. +Proof. +move=> posp eps peps. +move: (pol_cont ('X * p) 0 peps) => [e ep le]. +have he := (half_gt0 ep). +have hew:= (ltW he). +exists (half e); split. + by move=> y y0 ye; apply: all_pos_increasing. + by move=> y y1 h h1; apply: all_pos_increasing => //; apply:(le_trans hew). +have -> : half e* p.[half e] = ('X * p).[half e] - ('X * p).[0]. + by rewrite !hornerM !hornerX mul0r subr0. +have le1: `|half e - 0| < e by rewrite subr0 ger0_norm // half_ltx. +by move /ler_normlP:(ltW(le _ le1)) => [_ ->]; rewrite he. +Qed. + +Lemma one_root2_shift p a b: + one_root2 (p \shift a) b -> one_root2 p (a + b). +Proof. +move=> [ck [/andP [x1a kp] neg sl]]. +exists (a + ck.1,ck.2); split. + by rewrite ltrD2l x1a kp. + move=> x /= abxax1; rewrite -(addrNK a x) - horner_shift_poly. + by rewrite neg // ltrBrDl lerBlDl. +move=> x y /= axy. +have aux: y - x = y - a - (x - a). + by rewrite opprD addrAC -!addrA opprK addrN addr0. +rewrite -{2} (addrNK a x) -{2} (addrNK a y) -!(horner_shift_poly a _) aux. +by apply: sl; rewrite ?lerD2r // lerBrDr addrC. +Qed. + +Lemma one_root1_shift p a b c: + one_root1 (shift_poly c p) a b -> + one_root1 p (c + a) (c + b). +Proof. +move=> [x1 [x2 [k [/and4P [ax1 x1x2 x2b kp] pos neg sl]]]]. +exists (c + x1); exists (c + x2); exists k. +rewrite !ltrD2l; split => //; first by apply /and4P. + move=> x cp; rewrite - (addrNK c x). + rewrite -horner_shift_poly pos ? lerBDl ? ltrBDl //. + move=> x cp; rewrite - (addrNK c x). + by rewrite -horner_shift_poly neg // ltrBrDl ltrBlDl. +move=> x y cx1x xy ycx2. +have aux: y - x = y - c - (x - c). + by rewrite [x + _]addrC opprD opprK addrA addrNK. +rewrite -{2} (addrNK c x) -{2} (addrNK c y) aux -!(horner_shift_poly c _). +by rewrite sl ?lerD2r // ?lerBrDr? lerBlDr // addrC. +Qed. + +Lemma one_root1_scale p a b c: + 0 < c -> one_root1 (p \scale c) a b -> + one_root1 p (c * a) (c * b). +Proof. +move=> cp [x1 [x2 [k [/and4P [ax1 x1x2 x2b kp] pos neg sl]]]]. +exists (c * x1); exists (c * x2); exists (k / c). +have tc : 0 < c^-1 by rewrite invr_gt0. +rewrite !(ltr_pM2l cp). +have t: forall z, z = c * (z / c). + by move=> z; rewrite [c * _]mulrC mulfVK //;move: cp;rewrite lt0r => /andP []. +split => //; first by apply/and4P; split => //; apply:mulr_gt0. + move=> x cpp; rewrite (t x) - horner_scaleX_poly; apply: pos. + by rewrite ltr_pdivlMr // mulrC ler_pdivrMr //(mulrC x1). + move=> x cpp. + rewrite (t x) -horner_scaleX_poly neg //. + by rewrite ltr_pdivlMr // mulrC ltr_pdivrMr // (mulrC b). +move=> x y cx1x xy ycx2; rewrite -mulrA mulrDr mulrN ![c^-1 * _]mulrC + {2}(t x) {2}(t y) -!(horner_scaleX_poly _ p); apply: sl. + by rewrite ler_pdivlMr // mulrC. + by rewrite ler_wpM2r // ltW. +by rewrite ler_pdivrMr // mulrC. +Qed. + +End DescOnOrderedField. + + +(** ** Case of archifields *) + +Section DescOnArchiField. + +Variable R :archiFieldType. +Lemma desc_l4 (p: {poly R}) : alternate_1 p -> inv2 p. +Proof. +move: p;elim/poly_ind => [| p a ih]; first by rewrite/alternate_1 polyseq0. +have desc_c: alternate_1 (a%:P) -> inv2 (a%:P). + rewrite polyseqC;case: (a==0) => //=; case ha: (0< a) => // _. + move=> eps eps0; exists (eps / a); split. + by move => y _ _; rewrite !hornerC. + by move => y1 y2 _ _ _ ; rewrite !hornerC. + by rewrite hornerC ha divr_gt0 //= (divrK (unitf_gt0 ha)). +case sp : (nilp p). + by move: sp; rewrite nil_poly; move /eqP => ->; rewrite mul0r add0r. +rewrite -{1} cons_poly_def polyseq_cons sp /=. +case: (ltrgtP 0 a) => ha. +(* case a > 0 *) +move => haposp eps eps0; rewrite /inv2 /=. + have : all_ge0 (p * 'X + a%:P). + by rewrite -cons_poly_def polyseq_cons sp /= ltW. + move/all_pos_inv/(_ eps eps0)=> [x [h1x h2x /andP[h3x h4x]]]; exists x. + have xp:= ltW h3x. + split => //; rewrite h3x h4x !hornerE ltr_pwDr // mulr_ge0 //. + by rewrite all_pos_positive. +(* case a < 0 *) +rewrite -oppr_gt0 in ha. + set q := (p * 'X + a%:P). + move=> il;move: (ih il _ ((half_gt0 ha)))=> [x [H1 H2 /and3P [xp xpx xe]]]. + move: (le_lt_trans xe (half_ltx ha)) => xe'. + have qxn : q.[x] < 0 by rewrite !hornerE mulrC -(opprK a) subr_lt0. + move: (maxS x (-a/p.[x])) => /andP []; set y := (_ + _) => yx val. + have yx':= ltW yx. + have ppos: forall t, x <= t -> 0 < p.[t]. + move => t xt;exact (lt_le_trans xpx (H2 _ _ (lexx x) xt xt)). + have qsincr: forall t d, x <= t -> 0 < d -> q.[t] < q.[t+d]. + move => t d xt dp; rewrite !hornerE. + set w := _ + _. + have aux: t <= t+d by rewrite - {1}(addr0 t) lerD2l ltW. + have xtd:= (le_trans xt aux). + rewrite mulrDr -addrAC addrC ltr_pwDl ?(mulr_gt0 (ppos _ xtd) dp)//. + rewrite !lerD2r (ler_pM2r (lt_le_trans xp xt)). + by apply:H2 => //. + have qincr: forall t, x<=t -> {in <=%R t &, pol_increasing q}. + move => t xt u v ut vt; rewrite le_eqVlt; case /orP => uv. + by move /eqP:uv => ->. + rewrite ltW // - (addNKr u v); apply: (qsincr _ _(le_trans xt ut)). + by rewrite addrC subr_gt0. + move: (H2 _ _ (lexx x) yx' yx') => lepxpy. + have yge0: 0 <= y by rewrite ltW // (lt_le_trans xp yx'). + have posval : 0 <= q.[y]. + rewrite !hornerE -(addNr a) /= lerD2r /=. + apply: (@le_trans _ _ (p.[x] * y)); last by rewrite ler_wpM2r. + rewrite // mulrC - ler_pdivrMr // ltW //. + set r := ('X * q). + have negval' : r.[x] < 0 by rewrite 2!hornerE pmulr_rlt0. + have posval' : 0 <= r.[y] by rewrite 2! hornerE mulr_ge0. + move=> epsilon Hepsilon /=. + move: (half_gt0 Hepsilon) => he1. + move: (constructive_ivt yx negval' posval' he1) => [ppr]. + rewrite (surjective_pairing ppr); set u:=ppr.1;set v := ppr.2. + move /and5P => [/and3P [_ _ smallv] /and3P[xd dv v'y] _ posv _]. + have {xd dv} xv : x < v by apply: le_lt_trans xd dv. + have pv : 0 < v by apply: lt_trans xv. + move: posv; rewrite 2! hornerE -{1} (mulr0 v) (ler_pM2l pv) => posv. + move: (pol_cont r v he1) => [d' dp' pd']. + pose d := half d'. + have dp : d > 0 by rewrite half_gt0. + have dd' : d < d' by apply: half_ltx. + have vvd : v < v + d by rewrite ltrDl /=. + have xvd : x < v + d by apply: lt_trans vvd. + have lvd : 0 < p.[v + d] by apply: ppos; exact: ltW. + move => {y yx val yx' posval posval' v'y lepxpy yge0}. + have pa: le_below_x (v + d) (horner q). + move => y y0 yvd; rewrite !hornerE lerD2r /=. + case cmp: (y <= x); last first. + have cmp': x <= y by rewrite ltW // ltNge cmp. + apply: le_trans (_ : p.[v + d] * y <= _). + by apply: ler_wpM2r => //; apply: H2 => //;apply: (le_trans cmp'). + by rewrite ler_wpM2l // ltW. + apply: le_trans (_ : p.[x] * y <= _). + by rewrite ler_wpM2r //; apply: H1. + apply: le_trans (_ : p.[x] * (v + d) <= _); last first. + rewrite ler_wpM2r //; first exact: le_trans yvd. + rewrite H2 //; first (by apply: (lexx x)); by apply:ltW. + by rewrite ler_wpM2l // ltW. + exists (v + d). + rewrite (le_lt_trans posv (qsincr _ _ (ltW xv) dp)) (lt_trans pv vvd). + split => //=; first by apply: qincr; apply: ltW. + rewrite - (double_half epsilon). + apply: le_trans (_ : ((half epsilon) + r.[v+d] -r.[v]) <= _). + rewrite [ half epsilon + _] addrC -addrA. + rewrite [r.[v + d]] hornerE hornerX lerDl subr_ge0 //. + rewrite -!addrA lerD2l. + have aux:`|(v+d) - v| < d' by rewrite (addrC v) addrK ger0_norm// ltW. + by move: (ltW (pd' _ aux)) => /ler_normlP [_]. +(* case a = 0 *) +move => halt1 eps eps0. +move: (ih halt1 _ ltr01) => [x [plx pmonx /and3P [gx0 gpx0 lpx1]]]. +have e1px : 0 < eps / x by apply: mulr_gt0=> //=; rewrite invr_gt0. +move: (ih halt1 _ e1px) => [v [plv pmonv /and3P [gv0 gpv0 lpve]]]. +rewrite -ha addr0. +have aux: forall w, 0 <=w -> 0 <= p.[w] -> {in <=%R w &, pol_increasing p} -> + {in <=%R w &, pol_increasing ((p * 'X))}. + move => w wz pwz H s t sw tw st; rewrite !hornerE. + move: (H _ _ sw tw st) (le_trans pwz (H _ _ (lexx w) sw sw)) => pa pb. + by apply:(ler_pM pb (le_trans wz sw) pa st). +set w:= (Num.min x v); exists w. +have wc: w = x \/ w = v. + by rewrite /w /minr; case: ifPn; [left|right]. +have wz: 0 < w by case wc => ->. +have pw0: 0 < p.[w] by case wc => ->. +rewrite wz 3! hornerE (pmulr_lgt0 _ wz) pw0. +split. + move => t tp tw; rewrite !hornerE mulrC (mulrC _ w). + apply: (pmul2w1 tp (ltW pw0) tw). + move: tp tw;case wc=> ->; [apply: plx | apply: plv]. + by apply: aux; [apply: ltW | by apply: ltW| case wc => ->]. +move: lpve; rewrite (ler_pdivlMr _ _ gx0) => lpve. +case /orP:(le_total x v)=> xv; + rewrite /w/=. + move/min_idPr : (xv); rewrite minC => ->. + apply: le_trans lpve; rewrite mulrA. + rewrite (ler_pM2r gx0);apply: (ler_pM (ltW gx0) (ltW gpx0) xv). + exact:(pmonx _ _ (lexx x) xv xv). +move/min_idPr : (xv) => ->. +apply: le_trans lpve. +rewrite mulrA. +by rewrite (ler_pM2l (mulr_gt0 gv0 gpv0) v x). +Qed. + +Lemma desc (p: {poly R}): alternate p -> one_root2 p 0. +Proof. +move: p; elim/poly_ind => [| p a IHl]; first by rewrite polyseq0. +rewrite -cons_poly_def polyseq_cons. +case sl: (nilp p) => /=. + by rewrite polyseqC; case: (a == 0) => //=;rewrite ! if_same. +case: (ltrP a 0) => ha alt1. + rewrite - oppr_gt0 in ha. + move: (desc_l4 alt1 (half_gt0 ha)) => [x [psub pmon /and3P [xp pxp pxa1]]]. + move: (le_lt_trans pxa1 (half_ltx ha)) => pxa2. + exists (x, p.[x]); simpl; rewrite xp pxp; split => //. + move => y /andP [posy yx]. + move: (ltW posy) => posy'. + rewrite horner_cons -(opprK a) subr_lt0; apply: le_lt_trans pxa2. + rewrite mulrC; apply:(pmul2w1 posy' (ltW pxp) yx (psub _ posy' yx)). + move => y z xyz;rewrite !horner_cons opprD addrCA addrK. + rewrite [_ + _ * _]addrC [_ * z]mulrC [_ * y]mulrC. + have slp:slope_bounded x 0 (horner p). + move => t u /andP[xt tu];rewrite mul0r subr_gte0 pmon //. + exact (le_trans xt tu). + move:(slope_product_x (ltW xp) (lexx 0) slp xyz). + move/andP :xyz => [xy yz]. + rewrite mulr0 add0r; apply: le_trans. + by apply: (ler_wpM2r _ (pmon _ _ (lexx x) xy xy)); rewrite subr_ge0. +move: alt1; case a0 : (a == 0) => // alt1; move: (eqP a0) => a00. +clear ha a0. +move: (IHl alt1) => [v1k []] {IHl}. +set v1 := v1k.1; set k:= v1k.2; simpl => /andP[v1pos kpos] low incr. +have negval : (p.[v1] < 0) by apply: low; rewrite ?lexx v1pos. +set k':= half (k * v1). +have posk' : 0 < k' by apply: half_gt0; apply: mulr_gt0. +set u := (- p.[v1]) / k. +move: (maxS 0 u); set v:= Num.max 0 _ => /andP [pa pb]. +set v2:= v1 + v +1. +have v0: 0 <= v by rewrite le_max lexx. +have v1v2: v1 < v2 by rewrite /v2 - addrA (ltrDl v1). +have pos1:0 <= p.[v1 + v]. + move: (kpos); rewrite lt0r => /andP [ kne0 _]. + move: kpos; rewrite - invr_gt0 => kpos. + rewrite /v; have [caf|caf] := leP u 0. + by rewrite addr0 - oppr_le0 - (pmulr_lle0 _ kpos). + case/orP:(le_total u 0); [ | move => up]. + by rewrite leNgt caf. + have aa: v1 <= v1 <= v1 + u by rewrite lexx lerDl. + rewrite -(lerDr (- p.[v1]));apply: le_trans (incr _ _ aa). + by rewrite (addrC v1) addrK /u (mulrC _ (k^-1)) mulVKf //. +have pos : 0 < p.[v2]. + have hh: v1 <= v1 + v <= v1 + v + 1 by rewrite !lerDl v0 ler01. + apply: (le_lt_trans pos1);rewrite -subr_gt0. + by apply: (lt_le_trans _ (incr _ _ hh)); rewrite addrAC addrN add0r mulr1. +clear v0 pos1 pa pb. +move: (constructive_ivt v1v2 negval (ltW pos) posk') => [x12]. +rewrite (surjective_pairing x12); set x1:=x12.1;set x2 := x12.2. +move /and5P => [/and3P [x1close _ _] /and3P[v1x1 _ _] px1neg _ _]. +have x1pos : 0 < x1 by apply: lt_le_trans v1x1. +have Plow : forall x, 0 < x -> x <= x1 -> x * p.[x] < 0. + move=> x xpos xx1; rewrite (pmulr_rlt0 _ xpos). + case: (ltrP x v1)=> xv1; first by apply: low=> //; rewrite xpos ltW. + apply: le_lt_trans px1neg. + move: xx1; rewrite le_eqVlt; move/orP => [xx1 | xlx1]; + first by rewrite (eqP xx1) lexx. + have aux : v1 <= x <= x1 by rewrite xv1 ltW. + rewrite -subr_gte0; move: (incr _ _ aux); apply: le_trans. + by apply: ltW; apply: mulr_gt0 => //; rewrite subr_gt0. +exists (x1,k'); simpl; rewrite x1pos posk'; split => //. + by move=> x /andP[x0 xx1]; rewrite horner_cons a00 addr0 mulrC;apply : Plow. +move => x y /andP[x1x xy]. +rewrite ! horner_cons a00 !addr0 (mulrC _ x) (mulrC _ y). +have: (v1 * k + p.[x]) * (y - x) <= y * p.[y] - x * p.[x]. + apply:(slope_product_x (ltW v1pos) (ltW kpos) incr). + by rewrite xy (le_trans v1x1 x1x). +apply: le_trans; rewrite ler_wpM2r //; first by rewrite subr_ge0. +rewrite mulrC - (double_half (k * v1 )) -/k' - addrA lerDl. +rewrite - (opprK k') addrC subr_gte0 (le_trans x1close) // -subr_gte0. +have: k * (x - x1) <= p.[x] - p.[x1] by apply: incr =>//; rewrite x1x v1x1. +by apply : le_trans; apply: mulr_ge0 => //; rewrite ?(ltW kpos) ?subr_ge0. +Qed. + +Lemma one_root_reciprocal (p: {poly R}) deg : + (0 < size p)%N -> + (size p <= deg.+1)%N -> + one_root2 (recip deg p) 1 -> one_root1 p 0 1. +Proof. +move=> s0 sz [x1k [/andP []]]. +set x1 := x1k.1; set k := x1k.2; set q := (recip deg p). +move => x1gt1 kp neg sl. +have x10 : 0 < x1 by apply: lt_trans x1gt1; exact: ltr01. +set y' := x1 - q.[x1] / k. +have nx1 : q.[x1] < 0 by rewrite neg //x1gt1 lexx. +have knz: k != 0 by move: kp; rewrite lt0r; case /andP =>[]. +have y'1: x1 < y' by rewrite /y' ltrDl oppr_gt0 pmulr_llt0 // ?invr_gt0. +have y'pos : 0 <= q.[y']. + have aux: x1 <= x1 <= y' by rewrite (lexx x1) (ltW y'1). + rewrite -(lerD2r (- q.[x1])) add0r; apply: le_trans (sl _ _ aux). + by rewrite /y' (addrC x1) addrK mulrN mulrC mulfVK. +move: (@diff_xn_ub R deg 1); set u := _ *+ _; move => up. +set u':= Num.max 1 u. +have uu': u <= u' by rewrite le_max lexx orbT. +have u1: 1 <= u' by rewrite le_max lexx. +have u'0 : 0 < u' by rewrite (lt_le_trans ltr01). +have divu_ltr : forall x, 0 <= x -> x / u' <= x. + move => x x0; rewrite ler_pdivrMr // ler_peMr //. +have y'0: 0 < y' by apply: lt_trans y'1. +pose y := y' + 1. +have y'y : y' < y by rewrite /y ltrDl. +have y1 : x1 < y by apply: lt_trans y'1 _. +have ypos : 0 < q.[y]. + have aux: x1 <= y' <= y by rewrite (ltW y'1) (ltW y'y). + rewrite (le_lt_trans y'pos) // -subr_gte0. + by apply: lt_le_trans (sl _ _ aux); rewrite mulr_gt0 // subr_gt0. +have y0: 0 < y by apply: lt_trans y'y. +pose k' := half ((k * x1 ^+ 2 * y ^- 1 ^+ deg)). +have k'p : 0 < k'. + apply: half_gt0; rewrite mulr_gt0 //; first by rewrite mulr_gt0 // exprn_gt0. + rewrite exprn_gt0 // invr_gt0 //. +pose e := k' / u'. +have ep: 0 < e by rewrite /e; apply: mulr_gt0 => //; rewrite invr_gt0. +pose e1 := half e. +have e1p : e1 > 0 by apply: half_gt0. +have e1e : e1 < e by apply: half_ltx. +move: (constructive_ivt y'1 nx1 y'pos e1p)=> [pv]. +rewrite (surjective_pairing pv); set a:=pv.1;set b' := pv.2. +move=> /and5P[/and3P [cla _ clb'] /and3P[x1a ab b'y'] nega posb' _]. +move: (pol_lip q (z:=y)); set c := (norm_pol q^`()).[y] => cp. +have cp0 : 0 < c. + move: (lt_le_trans nega posb'); rewrite - subr_gt0 => dp. + move: (ltW (le_lt_trans b'y' y'y)) => pb. + move: y0; rewrite -(oppr_lt0 y) => yn0. + move: (ltW (lt_trans yn0 (lt_le_trans x10 x1a))) => pa. + move: (cp _ _ pa (ltW ab) pb); rewrite (gtr0_norm dp) => dp'. + by move: (lt_le_trans dp dp'); rewrite pmulr_lgt0 // subr_gt0. +set b := Num.min y (b' +(half e1)/c). +have blty: b <= y by rewrite /b ge_min lexx. +have b'b: b' < b. + rewrite lt_min (le_lt_trans b'y' y'y) /= - ltrBlDl addrN. + by rewrite (divr_gt0 (half_gt0 e1p) cp0). +have clb:c * (b - b') < e1. + apply: le_lt_trans (half_ltx e1p). + by rewrite -(ler_pdivlMl _ _ cp0) mulrC lerBlDl ge_min lexx orbT. +pose n := (size p).-1. +have a0 : 0 < a by apply: lt_le_trans x1a. +have b'0 : 0 < b' by apply: lt_trans ab. +have b0 : 0 < b by apply: lt_trans b'b. +have ibp: 0 < b^-1 by rewrite invr_gt0. +have inv_mono: forall x, 0 < x -> Num.sg (q.[x]) = Num.sg (p.[x^-1]). + move => x xp. + rewrite /q /recip. + rewrite hornerM (horner_reciprocal _ ( unitf_gt0 xp)) hornerXn. + rewrite !sgrM gtr0_sg ?mul1r //. + by rewrite gtr0_sg // ?mul1r // exprn_gt0. + by rewrite exprn_gt0. +rewrite /one_root1 /pos_in_interval /neg_in_interval1. +have res1:pos_in_interval 0 b^-1 (horner p). + move => x /andP[x0 xb]. + rewrite -[x]invrK -sgr_cp0 - inv_mono ?invr_gt0 // sgr_cp0. + rewrite (le_lt_trans posb') // -subr_gte0 /=. + have b'x : b' < x^-1. + by rewrite inv_comp// (le_lt_trans xb)// ltf_pV2. + have aa:x1 <= b' <= x^-1 by rewrite (ltW (le_lt_trans x1a ab)) (ltW b'x). + by apply:lt_le_trans (sl _ _ aa); rewrite mulr_gt0 // subr_gt0. +have res2: neg_in_interval1 a^-1 1 (horner p). + move => x /andP[a1x xlt1]. + have x0 : 0 < x by apply: lt_trans a1x; rewrite invr_gt0. + have xv0 : 0 < x^-1 by rewrite invr_gt0. + rewrite -[x]invrK -sgr_cp0 - inv_mono ?invr_gt0 // sgr_cp0. + have x1a0 : x^-1 < a by rewrite inv_compr. + case : (lerP x1 x^-1) => cmp; last first. + apply: neg => //;rewrite (inv_comp ltr01 x0) invr1. + by rewrite xlt1 (ltW cmp). + have aux: (x1 <= x^-1 <= a) by rewrite cmp (ltW x1a0). + apply: lt_trans nega; rewrite -subr_gte0. + apply: lt_le_trans (sl _ _ aux). + by rewrite mulr_gt0 // subr_gt0. +exists b^-1, a^-1, k'. +split => //. + rewrite k'p ibp ltf_pV2// (inv_compr ltr01 a0) invr1. + by rewrite (lt_trans ab b'b) (lt_le_trans x1gt1 x1a). +move => x z bvx xz zav. + rewrite le_eqVlt in xz; move/orP: xz => [xz | xz]. + by rewrite (eqP xz) !addrN mulr0 lexx. +have x0: 0 < x by apply: (lt_le_trans ibp bvx). +have z0 : 0 < z by apply: (lt_trans x0). +have lmrec : forall yy, 0 < yy -> p.[yy] = yy ^+ deg * q.[yy^-1]. + move => yy yy0. + rewrite hornerM horner_reciprocal1 ?unitf_gt0 // hornerXn exprVn mulrA. + case h : (size p == 1)%N. + rewrite (eqP h) !subSS !subn0 mulfV // expf_neq0 //. + by move: yy0; rewrite lt0r; case/andP. + have h' : size p = (size p).-2.+2. + case h'': (size p) => [ | [ | sp]] //. + by move: s0; rewrite h'' ltn0. + by move: h; rewrite h'' eqxx. + rewrite -expfB; last first. + rewrite h' subSS prednK; last by rewrite h'. + rewrite -{2}[deg]subn0 ltn_sub2l //. + by rewrite -ltnS (leq_trans _ sz) // h'. + by rewrite h'. + by rewrite h' !subSS subKn ?subn0 // -ltnS -h'. +rewrite (lmrec x x0) (lmrec z z0). +set s := deg. +set t1 := (x ^+ s - z ^+ s) * q.[x^-1]. +set t3 := q.[x^-1] - q.[z^-1]. +rewrite (_ : _ * _ - _ = t1 + t3 * z ^+ s); last first. + by rewrite /t1 !mulrDl !mulNr ![_.[_] *_]mulrC !addrA addrNK. +set t2 := t3 * _. +pose k1 := -k'; pose k2 := k' + k'. +have k2p : k2 = (k * x1 ^+ 2 * y ^-1 ^+ s) by apply: double_half. +rewrite (_ : k' = k1 + k2); last by rewrite /k1 /k2 addrA addNr add0r. +have xzi: z^-1 < x^-1 by rewrite ltf_pV2. +have pa : x1 <= z^-1. + by rewrite (le_trans x1a)// -(invrK a)// lef_pV2// posrE invr_gt0. +have pb: x1 <= x^-1 by rewrite (ltW (le_lt_trans pa xzi)). +have pc: 0 <= k * (x^-1 - z^-1) by apply: ltW;rewrite(mulr_gt0 kp) // subr_gt0. +have pdd:(x1 <= z^-1 <= x^-1) by rewrite pa (ltW xzi). +have pd:= (sl _ _ pdd). +have t3p:= le_trans pc pd. +have pe : 0 <= y^-1 <= z. + by rewrite invr_ge0 ltW //= (le_trans _ (ltW xz))// (le_trans _ bvx)// lef_pV2. +case /andP: (pow_monotone s pe) => _ hh. +have maj' : t3 * y^-1 ^+ s <= t3 * z^+ s by rewrite ler_wpM2l. +rewrite mulrDl; apply: lerD; last first. + apply: le_trans maj'; rewrite /t3 k2p mulrAC. + rewrite ler_pM2r; last by apply: exprn_gt0; rewrite invr_gt0. + apply: le_trans pd. + rewrite ![k * _]mulrC mulrAC ler_pM2r //. + have xn0 : (x != 0) by move: x0; rewrite lt0r; case /andP =>[]. + have zn0 : (z != 0) by move: z0; rewrite lt0r; case /andP =>[]. + have xVn0 : (x^-1 != 0) by move: x0; rewrite -invr_gt0 lt0r; case /andP =>[]. + rewrite -[x^-1](mulfK zn0) -(mulrC z) - (mulrA z _ _). + rewrite -{2}[z^-1](mulfK xn0) -(mulrA _ x _)(mulrCA _ x). + rewrite (mulrC z^-1) -mulrBl (mulrC (z - x)). + rewrite ler_pM2r /=; last by rewrite subr_gte0. + apply: le_trans (_ : x1 / z <= _); first rewrite ler_pM2l //=. + by rewrite ler_pM2r ?invr_gt0. +move:(ltW xz) => xz'. +have xzexp : (x ^+ s - z ^+ s) <= 0. + have aux: 0 <=x <= z by rewrite xz' ltW//. + by case /andP :(pow_monotone s aux)=> [_]; rewrite subr_le0. +have xzexp' : (z ^+ s - x ^+ s) >= 0 by rewrite subr_ge0 - subr_le0. +rewrite /t1 /k1 /k' {maj' t2 t3}. +case: (lerP 0 ( q.[x^-1])) => sign; last first. + apply: le_trans (_ : 0 <= _). + by rewrite mulNr lterNl oppr0 mulr_ge0 //?(ltW k'p)// subr_gte0 /= ltW. + by rewrite mulr_le0 // ltW. +rewrite mulNr lterNl -mulNr opprD opprK addrC. +have rpxe : q.[x^-1] <= e. + have bvx' : x^-1 <= b by rewrite -(invrK b)// lef_pV2. + apply: (@le_trans _ _ q.[b]). + have aux:(x1 <= x^-1 <= b) by rewrite pb bvx'. + rewrite -subr_ge0 /= ;apply: le_trans (sl _ _ aux). + rewrite mulr_ge0 ?subr_gte0 // ltW //. + rewrite -[_ _ b]addr0 -(addrN (q).[b']) addrA. + rewrite (addrC ( _ b)) -addrA -(double_half e) (lerD clb')//. + have yb: - y <= b' by apply: ltW; apply: lt_trans b'0; rewrite oppr_lt0. + move: (le_trans (cp b' b yb (ltW b'b) blty) (ltW clb)). + by move /ler_normlP => [_]. +apply: le_trans (_ : (z^+ s - x ^+ s) * e <= _). + by rewrite ler_wpM2l // ?subr_gte0. +have un0 : (u' != 0) by move: u'0; rewrite lt0r; case /andP =>[]. +rewrite [_ * e]mulrC; apply: le_trans (_ : e * (u' * (z - x)) <= _)=> /=. + apply: ler_wpM2l; first exact: ltW. + apply: (@le_trans _ _ (u * (z - x))). + have xm1: -1 <= x by exact: (ltW (lt_trans (ltrN10 R) x0)). + have a1 : 1 <= a by apply: (ltW (lt_le_trans x1gt1 x1a)). + rewrite - (ger0_norm xzexp'); apply: (up _ _ xm1 xz'). + apply: le_trans zav _. + by rewrite invr_le1 // unitf_gt0. + by rewrite ler_pM2r // subr_gte0. +rewrite mulrA ler_pM2r; last by rewrite subr_gte0. +rewrite /= /e divfK ?lterr //. +Qed. + +Lemma alternate_MX (p : {poly R}) k: + alternate ('X ^+ k * p) -> alternate p. +Proof. +elim: k => [ | k IH]; first by rewrite expr0 mul1r. +case h : (p == 0); first by rewrite (eqP h) mulr0. +rewrite mulrC polyseqMXn //=; last by rewrite h. +by rewrite ltxx eqxx -polyseqMXn ?h // mulrC. +Qed. + +Lemma Bernstein_isolate deg a b (l : {poly R}): a < b -> (0 < size l)%N -> + (size l <= deg.+1)%N -> alternate (Mobius deg a b l) -> one_root1 l a b. +Proof. +rewrite /Mobius /recip => altb s0 sz. +have sss : size ((l \shift a) \scale (b - a)) = size l. + rewrite size_scaleX; last by move: altb; rewrite -subr_gt0 lt0r; case/andP. + by rewrite size_comp_poly2 // size_XaddC. +rewrite sss => alt. +have -> : a = a + (a - a) by rewrite addrN addr0. +have -> : b = a + (b - a) by rewrite (addrC b) addNKr. +apply: one_root1_shift. +rewrite addrN -(mulr1 (b - a)) -(mulr0 (b - a)). +apply: one_root1_scale; first by rewrite subr_gt0. +move/desc: alt => alt'; move/one_root2_shift: alt'; rewrite addr0 -sss. +by apply: one_root_reciprocal; rewrite sss. +Qed. + +End DescOnArchiField. diff --git a/theories/desc1.v b/theories/desc1.v new file mode 100644 index 0000000..f1724f0 --- /dev/null +++ b/theories/desc1.v @@ -0,0 +1,697 @@ +From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype order. +From mathcomp Require Import binomial bigop ssralg poly ssrnum ssrint rat. + +From mathcomp Require Import polydiv polyorder path interval polyrcf. + +(** Descates method 1 *) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import Order.Theory GRing.Theory Num.Theory Num.Def. +Local Open Scope ring_scope. +(** ** Sign changes *) + +Section SignChange. + +Variable R :realDomainType. +Implicit Type l: (seq R). +Implicit Type p: {poly R}. + +Definition all_eq0 l := all (fun x => x == 0) l. +Definition all_ge0 l:= all (fun x => 0 <= x) l. +Definition all_le0 l := all (fun x => x <= 0) l. +Definition all_ss a l := all (fun x => 0 <= x * a) l. +Definition opp_seq l := [seq - z | z <- l]. +Definition filter0 l := [seq z <- l | z != 0]. + +(** Some helper lemmas *) + +Lemma product_neg (a b : R): a * b < 0 -> a != 0 /\ b != 0. +Proof. +case (eqVneq a 0) => [->|]; first by rewrite mul0r ltxx. +case (eqVneq b 0) => [->|] //; by rewrite mulr0 ltxx. +Qed. + +Lemma square_pos (a: R): a != 0 -> 0 < a * a. +Proof. by move => anz; rewrite lt0r sqr_ge0 sqrf_eq0 anz. Qed. + +Lemma prodNsimpl_ge (a b x: R): b * a < 0 -> 0 <= x * b -> x * a <= 0. +Proof. +move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. +by rewrite - (nmulr_lle0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lle0. +Qed. + +Lemma prodNsimpl_gt (a b x: R): b * a < 0 -> 0 < x * b -> x * a < 0. +Proof. +move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. +by rewrite - (nmulr_llt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_llt0. +Qed. + +Lemma prodNsimpl_lt (a b x: R): b * a < 0 -> x * b < 0 -> 0 < x * a. +Proof. +move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. +by rewrite - (nmulr_lgt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lgt0. +Qed. + +Lemma all_rev l q: all q l = all q (rev l). +Proof. by elim:l => [// | a l hr]; rewrite rev_cons all_rcons /= hr. Qed. + +Lemma has_split q l: has q l -> + exists l1 a l2, [/\ l = l1 ++ a :: l2, q a & all (fun z => ~~(q z)) l1]. +Proof. +elim:l => // a l Hrec /=; case ha: (q a) => /=. + by move => _; exists [::], a, l; split => //. +move /Hrec => [l1 [b [l2 [-> pb pc]]]]. +by exists (a::l1),b,l2; split => //=; rewrite ha pc. +Qed. + +Lemma has_split_eq l: has (fun z => z != 0) l -> + exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l1]. +Proof. +move/has_split => [l1 [a [l2 [-> pa pb]]]]; exists l1,a,l2; split => //. +by apply /allP => x; move /(allP pb); case (x==0). +Qed. + +Lemma has_split_eq_rev l: has (fun z => z != 0) l -> + exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l2]. +Proof. +have <- : (has (fun z : R => z != 0)) (rev l) = has (fun z : R => z != 0) l. + by elim:l => [// | a l hr]; rewrite rev_cons has_rcons /= hr. +move/has_split_eq => [l1 [a [l2 [lv pa pb]]]]; exists (rev l2),a,(rev l1). +by rewrite -(cat1s a) catA cats1 -rev_cons -rev_cat -lv revK /all_eq0 -all_rev. +Qed. + +Lemma opp_seqK l: opp_seq (opp_seq l) = l. +Proof. +by rewrite/opp_seq -map_comp; apply map_id_in => a /=; rewrite opprK. +Qed. + +Definition tail_coef p := p `_(\mu_0 p). +Definition lead_tail_coef p := (tail_coef p) * (lead_coef p). + +Lemma tail_coef0a p: ~~ (root p 0) -> tail_coef p = p`_0. +Proof. by move /muNroot; rewrite /tail_coef => ->. Qed. + +Lemma tail_coef0b p: p`_0 != 0 -> tail_coef p = p`_0. +Proof. rewrite - {1} horner_coef0; apply: tail_coef0a. Qed. + +Lemma tail_coefM (p q: {poly R}): + tail_coef (p*q) = (tail_coef p) * (tail_coef q). +Proof. +rewrite /tail_coef. +case pnz: (p!=0); last by rewrite (eqP(negbFE pnz)) mul0r mu0 coef0 mul0r. +case qnz: (q!=0); last by rewrite (eqP(negbFE qnz)) mulr0 mu0 coef0 mulr0. +rewrite (mu_mul 0 (mulf_neq0 pnz qnz)). +move: (mu_spec 0 pnz) (mu_spec 0 qnz); rewrite subr0. +set a := (\mu_0 p); set b:= (\mu_0 q); move => [pa v1 ->] [qa v2 ->]. +by rewrite mulrACA -exprD 3! coefMXn ! ltnn ! subnn - ! horner_coef0 hornerM. +Qed. + +Lemma lead_tail_coefM (p q: {poly R}): + lead_tail_coef (p*q) = (lead_tail_coef p) * (lead_tail_coef q). +Proof. by rewrite /lead_tail_coef -mulrACA -tail_coefM lead_coefM. Qed. + +Lemma lead_tail_coef_opp p: lead_tail_coef (- p) = (lead_tail_coef p). +Proof. +rewrite - mulrN1 lead_tail_coefM; set one := (X in _ * lead_tail_coef(X)). +suff : lead_tail_coef one = 1 by move ->; rewrite mulr1. +have ->: one = ((-1)%:P) by rewrite polyCN. +by rewrite /lead_tail_coef /tail_coef lead_coefC mu_polyC coefC mulN1r opprK. +Qed. + +Lemma mu_spec_supp p: p != 0 -> + exists q, [/\ p = q * 'X^ (\mu_0 p), (~~ root q 0), + lead_coef p = lead_coef q, tail_coef p = tail_coef q & + tail_coef q = q`_0]. +Proof. +move /(mu_spec 0) => [q pa]; set n := (\mu_0 p) => ->; exists q. +rewrite lead_coefM tail_coefM {1 2} subr0 (eqP (monicXn R n)) mulr1 /tail_coef. +by rewrite mu_exp mu_XsubC mul1n subr0 coefXn eqxx mulr1 (muNroot pa). +Qed. + +Lemma tail_coefE p: tail_coef p = (head 0 (filter0 p)). +Proof. +have [-> |] := (eqVneq p 0); first by rewrite /tail_coef mu0 coef0 polyseq0 /=. +move /(mu_spec_supp) => [q [pa pb pc pd pe]]; rewrite /filter0. +case (eqVneq q 0) => qnz; first by move: pb; rewrite qnz root0. +have q0nz: q`_0 != 0 by rewrite - horner_coef0. +rewrite pd pe pa polyseqMXn// -cat_nseq filter_cat (eq_in_filter (a2 := pred0)). + by rewrite filter_pred0 cat0s nth0; move: q0nz; case q; case => //= a l _ ->. +have /allP h: all (pred1 (0:R)) (nseq (\mu_0 p) 0). + by rewrite all_pred1_nseq. +by move => x /h /= ->. +Qed. + +Fixpoint changes (s : seq R) : nat := + (if s is a :: q then (a * (head 0 q) < 0)%R + changes q else 0)%N. +Definition schange (l: seq R) := changes (filter0 l). + +Lemma schange_sgr l: schange l = schange [seq sgr z | z <- l]. +Proof. +rewrite /schange /filter0 filter_map; set s1 := [seq z <- l | z != 0]. +set s := (filter (preim _ _)); have -> : s l = s1. + apply: eq_in_filter => x xl /=. + by rewrite sgr_def; case xz: (x!=0); rewrite ?mulr0n ?eqxx ?mulr1n ?signr_eq0. +elim: s1 => [ // | a l1 /= ->]; case l1 => /=; first by rewrite !mulr0. +by move => b l2; rewrite - sgrM sgr_lt0. +Qed. + + +Lemma schange0_odd l: last 0 l != 0 -> + odd (schange l + (0 < head 0 (filter0 l) * last 0 l)%R). +Proof. +rewrite /schange. +have -> : filter0 l = [seq z <- 0::l | z != 0]. + by rewrite /filter0 {2} /filter eqxx. +rewrite (lastI 0 l); set b := (last 0 l) => bnz; rewrite filter_rcons bnz. +set s := [seq z <- belast 0 l | z != 0]. +have: all (fun z => z != 0) s by apply : filter_all. +elim: s; first by rewrite /= mulr0 ltxx square_pos //. +move => c s /=; set C:= changes _; set d:= head 0 _ => hr /andP [cnz etc]. +have dnz: d != 0 by move: etc; rewrite /d; case s => // s' l' /= /andP []. +rewrite addnC addnA addnC; move: (hr etc). +rewrite -sgr_gt0 - (sgr_gt0 (c*b)) - sgr_lt0 ! sgrM. +rewrite /sgr - if_neg - (if_neg (c==0))- (if_neg (b==0)) bnz dnz cnz. +by case: (d<0); case: (b<0); case: (c<0); rewrite ?mulrNN ? mulr1 ?mul1r ?ltr01 + ?ltrN10 ? ltr10 ? ltr0N1 ?addn0 ? addnS ?addn0//=; move => ->. +Qed. + +Lemma schange_odd p : p != 0 -> odd (schange p + (0 < lead_tail_coef p)%R). +Proof. +rewrite - lead_coef_eq0 /lead_tail_coef tail_coefE /schange lead_coefE nth_last. +by move => h; rewrite schange0_odd. +Qed. + +Lemma schange_cat l1 a l2: a != 0 -> + schange (l1++a::l2) = (schange (l1++[::a]) + schange (a::l2)) %N. +Proof. +move => anz. +rewrite /schange /filter0 filter_cat cats1 filter_rcons anz. +set w := [seq z <- a :: l2 | z != 0]. +elim [seq z <- l1 | z != 0]; first by rewrite /= mulr0 ltxx. +move => b l /= ->. rewrite - addnA. congr addn. +by rewrite -cats1 /w; case l => //=; rewrite anz. +Qed. + +Lemma schange_nz l i j: l`_i * l`_j < 0 -> (0 < (schange l))%N. +Proof. +move=> pn; move: (product_neg pn) => [xnz ynz]. +have aux: forall k, l`_k !=0 -> l`_k \in (filter0 l). + move => k kz; rewrite mem_filter kz /= mem_nth //. + by case (leqP (size l) k) => h //; move: kz;rewrite nth_default // eqxx. +move: pn (aux _ xnz) (aux _ ynz); set x := l`_i; set y := l`_j. +move: (filter_all (fun z => z!=0) l); rewrite /schange -/(filter0 l). +case (filter0 l) => //. +move => a l2 pa pb pc pd. +wlog : x y pb pc pd / a * x < 0. + move => H; case (ltrgt0P (a * x)) => h; try apply: (H x y pb pc pd h). + apply: (H y x) => //; [by rewrite mulrC | exact: (prodNsimpl_gt pb h)]. + move: pa => /= /andP [anz _]. + by move /eqP: h; rewrite mulf_eq0 (negbTE anz) (negbTE xnz). +move: pc; rewrite inE; case /orP. + by move /eqP <- => h; move: (lt_trans pb (prodNsimpl_lt pb h)); rewrite ltxx. +move: pa; clear; move:a x; elim l2 => //. +move => a l H b x /= /andP [bnz bl] ca bcn. +case (ltrgt0P (b * a)); last first. + by move /eqP; rewrite mulf_eq0 (negbTE bnz)=> /= ane; move: bl; rewrite ane. + move=> ->. + by rewrite add1n ltnS. +rewrite mulrC; move => ba; move: (prodNsimpl_gt bcn ba) => aca. +rewrite (ltNge (a * b)) (ltW ba) add0n. +apply: (H a x bl) => //; move: ca; rewrite inE; case /orP => // /eqP xa. +by move: (lt_trans bcn ba); rewrite xa mulrC ltxx. +Qed. + +Fixpoint schange_index_aux l i y := + if l is x::l' then + if (((y==0) && (x != 0)) || (x*y < 0)) then i :: schange_index_aux l' i.+1 x + else schange_index_aux l' i.+1 y + else [::]. + +Definition schange_index l := schange_index_aux l 0 0. + +Notation SIA := schange_index_aux. (* local short notation *) + +(** We study the sign change function *) + +Lemma schangei_addm l n m a: + SIA l (n+m)%N a = [seq (z+m)%N | z <- SIA l n a]. +Proof. +move: n a; elim: l => [ n z // | a l hrec n y /=]. +by case hyp: ((y == 0) && (a != 0) || (a * y < 0))=> //=; rewrite - addSn hrec. +Qed. + +Lemma schangei_s0 l1 l2: all_eq0 l1 -> + schange_index (l1 ++ l2) = SIA l2 (size l1) 0. +Proof. +elim l1 => // a l hrec /= /andP [/eqP -> /hrec]. +rewrite /schange_index /= mul0r eqxx ltxx andbF orbF. +by rewrite - addn1 - (addn1 (size l)) ! schangei_addm => <-. +Qed. + +Lemma schangeE l: (size (schange_index l)).-1 = (schange l). +Proof. +transitivity ((size (schange_index (filter (fun z => z != 0) l))).-1). + have aux: forall l, (all_eq0 l) -> filter (fun z => z != 0) l = [::]. + by elim => // a l' Hr /= /andP [-> /Hr ->]. + rewrite /schange; case alz: (all_eq0 l). + by rewrite (aux _ alz) - {1} (cats0 l) schangei_s0. + move: (negbT alz); rewrite - (has_predC) => /has_split_eq. + move => [l1 [b [l2 [-> pb pc]]]]; rewrite filter_cat aux //= pb. + rewrite schangei_s0 // /schange_index /= eqxx pb /=. + move: b (size l1).+1 1%N pb; elim: l2 => // a l' Hrec b n m bnz /=. + case (eqVneq a 0). + by move => ->; rewrite mul0r eqxx ltxx andbF /=; apply: Hrec. + move =>h; rewrite h /= (negbTE bnz) /=. + by case h':(a * b < 0); [ simpl; congr S |]; apply: Hrec. +move: (filter_all (fun z => z != 0) l); rewrite -/(filter0 l). +rewrite /schange; case (filter0 l) => // a s /= /andP [anz ar]. +rewrite /schange_index /SIA -/SIA eqxx anz andbT orTb /=. +move: 1%N a anz ar; elim:s; first by move => a n _ _ /=; rewrite mulr0 ltxx. +move => a s Hrec n b bnz /= /andP [anz ar]; rewrite mulrC anz (negbTE bnz) /=. +case h:(b * a < 0) => /=; rewrite Hrec // add0n. +have: (0 < b * a) by rewrite lt0r mulf_neq0 // leNgt h. +case (ltrgt0P a) => ap //; last by move: anz; rewrite ap eqxx. + by rewrite (pmulr_lgt0) // => bp; rewrite ! (pmulr_rlt0). +by rewrite (nmulr_lgt0) // => bp; rewrite ! (nmulr_rlt0). +Qed. + +Lemma schangei0 l: all_eq0 l <-> schange_index l = [::]. +Proof. +split; first by move /schangei_s0 => h; move: (h [::]); rewrite /= cats0. +suff: forall l n, SIA l n 0 = [::] -> all_eq0 l by apply. +elim => [ // | a l' hrec n]. +by rewrite /= eqxx mulr0 ltxx orbF andTb; case az: (a==0) => //= /hrec. +Qed. + +Lemma schangei_s0n l1 a l2: a !=0 -> all_eq0 l1 -> + schange_index (l1 ++a :: l2) = size l1 :: (SIA l2 (size l1).+1 a). +Proof. by move => anz alz; rewrite (schangei_s0 _ alz) /= eqxx anz. Qed. + +Lemma schangei_snn l i s: + schange_index l = i::s -> exists l1 a l2, + [/\ l = l1 ++a :: l2, a != 0, i = size l1, all_eq0 l1 & + SIA l2 (size l1).+1 a = s]. +Proof. +case alt: (all_eq0 l); first by move /schangei0:alt => -> //. +move: (allPn (negbT alt)) => /hasP /has_split_eq [l1 [a [l2 [ -> az al0]]]]. +rewrite (schangei_s0n _ az al0) => /eqP;rewrite eqseq_cons. +by move => /andP [/eqP <- /eqP <-];exists l1, a, l2. +Qed. + +Lemma schangei_reca a l n: a != 0 -> ((all_ss a l) = (SIA l n a == [::])). +Proof. +move => anz; move: n; elim: l => [// | b l h n]. +by rewrite /= (negbTE anz)/= (h n.+1) ltNge; case sab: (0 <= b * a). +Qed. + + +Lemma schangei_rec a l1 l2 n: a != 0 -> all_ss a l1 -> + SIA (l1++l2) n a = SIA l2 (n + size l1)%N a. +Proof. +move => anz; move: n; elim : l1;first by move =>n /=; rewrite addn0. +move =>b l hrec n /= /andP [pa pb]. +by rewrite ltNge pa (negbTE anz) /= (hrec _ pb) addnS addSn. +Qed. + +Lemma schangei_recb a l1 b l2 n: b * a < 0 -> all_ss a l1 -> + SIA (l1++ b::l2) n a = (n+size l1)%N :: SIA l2 (n + size l1).+1 b. +Proof. +move => h1 h2; move : (product_neg h1) => [bz az]. +by rewrite (schangei_rec _ _ az h2) /= bz h1 orbT. +Qed. + +Lemma schangei_recc a l i s n: a!= 0 -> + SIA l n a = i :: s -> exists l1 b l2, + [/\ l = l1 ++ b :: l2, b *a <0, b!= 0, (all_ss a l1) & + (i = n+size l1)%N /\ SIA l2 (n + size l1).+1 b = s]. +Proof. +move => anz;case alz: (all_ss a l). + by move: alz; rewrite (schangei_reca _ n anz) => /eqP ->. +move: (negbT alz); rewrite - (has_predC) => /has_split [l1 [b [l2 [-> pb pc]]]]. +move: pb => /=; rewrite - ltNge => abn. +case bz: (b!=0); last by move: abn; rewrite (eqP (negbFE bz)) mul0r ltxx. +have pc': all_ss a l1 by apply /allP => t /(allP pc) /= /negbNE. +rewrite (schangei_recb l2 n abn pc') => /eqP h. +by exists l1,b, l2; move: h; rewrite eqseq_cons => /andP [/eqP <- /eqP ->]. +Qed. + +Lemma schangei_tail l i s: + schange_index l = rcons s i -> exists l1 a l2, + [/\ l = l1 ++ a :: l2, (i <= size l1)%N, 0 < a * l`_i & all_eq0 l2]. +Proof. +move => h. +suff [l1 [a [l2 [-> pa pb pc]]]]: exists l1 (a : R) l2, + [/\ l = l1 ++ a :: l2, a != 0, i = size l1 & all_ss a l2]. + have:has (fun z => z != 0) (a::l2) by rewrite /= pa. + move /has_split_eq_rev => [la [b [lb [qa qb qc]]]]. + exists (l1++la),b, lb. + rewrite pb size_cat leq_addr nth_cat ltnn subnn /= qa catA; split => //. + have: b \in a :: l2 by rewrite qa mem_cat mem_head orbT. + rewrite lt0r (mulf_neq0 qb pa) /= in_cons =>/orP []; last by move /(allP pc). + by move /eqP => ->; rewrite sqr_ge0. +move: h;case: s. + move /schangei_snn => [l1 [a [l2 [ -> pb pc pd pe]]]]; exists l1, a, l2. + by split => //; move: pe => /eqP; rewrite -schangei_reca. +move => j s; move /schangei_snn => [l1 [a [l2 [-> pb pc _]]]] h. +suff [l0 [b [l3 [-> qb -> qd]]]]: exists l0 b l3, [/\ l2 = l0 ++ b :: l3, b !=0, + i = ((size l1).+1 + size l0)%N & all_ss b l3 ]. + by exists (l1++a::l0),b,l3; rewrite - catA cat_cons addSnnS size_cat //=. +move: l2 a pb (size l1).+1 h; clear; elim: s. + move => l b bnz n /= h. + move: (schangei_recc bnz h)=> [l1 [c [l2 [-> pa cz pb [pc pd]]]]]. + by exists l1,c,l2; split => //; move:pd => /eqP; rewrite - schangei_reca. +move => a l Hrec l2 b bnz n. +move /(schangei_recc bnz) => [l1 [c [l3 [-> pa cz pb [pc]]]]]. +move /(Hrec _ _ cz _) => [l0 [d [l4 [-> qa -> qc]]]]. +by exists ( l1 ++ c :: l0), d,l4; rewrite -catA cat_cons addSnnS size_cat addnA. +Qed. + +Lemma schangei_correct l (i : nat): + i \in schange_index l -> l`_i != 0 /\ l`_i * (0::l)`_i <= 0. +Proof. +move: {2 3} (schange_index l) (refl_equal (schange_index l)); case => //. +have aux: forall i l n a, + i \in SIA l n a -> exists2 j:nat, j \in SIA l 0 a & i = (j + n)%N. + by move => i' l' n a; rewrite -(add0n n) schangei_addm; move /mapP. +move => k s /schangei_snn [l1 [a [l2 [-> anz il1 l1z sv]]]]. +rewrite inE; case/ orP. + move /eqP ->; rewrite !nth_cat il1 ltnn subnn /=; split => //. + rewrite -cat_cons nth_cat /= ltnS leqnn -last_nth. + suff : (last 0 l1 == 0) by move => /eqP ->; rewrite mulr0. + by move: (mem_last 0 l1); rewrite inE => /orP; case => //; move /(allP l1z). +rewrite - sv => isv. +move : (aux i l2 (size l1).+1 a isv) => [j j2 j1]. +rewrite j1 addnC nth_cat - cat_cons nth_cat addSn - addnS ltnNge leq_addr /=. +rewrite addnC addnK /= addSn ltnNge ltnS leq_addl /= -addnS addnK. +move: j2; clear il1 l1z isv j1 sv k s l1 l i. +move: {1} 0%N {1} (SIA l2 0 a) (refl_equal (SIA l2 0 a)) => n s. +move:s l2 a n j anz; elim. + by move => l2 a n j _; rewrite -(add0n n) schangei_addm; case (SIA l2 0 a). +move => a s Hrec l b n j bnz => eq1;symmetry in eq1. +move: (schangei_recc bnz eq1)=> [l1 [c [l3 [pa pb cz pc [pd pe]]]]] => js. +have: (j + n)%N \in SIA l n b. + by rewrite-{2} (add0n n) schangei_addm; apply /mapP; exists j. +rewrite eq1 in_cons => /orP []. + rewrite pd addnC eqn_add2l => /eqP ->. + rewrite pa - cat_cons nth_cat ltnn subnn; split => //. + rewrite /= - (cat_cons) nth_cat /= ltnS leqnn -last_nth. + move: (mem_last b l1)=> /orP;case; first by move/eqP => ->;apply: ltW. + by rewrite mulrC; move/(allP pc); apply prodNsimpl_ge; rewrite mulrC. +rewrite - pe - addnS (addnC n) schangei_addm; move /mapP. +move => [j0 ka] /eqP; rewrite eqn_add2r => /eqP => ->. +move: ka; rewrite -(add0n (size l1).+1) schangei_addm => /mapP [k jv ->]. +symmetry in pe; move: (Hrec l3 c (n + size l1).+1 k cz pe jv). +rewrite pa - cat_cons ! nth_cat - addSnnS leqNgt ltnS leq_addl /=. +by rewrite addnK /= addSnnS leqNgt ltnS leq_addl /= addnK. +Qed. + +Lemma pol_mul_cs (p: {poly R}) (x: R): + p !=0 -> x > 0 -> ( (schange p) < (schange (p * ('X - x%:P))%R))%N. +Proof. +move => pnz xn. +set q := _ * _. +have spp: size p = (size p).-1.+1. + by move: pnz; rewrite -size_poly_eq0; case sz:(size p). +set s := (schange_index p). +have pa: forall k:nat, k \in s -> p`_k * q`_k < 0. + move => k ks. + move: (schangei_correct ks) => [eq1 eq2]. + have rhsp: 0 < p`_k * (p`_k * x) by rewrite mulrA pmulr_lgt0 // square_pos. + rewrite /q mulrBr coefB coefMC mulrBr subr_lt0 coefMX (le_lt_trans _ rhsp)//. + by move: eq2; case k. +have: schange_index p = s by []. +have lcpnz: lead_coef p != 0 by rewrite lead_coef_eq0. +have lpp: lead_coef p \in polyseq p by apply: mem_nth; rewrite {2} spp. +move: (eq_refl s); rewrite {1}/s; case s. + by move /eqP /schangei0 => ap; move:lcpnz; move /(allP ap): lpp => ->. +move => i l0 _ sv0. +have pb: 0 < p`_(last 0%N s) * q`_(size p). + have -> : q`_(size p) = lead_coef p. + move: (monicXsubC x) => mc; rewrite- (lead_coef_Mmonic p mc) lead_coefE. + by rewrite (size_Mmonic pnz mc) size_XsubC addn2. + move: (lastI i l0) lcpnz; rewrite - sv0 => sv1. + move:(schangei_tail sv1) => [l1 [a [l2 [pv sl1 pn]]]]. + have ->: last 0%N s = (last i l0) by rewrite /s sv1 last_rcons. + have: lead_coef p = last 0 p by rewrite (last_nth 0) spp. + rewrite pv last_cat last_cons; case l2. + move => /= ->; move: pn; rewrite pv - cat1s catA mulrC. + by rewrite (nth_cat 0 (l1 ++ [:: a])) size_cat addn1 ltnS sl1. + by move => b l anz lpv; rewrite (allP lpv) // anz /= mem_last. +have rec0: forall l1 l2, l2`_0 != 0 -> (schange (l2) <= schange (l1++l2))%N. + by move => l1; case => // a l2 /= anz; rewrite (schange_cat _ _ anz) leq_addl. +have ncat: forall l1 l2 b, (l1++l2)`_( (size l1) +b) = l2`_b. + by move=> l1 l2 b; rewrite nth_cat addKn -ltn_subRL subnn. +move: pa pb;rewrite -{1} schangeE /s sv0 /=. +move: sv0 => /schangei_snn [l1 [a [l2 [-> pa pb pc pd]]]] ha hb. +have he: (l1 ++ a :: l2)`_i = a by rewrite nth_cat pb ltnn subnn. +have skm: forall k, (l1 ++ a :: l2)`_(k + i) = (a::l2)`_k. + by move => k; rewrite addnC pb ncat. +have hc: a * q`_i < 0 by rewrite -he;apply: ha; rewrite mem_head. +have[l2a [l2b [l2v sl]]]: exists l2a l2b, l2a ++ l2b = q /\ size l2a = i. + exists (take i q), (drop i q); split; first by exact: cat_take_drop. + apply: size_takel; case /orP:(leq_total i (size q)) => //. + by move/(nth_default 0) => h; move: hc; rewrite h mulr0 ltxx. +move: (hc); rewrite -l2v nth_cat -sl ltnn subnn => hc'. +apply: (leq_trans _ (rec0 l2a l2b (proj2 (product_neg hc')))). +have sv:[seq (z + i)%N | z <- SIA l2 1 a] = l0 by rewrite pb -pd -schangei_addm. +have: forall k, k \in (SIA l2 1 a) -> (a::l2)`_(k-0)%N * l2b`_(k-0%N) < 0. + move => k ka; rewrite - skm subn0. + have ->: l2b`_k = q`_(k+i) by rewrite -l2v - sl addnC ncat. + by apply: ha;rewrite inE - sv (mem_map (@addIn i)) ka orbT. +have: 0 < (a :: l2)`_((last 0%N (SIA l2 1 a)) -0) * l2b`_(size l2).+1. + move: hb; rewrite -sv /= (last_map (fun z=> (z + i)%N) (SIA l2 1 a) 0%N). + by rewrite subn0 skm - l2v size_cat -pb - sl ncat. +rewrite - sv size_map. +move: rec0 ncat hc' pa; clear; move => rec0 ncat hc' pa. +move: {2 3 4 5} (SIA l2 1 a) pa (erefl (SIA l2 1 a)) hc'. +rewrite - (addn0 1%N); move: {2 4 5 6 7} 0%N. +move => n s; move: s a n l2 l2b; elim. + move => a n l l' _ anz pnz;set j := (size l).+1 %N. + rewrite /last subnn {1}/nth mulrC ; move => lt2 _. + move:(prodNsimpl_gt pnz lt2);apply: schange_nz. +move => i s Hrec a n l l' anz. +move /(schangei_recc anz)=> [l1 [b [l2 [-> pa pb pc [pd pe]]]]]. +move => qa qb qc /=. +have imn: (i - n = (size l1).+1) %N by rewrite pd addnAC add1n addnK. +have: (i\in i :: s) by rewrite mem_head. +move /qc; rewrite imn -cat1s catA nth_cat subnn ltnn - imn => e1. +set ni := (i - n )%N. +move: (cat_take_drop ni l'). +set l1' := take ni l'; set l2' := drop ni l' => e2. +have e3: size l1' = ni. + move: e1;rewrite size_take; case (leqP (size l') ni) => //. + by move/(nth_default 0) => ->; rewrite mulr0 ltxx. +move: (prodNsimpl_lt qa pa); rewrite mulrC => e4. +move: (prodNsimpl_gt e1 e4) => e5. +move: (proj2 (product_neg e5)); set w := l'`_ni => wnz. +have [u l2v]: exists u, l2' = w::u. + move: wnz;rewrite /w - e2 nth_cat e3 ltnn subnn. + case l2'; [ by rewrite eqxx | by move => a1 b1 _; exists b1]. +move: (schange_cat l1' u wnz); rewrite - l2v e2 => ->. +suff: ((size s) < schange l2')%N. + set l1'' := (l1' ++ [:: w]). + have : l1''`_0 * l1''`_ni < 0. + move: e5; rewrite -e2 l2v /l1'' !nth_cat e3 ltnn subnn; case i => //. + by move/schange_nz => e6 e7; move: (leq_add e6 e7); rewrite add1n. +clear u l2v. +have r0: b * l2'`_0 < 0 by move: e1; rewrite - e2 nth_cat e3 ltnn subnn. +move: pe; rewrite -pd - add1n => r1. +have r2 : (forall k, k \in s -> (b :: l2)`_(k - i) * l2'`_(k - i) < 0). + move => k ks; have: k \in i::s by rewrite inE ks orbT. + move: ks; rewrite -{1} r1 schangei_addm; move /mapP => [k' k'v kv]. + have ->: (k - i)%N = k' by rewrite kv addnK. + move/ qc; rewrite - e2 - cat1s catA. + have ->: (k - n = k' + (size l1).+1)%N. + by rewrite kv pd addnAC add1n addnA addnK. + by rewrite addnC ncat -imn -/ni -e3 ncat. +have r3: 0 < (b :: l2)`_(last i s - i) * l2'`_(size l2).+1. + move:qb; rewrite - e2 size_cat - addSn - imn -/ni -e3 ncat. + suff: ((last n (i :: s) - n) = ni + (last i s - i)) %N. + by move => ->; rewrite /ni imn - cat1s catA ncat. + have lni: (n<=i) %N by rewrite pd addnAC leq_addl. + rewrite -r1 schangei_addm; case (SIA l2 1 b); first by rewrite /= subnn addn0. + move => n0 l0 /=; set la := last _ _. + have eq1: (i <= la)%N. + by rewrite /la (last_map (fun z=> (z + i)%N)) leq_addl. + by rewrite - {1} (subnK eq1) - (addnBA _ lni) addnC. +exact: (Hrec b i l2 l2' pb r1 r0 r3 r2). +Qed. + +End SignChange. + +Section SignChangeRcf. +Variable R : rcfType. +Implicit Type p : {poly R}. + +Lemma noproots_cs p: (forall x, 0 ~~ root p x) -> 0 < lead_tail_coef p. +Proof. +move => h. +have [pz |pnz]:= (eqVneq p 0); first by move: (h _ ltr01); rewrite pz root0. +move: (mu_spec_supp pnz) => [q [pa pb pc pd pe]]. +have: {in `[0, +oo[, (forall x, ~~ root q x)}. + move=> x; rewrite in_itv/= andbT le0r; case/orP; first by move=>/eqP ->. + by move /h; rewrite pa rootM negb_or => /andP []. +move/sgp_pinftyP => ha; move: (ha 0). +rewrite in_itv/= lexx /= => H. +rewrite /lead_tail_coef pc pd pe - sgr_gt0 sgrM -/(sgp_pinfty q). +by rewrite - horner_coef0 - H // - sgrM sgr_gt0 lt0r sqr_ge0 mulf_neq0. +Qed. + +Definition fact_list p s q := + [/\ p = (\prod_(z <- s) ('X - z.1%:P) ^+ (z.2)) * q, + (all (fun z => 0 < z) [seq z.1 | z <- s]), + (sorted <%R [seq z.1 | z <- s]) & + (all (fun z => (0 (forall x, 0 ~~ root (sq.2) x)) + /\ (p = 0 -> sq.1 = [::] /\ sq.2 = 0)) }. +Proof. +case pnz: (p != 0); last first. + by exists ([::],p) => //; split => //; rewrite big_nil mul1r. +pose sa := [seq z <- rootsR p | 0 0 < z) [seq z.1 | z <- sb]). + by rewrite - sav; apply /allP => x; rewrite mem_filter => /andP []. +have pb : (sorted <%R [seq z.1 | z <- sb]). + rewrite -sav. + by apply: sorted_filter => //; [apply: lt_trans |apply: sorted_roots]. +have pc: (all (fun z => (0 x /mapP [t] /mapP [z]; rewrite mem_filter => /andP [z0 z2]. + move => -> -> /=; rewrite mu_gt0 //; apply: (root_roots z2). +suff: { q | p = (\prod_(z <- sa) ('X - z%:P) ^+ (\mu_z p)) * q & + forall x : R, 0 < x -> ~~ root q x}. + move => [q qa qb]; exists (sb,q) => //. + by split => //;rewrite qa /= big_map; congr (_ * _); apply eq_big. + by split => // pz; move: pnz; rewrite pz eqxx. +clear sb sav pa pb pc. +have: all (root p) sa. + apply/allP=> x;rewrite mem_filter =>/andP [_]; apply /root_roots. +have: uniq sa by apply:filter_uniq; apply: uniq_roots. +have: forall x, root p x -> 0 < x -> x \in sa. + by move=> x rx xp;rewrite mem_filter xp -(roots_on_rootsR pnz) rx. +move: sa=> s. +elim: s p pnz=>[p _ H _ _| ]. + exists p; first by by rewrite big_nil mul1r. + move => x xp;apply/negP =>nr; by move: (H _ nr xp). +move => a l Hrec /= p p0 rp /andP [nal ul] /andP [ap rap]. +have [q rqa pv] := (mu_spec a p0). +case q0: (q != 0); last by move:p0; rewrite pv (eqP(negbFE q0)) mul0r eqxx. +have q1 x: root q x -> 0 < x -> x \in l. + move=> rx xp; case xa: (x == a); first by rewrite -(eqP xa) rx in rqa. + by rewrite -[_ \in _]orFb -xa -in_cons rp // pv rootM rx. +have q2: all (root q) l. + apply/allP=> x xl. + case xa: (x ==a); first by move: nal; rewrite - (eqP xa) xl. + move /(allP rap): xl. + by rewrite pv rootM -[\mu__ _]prednK ?mu_gt0 // root_exp_XsubC xa orbF. +have [r qv rq]:= (Hrec q q0 q1 ul q2). +exists r => //; rewrite {1} pv {1} qv mulrAC; congr (_ * _). +rewrite big_cons mulrC; congr (_ * _). +rewrite (big_nth 0). +rewrite [in RHS](big_nth 0). +rewrite 2!big_mkord; apply: eq_bigr => i _. +set b := l`_i;congr (_ ^+ _). +have rb: root q b by apply /(allP q2); rewrite mem_nth //. +have nr: ~~ root (('X - a%:P) ^+ \mu_a p) b. + rewrite /root horner_exp !hornerE expf_neq0 // subr_eq0; apply /eqP => ab. + by move: rqa; rewrite - ab rb. +rewrite pv mu_mul ? (muNroot nr) // ?addn0//. +by rewrite mulf_neq0 // expf_neq0 // monic_neq0 // monicXsubC. +Qed. + +Definition pos_roots p := (s2val (poly_split_fact p)).1. +Definition pos_cofactor p := (s2val (poly_split_fact p)).2. +Definition npos_roots p := (\sum_(i <- (pos_roots p)) (i.2)) %N. + +Lemma pos_split1 p (s := pos_roots p) (q:= pos_cofactor p): + p != 0 -> [/\ fact_list p s q, (forall x, 0 ~~ root q x) & q != 0]. +Proof. +move => h; rewrite /s/q /pos_roots / pos_cofactor. +move: (poly_split_fact p) => H; move: (s2valP' H) (s2valP H) => [h1 _] h2. +split => //; first by apply: h1. +by apply/eqP => qz; move:h2 => [] pv; move: h; rewrite {1} pv qz mulr0 eqxx. +Qed. + + +Lemma monicXsubCe (c:R) i : ('X - c%:P) ^+ i \is monic. +Proof. apply:monic_exp; exact: monicXsubC. Qed. + +Lemma monic_prod_XsubCe I rI (P : pred I) (F : I -> R) (G : I -> nat): + \prod_(i <- rI | P i) ('X - (F i)%:P )^+ (G i) \is monic. +Proof. by apply: monic_prod => i _; exact: monicXsubCe. Qed. + +Lemma npos_root_parity p: p != 0 -> + odd (npos_roots p + (0< lead_tail_coef p)%R). +Proof. +move => pnz; move: (pos_split1 pnz) => [[pv pb pc] pd qp qnz]. +rewrite {2} pv;set r := \prod_(z <- _) _. +have rm: r \is monic by apply:monic_prod_XsubCe. +rewrite lead_tail_coefM (pmulr_lgt0 _ (noproots_cs qp)) /lead_tail_coef. +move: (refl_equal (sgr r`_0)); rewrite - {2} horner_coef0 horner_prod. +set X := \prod_(z <- _) _; have ->: X = \prod_(i <- pos_roots p) (- i.1)^+ i.2. + by apply: eq_big => // i _; rewrite horner_exp hornerXsubC sub0r. +have ->: Num.sg (\prod_(i <- pos_roots p) (- i.1) ^+ i.2) = + (-1) ^+ \sum_(i <- pos_roots p) (i.2). + move: pb; elim (pos_roots p) => [ _ | i rr /= Hr /andP [pa pb]]. + by rewrite !big_nil sgr1. + by rewrite !big_cons sgrM sgrX Hr // sgrN (gtr0_sg pa) exprD. +move => aux. +case (eqVneq r`_0 0) => nr0. + by move: aux; rewrite nr0 sgr0 => /eqP; rewrite eq_sym signr_eq0. +rewrite (eqP rm) mulr1 (tail_coef0b nr0) -sgr_gt0 aux - signr_odd signr_gt0. +by case h: (odd(npos_roots p)); [ rewrite addn0 | rewrite addn1 /= h]. +Qed. + +Lemma size_prod_XsubCe I rI (F : I -> R) (G : I -> nat) : + size (\prod_(i <- rI) ('X - (F i)%:P)^+ (G i)) = + (\sum_(i <- rI) (G i)).+1. +Proof. +elim: rI => [| i r /=]; rewrite ? big_nil ? size_poly1 // !big_cons. +rewrite size_monicM ? monicXsubCe ? monic_neq0 // ?monic_prod_XsubCe //. +by rewrite size_exp_XsubC => ->; rewrite addSn addnS. +Qed. + +Lemma schange_parity p: p != 0 -> odd (npos_roots p) = odd (schange p). +Proof. +move => pnz. +move: (npos_root_parity pnz) (schange_odd pnz). +case h: (0 < lead_tail_coef p)%R; last by rewrite !addn0 => ->. +by rewrite ! addn1 /= => /negbTE -> /negbTE ->. +Qed. + +Lemma descartes p: p != 0 -> + (odd (npos_roots p) = odd (schange p) /\ + ((npos_roots p) <= (schange p)) %N). +Proof. +move => pa; split; first by apply:schange_parity. +move: (pos_split1 pa); rewrite /npos_roots; move => [[p1 p2 p3 p4] p5 qnz]. +have [s [sa <- <-]]: exists s, [/\ (all [eta <%R 0] s), + size s = (\sum_(i <- pos_roots p) i.2)%N & + \prod_(z <- s) ('X - z%:P) * pos_cofactor p = p]. + rewrite {3}p1;move: p2;elim: (pos_roots p) => [_ | a l Hrec /= /andP [q1 q2]]. + by exists [::]; rewrite ! big_nil. + move: (Hrec q2) => [s [s1 s2 s3]]; exists ((nseq a.2 a.1) ++ s). + rewrite all_cat s1 ! big_cons -s2 size_cat size_nseq andbT; split => //. + have: all (pred1 a.1) (nseq a.2 a.1). + by rewrite all_pred1_nseq. + by move => h; apply /allP => x; move /(allP h) => /= /eqP ->//. + rewrite big_cat /= - ! mulrA -s3 ;congr ( _ * _). + rewrite (big_nth 0) big_mkord (eq_bigr (fun _ => ('X - a.1%:P)))=>[|[i]] /=. + by rewrite prodr_const card_ord size_nseq. + by rewrite size_nseq nth_nseq=> ->. +move: (pos_cofactor p) sa qnz ;clear; elim s; first by move => p _ pnz //. +move => a l Hrec p /= /andP [ap alp] pnz. +rewrite big_cons - mulrA mulrC; move: (Hrec _ alp pnz); set q := _ * _ => e1. +have qnz: q !=0 + by rewrite mulf_neq0 //; apply: monic_neq0; apply: monic_prod_XsubC. +exact (leq_ltn_trans e1 (pol_mul_cs qnz ap)). +Qed. + +End SignChangeRcf. diff --git a/theories/desc2.v b/theories/desc2.v new file mode 100644 index 0000000..0dc145e --- /dev/null +++ b/theories/desc2.v @@ -0,0 +1,601 @@ +From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype order. +From mathcomp Require Import binomial bigop ssralg poly ssrnum ssrint rat. + +From mathcomp Require Import polydiv polyorder path interval polyrcf. + +(** Descates method 2 *) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + + +Import Order.Theory GRing.Theory. +Import Num.Theory Num.Def. +Local Open Scope ring_scope. +(** ** Sign changes *) + +Section SignChange. + +Variable R :realDomainType. +Implicit Type l: (seq R). +Implicit Type p: {poly R}. + +Definition all_eq0 l := all (fun x => x == 0) l. +Definition all_ge0 l:= all (fun x => 0 <= x) l. +Definition all_le0 l := all (fun x => x <= 0) l. +Definition all_ss a l := all (fun x => 0 <= x * a) l. +Definition opp_seq l := [seq - z | z <- l]. +Definition filter0 l := [seq z <- l | z != 0]. + +(** Some helper lemmas *) + +(* TODO(rei): same as in desc1.v?! *) +Lemma product_neg (a b : R): a * b < 0 -> a != 0 /\ b != 0. +Proof. +case (eqVneq a 0) => [->|]; first by rewrite mul0r ltxx. +case (eqVneq b 0) => [->|] //; by rewrite mulr0 ltxx. +Qed. + +Lemma square_pos (a: R): a != 0 -> 0 < a * a. +Proof. by move => anz; rewrite lt0r sqr_ge0 sqrf_eq0 anz. Qed. + +Lemma prodNsimpl_ge (a b x: R): b * a < 0 -> 0 <= x * b -> x * a <= 0. +Proof. +move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. +by rewrite - (nmulr_lle0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lle0. +Qed. + +Lemma prodNsimpl_gt (a b x: R): b * a < 0 -> 0 < x * b -> x * a < 0. +Proof. +move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. +by rewrite - (nmulr_llt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_llt0. +Qed. + +Lemma prodNsimpl_lt (a b x: R): b * a < 0 -> x * b < 0 -> 0 < x * a. +Proof. +move => pa; move: (square_pos (proj1 (product_neg pa))) => pb. +by rewrite - (nmulr_lgt0 _ pa) mulrA - (mulrA _ _ b) mulrAC pmulr_lgt0. +Qed. + +Lemma all_rev l q: all q l = all q (rev l). +Proof. by elim:l => [// | a l hr]; rewrite rev_cons all_rcons /= hr. Qed. + +Lemma has_split q l: has q l -> + exists l1 a l2, [/\ l = l1 ++ a :: l2, q a & all (fun z => ~~(q z)) l1]. +Proof. +elim:l => // a l Hrec /=; case ha: (q a) => /=. + by move => _; exists [::], a, l; split => //. +move /Hrec => [l1 [b [l2 [-> pb pc]]]]. +by exists (a::l1),b,l2; split => //=; rewrite ha pc. +Qed. + +Lemma has_split_eq l: has (fun z => z != 0) l -> + exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l1]. +Proof. +move/has_split => [l1 [a [l2 [-> pa pb]]]]; exists l1,a,l2; split => //. +by apply /allP => x; move /(allP pb); case (x==0). +Qed. + +Lemma has_split_eq_rev l: has (fun z => z != 0) l -> + exists l1 a l2, [/\ l = l1 ++ a :: l2, a !=0 & all_eq0 l2]. +Proof. +have <- : (has (fun z : R => z != 0)) (rev l) = has (fun z : R => z != 0) l. + by elim:l => [// | a l hr]; rewrite rev_cons has_rcons /= hr. +move/has_split_eq => [l1 [a [l2 [lv pa pb]]]]; exists (rev l2),a,(rev l1). +by rewrite -(cat1s a) catA cats1 -rev_cons -rev_cat -lv revK /all_eq0 -all_rev. +Qed. + +Lemma opp_seqK l: opp_seq (opp_seq l) = l. +Proof. +by rewrite/opp_seq -map_comp; apply map_id_in => a /=; rewrite opprK. +Qed. + + + +Definition tail_coef p := p `_(\mu_0 p). +Definition lead_tail_coef p := (tail_coef p) * (lead_coef p). + +Lemma tail_coef0a p: ~~ (root p 0) -> tail_coef p = p`_0. +Proof. by move /muNroot; rewrite /tail_coef => ->. Qed. + +Lemma tail_coef0b p: p`_0 != 0 -> tail_coef p = p`_0. +Proof. rewrite - {1} horner_coef0; apply: tail_coef0a. Qed. + +Lemma tail_coefM (p q: {poly R}): + tail_coef (p*q) = (tail_coef p) * (tail_coef q). +Proof. +rewrite /tail_coef. +case pnz: (p!=0); last by rewrite (eqP(negbFE pnz)) mul0r mu0 coef0 mul0r. +case qnz: (q!=0); last by rewrite (eqP(negbFE qnz)) mulr0 mu0 coef0 mulr0. +rewrite (mu_mul 0 (mulf_neq0 pnz qnz)). +move: (mu_spec 0 pnz) (mu_spec 0 qnz); rewrite subr0. +set a := (\mu_0 p); set b:= (\mu_0 q); move => [pa v1 ->] [qa v2 ->]. +by rewrite mulrACA -exprD 3! coefMXn ! ltnn ! subnn - ! horner_coef0 hornerM. +Qed. + +Lemma lead_tail_coefM (p q: {poly R}): + lead_tail_coef (p*q) = (lead_tail_coef p) * (lead_tail_coef q). +Proof. by rewrite /lead_tail_coef -mulrACA -tail_coefM lead_coefM. Qed. + +Lemma lead_tail_coef_opp p: lead_tail_coef (- p) = (lead_tail_coef p). +Proof. +rewrite - mulrN1 lead_tail_coefM; set one := (X in _ * lead_tail_coef(X)). +suff : lead_tail_coef one = 1 by move ->; rewrite mulr1. +have ->: one = ((-1)%:P) by rewrite polyCN. +by rewrite /lead_tail_coef /tail_coef lead_coefC mu_polyC coefC mulN1r opprK. +Qed. + +Lemma mu_spec_supp p: p != 0 -> + exists q, [/\ p = q * 'X^ (\mu_0 p), (~~ root q 0), + lead_coef p = lead_coef q, tail_coef p = tail_coef q & + tail_coef q = q`_0]. +Proof. +move /(mu_spec 0) => [q pa]; set n := (\mu_0 p) => ->; exists q. +rewrite lead_coefM tail_coefM {1 2} subr0 (eqP (monicXn R n)) mulr1 /tail_coef. +by rewrite mu_exp mu_XsubC mul1n subr0 coefXn eqxx mulr1 (muNroot pa). +Qed. + +Lemma tail_coefE p: tail_coef p = (head 0 (filter0 p)). +Proof. +have [-> |] := (eqVneq p 0); first by rewrite /tail_coef mu0 coef0 polyseq0 /=. +move /(mu_spec_supp) => [q [pa pb pc pd pe]]; rewrite /filter0. +case (eqVneq q 0) => qnz; first by move: pb; rewrite qnz root0. +have q0nz: q`_0 != 0 by rewrite - horner_coef0. +rewrite pd pe pa polyseqMXn// -cat_nseq filter_cat (eq_in_filter (a2 := pred0)). + by rewrite filter_pred0 cat0s nth0; move: q0nz; case q; case => //= a l _ ->. +have /allP h: all (pred1 (0:R)) (nseq (\mu_0 p) 0). + by rewrite all_pred1_nseq. +by move => x /h /= ->. +Qed. + +Fixpoint changes (s : seq R) : nat := + (if s is a :: q then (a * (head 0 q) < 0)%R + changes q else 0)%N. +Definition schange (l: seq R) := changes (filter0 l). + +Lemma schange_sgr l: schange l = schange [seq sgr z | z <- l]. +Proof. +rewrite /schange /filter0 filter_map; set s1 := [seq z <- l | z != 0]. +set s := (filter (preim _ _)); have -> : s l = s1. + apply: eq_in_filter => x xl /=. + by rewrite sgr_def; case xz: (x!=0); rewrite ?mulr0n ?eqxx ?mulr1n ?signr_eq0. +elim: s1 => [ // | a l1 /= ->]; case l1 => /=; first by rewrite !mulr0. +by move => b l2; rewrite - sgrM sgr_lt0. +Qed. + +Lemma schange_deriv p (s := (schange p)) (s':= schange p^`()): + (s = s' \/ s = s'.+1). +Proof. +rewrite /s/s'. +have [-> | pnz] := (eqVneq p 0); first by rewrite deriv0; left. +move: pnz; rewrite - size_poly_gt0 => pz. +have eq: polyseq p = p`_0 :: behead p by move: pz; case p => q /=; case q => //. +have aux: forall i, p^`()`_i = (nth 0 (behead p)) i *+ i.+1. + by move => i; rewrite coef_deriv nth_behead. +rewrite schange_sgr (schange_sgr p^`()). +have <-: [seq Num.sg z | z <- (behead p)] = [seq Num.sg z | z <- p^`()]. + have aux1: size (behead p) = size p^`() by rewrite size_deriv {2} eq. + apply: (eq_from_nth (x0 :=0)); first by rewrite !size_map. + move => i; rewrite size_map => iz;rewrite (nth_map 0)// (nth_map 0) -?aux1//. + by rewrite coef_deriv nth_behead sgrMn mul1r. +rewrite eq /= /schange/filter0/filter;case h: (Num.sg p`_0 != 0); last by left. +simpl; case h': (_ < 0); [ by rewrite addSn; right | by left]. +Qed. + +Lemma schange0_odd l: last 0 l != 0 -> + odd (schange l + (0 < head 0 (filter0 l) * last 0 l)%R). +Proof. +rewrite /schange. +have -> : filter0 l = [seq z <- 0::l | z != 0]. + by rewrite /filter0 {2} /filter eqxx. +rewrite (lastI 0 l); set b := (last 0 l) => bnz; rewrite filter_rcons bnz. +set s := [seq z <- belast 0 l | z != 0]. +have: all (fun z => z != 0) s by apply : filter_all. +elim: s; first by rewrite /= mulr0 ltxx square_pos //. +move => c s /=; set C:= changes _; set d:= head 0 _ => hr /andP [cnz etc]. +have dnz: d != 0 by move: etc; rewrite /d; case s => // s' l' /= /andP []. +rewrite addnC addnA addnC; move: (hr etc). +rewrite -sgr_gt0 - (sgr_gt0 (c*b)) - sgr_lt0 ! sgrM. +rewrite /sgr - if_neg - (if_neg (c==0))- (if_neg (b==0)) bnz dnz cnz. +by case: (d<0); case: (b<0); case: (c<0); rewrite ?mulrNN ? mulr1 ?mul1r ?ltr01 + ?ltrN10 ? ltr10 ? ltr0N1 ?addn0 ? addnS ?addn0//=; move => ->. +Qed. + +Lemma schange_odd p: p != 0 -> odd (schange p + (0 < lead_tail_coef p)%R). +Proof. +rewrite - lead_coef_eq0 /lead_tail_coef tail_coefE /schange lead_coefE nth_last. +by move => h; rewrite schange0_odd. +Qed. +End SignChange. + + +Section SignChangeRcf. +Variable R :rcfType. +Implicit Type (p:{poly R}). + +(* TODO(rei): same as desc1.v?! *) +Lemma noproots_cs p: (forall x, 0 ~~ root p x) -> 0 < lead_tail_coef p. +Proof. +move => h. +have [pz |pnz]:= (eqVneq p 0); first by move: (h _ ltr01); rewrite pz root0. +move: (mu_spec_supp pnz) => [q [pa pb pc pd pe]]. +have: {in `[0, +oo[, (forall x, ~~ root q x)}. + move=> x; rewrite in_itv/= andbT le0r; case/orP; first by move=>/eqP ->. + by move /h; rewrite pa rootM negb_or => /andP []. +move/sgp_pinftyP => ha; move: (ha 0). +rewrite in_itv/= lexx /= => H. +rewrite /lead_tail_coef pc pd pe - sgr_gt0 sgrM -/(sgp_pinfty q). +by rewrite - horner_coef0 - H // - sgrM sgr_gt0 lt0r sqr_ge0 mulf_neq0. +Qed. + +Definition fact_list p s q := + [/\ p = (\prod_(z <- s) ('X - z.1%:P) ^+ (z.2)) * q, + (all (fun z => 0 < z) [seq z.1 | z <- s]), + (sorted <%R [seq z.1 | z <- s]) & + (all (fun z => (0 (forall x, 0 ~~ root (sq.2) x)) + /\ (p = 0 -> sq.1 = [::] /\ sq.2 = 0)) }. +Proof. +case pnz: (p != 0); last first. + by exists ([::],p) => //; split => //; rewrite big_nil mul1r. +pose sa := [seq z <- rootsR p | 0 a. +have pa: (all (fun z => 0 < z) [seq z.1 | z <- sb]). + by rewrite - sav; apply /allP => x; rewrite mem_filter => /andP []. +have pb : (sorted <%R [seq z.1 | z <- sb]). + rewrite - sav. + by apply: sorted_filter => //; [apply: lt_trans |apply: sorted_roots]. +have pc: (all (fun z => (0 x /mapP [t] /mapP [z]; rewrite mem_filter => /andP [z0 z2]. + move => -> -> /=; rewrite mu_gt0 //; apply: (root_roots z2). +suff: { q | p = (\prod_(z <- sa) ('X - z%:P) ^+ (\mu_z p)) * q & + forall x : R, 0 < x -> ~~ root q x}. + move => [q qa qb]; exists (sb,q) => //. + split => //;rewrite qa /= big_map; congr (_ * _); apply eq_big. + by split => // pz; move: pnz; rewrite pz eqxx. +clear sb sav pa pb pc. +have: all (root p) sa. + apply/allP=> x;rewrite mem_filter =>/andP [_]; apply /root_roots. +have: uniq sa by apply:filter_uniq; apply: uniq_roots. +have: forall x, root p x -> 0 < x -> (x \in sa). + by move=> x rx xp;rewrite mem_filter xp -(roots_on_rootsR pnz) rx. +move: sa=> s. +elim: s p pnz=>[p _ H _ _| ]. + exists p; first by by rewrite big_nil mul1r. + move => x xp;apply/negP =>nr; by move: (H _ nr xp). +move => a l Hrec /= p p0 rp /andP [nal ul] /andP [ap rap]. +have [q rqa pv] := (mu_spec a p0). +case q0: (q != 0); last by move:p0; rewrite pv (eqP(negbFE q0)) mul0r eqxx. +have q1 x: root q x -> 0 < x -> x \in l. + move=> rx xp; case xa: (x == a); first by rewrite -(eqP xa) rx in rqa. + by rewrite -[_ \in _]orFb -xa -in_cons rp // pv rootM rx. +have q2: all (root q) l. + apply/allP=> x xl. + case xa: (x ==a); first by move: nal; rewrite - (eqP xa) xl. + move /(allP rap): xl. + by rewrite pv rootM -[\mu__ _]prednK ?mu_gt0 // root_exp_XsubC xa orbF. +have [r qv rq]:= (Hrec q q0 q1 ul q2). +exists r => //; rewrite {1} pv {1} qv mulrAC; congr (_ * _). +rewrite big_cons mulrC; congr (_ * _). +rewrite (big_nth 0). +rewrite [RHS](big_nth 0). +rewrite 2! big_mkord; apply: eq_bigr => i _. +set b := l`_i;congr (_ ^+ _). +have rb: root q b by apply /(allP q2); rewrite mem_nth //. +have nr: ~~ root (('X - a%:P) ^+ \mu_a p) b. + rewrite /root horner_exp !hornerE expf_neq0 // subr_eq0; apply /eqP => ab. + by move: rqa; rewrite - ab rb. +rewrite pv mu_mul ? (muNroot nr) // ?addn0//. +by rewrite mulf_neq0 // expf_neq0 // monic_neq0 // monicXsubC. +Qed. + +Definition pos_roots p := (s2val (poly_split_fact p)).1. +Definition pos_cofactor p := (s2val (poly_split_fact p)).2. +Definition npos_roots p := (\sum_(i <- (pos_roots p)) (i.2))%N. + +Lemma pos_split1 p (s := pos_roots p) (q:= pos_cofactor p): + p != 0 -> [/\ fact_list p s q, (forall x, 0 ~~ root q x) & q != 0]. +Proof. +move => h; rewrite /s/q /pos_roots / pos_cofactor. +move: (poly_split_fact p) => H; move: (s2valP' H) (s2valP H) => [h1 _] h2. +split => //; first by apply: h1. +by apply/eqP => qz; move:h2 => [] pv; move: h; rewrite {1} pv qz mulr0 eqxx. +Qed. + +Lemma monicXsubCe (c:R) i : ('X - c%:P) ^+ i \is monic. +Proof. apply:monic_exp; exact: monicXsubC. Qed. + +Lemma monic_prod_XsubCe I rI (P : pred I) (F : I -> R) (G : I -> nat): + \prod_(i <- rI | P i) ('X - (F i)%:P )^+ (G i) \is monic. +Proof. by apply: monic_prod => i _; exact: monicXsubCe. Qed. + +Lemma npos_root_parity p: p != 0 -> + odd (npos_roots p + (0< lead_tail_coef p)%R). +Proof. +move => pnz; move: (pos_split1 pnz) => [[pv pb pc] pd qp qnz]. +rewrite {2} pv;set r := \prod_(z <- _) _. +have rm: r \is monic by apply:monic_prod_XsubCe. +rewrite lead_tail_coefM (pmulr_lgt0 _ (noproots_cs qp)) /lead_tail_coef. +move: (refl_equal (sgr r`_0)); rewrite - {2} horner_coef0 horner_prod. +set X := \prod_(z <- _) _; have ->: X = \prod_(i <- pos_roots p) (- i.1)^+ i.2. + by apply: eq_big => // i _; rewrite horner_exp hornerXsubC sub0r. +have ->: Num.sg (\prod_(i <- pos_roots p) (- i.1) ^+ i.2) = + (-1) ^+ \sum_(i <- pos_roots p) (i.2). + move: pb; elim (pos_roots p) => [ _ | i rr /= Hr /andP [pa pb]]. + by rewrite !big_nil sgr1. + by rewrite !big_cons sgrM sgrX Hr // sgrN (gtr0_sg pa) exprD. +move => aux. +case (eqVneq r`_0 0) => nr0. + by move: aux; rewrite nr0 sgr0 => /eqP; rewrite eq_sym signr_eq0. +rewrite (eqP rm) mulr1 (tail_coef0b nr0) -sgr_gt0 aux - signr_odd signr_gt0. +by case h: (odd(npos_roots p)); [ rewrite addn0 | rewrite addn1 /= h]. +Qed. + +Lemma size_prod_XsubCe I rI (F : I -> R) (G : I -> nat) : + size (\prod_(i <- rI) ('X - (F i)%:P)^+ (G i)) = + (\sum_(i <- rI) (G i)).+1. +Proof. +elim: rI => [| i r /=]; rewrite ? big_nil ? size_poly1 // !big_cons. +rewrite size_monicM ? monicXsubCe ? monic_neq0 // ?monic_prod_XsubCe //. +by rewrite size_exp_XsubC => ->; rewrite addSn addnS. +Qed. + +Lemma schange_parity p: p != 0 -> odd (npos_roots p) = odd (schange p). +Proof. +move => pnz. +move: (npos_root_parity pnz) (schange_odd pnz). +case h: (0 < lead_tail_coef p)%R; last by rewrite !addn0 => ->. +by rewrite ! addn1 /= => /negbTE -> /negbTE ->. +Qed. + +Lemma pos_split_deg p: p != 0 -> + size p = ((npos_roots p) + (size (pos_cofactor p))) %N. +Proof. +move /pos_split1 => [[pa _ _ ] _ _ pb]. +by rewrite {1} pa size_monicM // ? monic_prod_XsubCe // size_prod_XsubCe addSn. +Qed. + + +Lemma npos_roots0 p: (p != 0 /\ p^`() != 0) \/ (npos_roots p = 0)%N. +Proof. +case (eqVneq p 0) => pnz. + right; rewrite /npos_roots /pos_roots. + move: (poly_split_fact p) => H; move: (s2valP' H) (s2valP H) => [_ h1] _. + by rewrite (proj1 (h1 pnz)) // big_nil. +move: (pos_split1 pnz) => [[pa pb pc pd] pe pf]. +case (leqP (size p) 1%N) => sp; [right | left]. + move: pf sp; rewrite (pos_split_deg pnz) - size_poly_gt0. + case: (size (pos_cofactor p)) => //. + by move => m _; rewrite addnS ltnS leqn0 addn_eq0 => /andP [/eqP -> _]. +split => //. +by rewrite -size_poly_eq0 (size_deriv p); move: sp;case: (size p)=> //; case. +Qed. + +Lemma coprimep_prod p I l (F: I-> {poly R}): + (all (fun z => coprimep p (F z)) l) -> coprimep p (\prod_(z <- l) (F z)). +Proof. +elim l; first by rewrite big_nil /= coprimep1. +by move => b m Hrec /andP [ap /Hrec]; rewrite big_cons coprimepMr ap => ->. +Qed. + +Lemma Gauss_dvdp_prod p (I:eqType) (l: seq I) (F: I-> {poly R}): + (all (fun i => (F i) %| p) l) -> + (uniq [seq F i | i <- l]) -> + (forall i j, i \in l -> j \in l -> (i == j) || coprimep (F i) (F j)) -> + \prod_(i <- l) (F i) %| p. +Proof. +move: p; elim: l. + by move => p _ _ _; rewrite big_nil dvd1p. +move => a l Hrec p /= /andP [ap dr] /andP [al ul] etc. +have aa: coprimep (F a) (\prod_(j <- l) F j). + apply: coprimep_prod; apply /allP => x xl. + have xal: x \in a :: l by rewrite inE xl orbT. + have aa: F x \in [seq F i | i <- l] by apply/mapP; exists x. + by move: al;case/orP: (etc _ _ (mem_head a l) xal)=> // /eqP ->; rewrite aa. +rewrite big_cons Gauss_dvdp // ap /= Hrec // => i j il jl. +by apply: etc; rewrite inE ? il ? jl orbT. +Qed. + +Lemma Gauss_dvdp_prod2 p (l: seq (R * nat)): + (all (fun z => ('X - z.1%:P)^+ (z.2) %| p) l) -> + (uniq [seq z.1 | z <- l]) -> + \prod_(i <- l) ('X - i.1%:P)^+ (i.2) %| p. +Proof. +move => pa pb. +set l2:= [seq z <- l | z.2 != 0%N]. +have qc: all (fun z => z.2 !=0%N) l2 by apply: filter_all. +have qa:all (fun z => ('X - (z.1)%:P) ^+ z.2 %| p) l2. + by apply /allP => x; rewrite mem_filter => /andP [_] /(allP pa). +have qb: uniq [seq z.1 | z <- l2]. + move: pb;rewrite /l2; elim l => [|x s IHs] //= /andP [Hx Hs]. + case (x.2 == 0%N); rewrite /= IHs // andbT; apply /negP. + move /mapP => [y]; rewrite mem_filter => /andP [_ ys] xy. + move: Hx; rewrite xy; move/negP;case; apply /mapP; exists y => //. +have ->: \prod_(i <- l) ('X - (i.1)%:P) ^+ i.2 = + \prod_(i <- l2) ('X - (i.1)%:P) ^+ i.2. + rewrite big_filter [X in _ = X] big_mkcond /=; apply: eq_bigr => i _. + by case h: (i.2 == 0%N) => //=; rewrite (eqP h) expr0. +apply:Gauss_dvdp_prod => //. + rewrite map_inj_in_uniq. apply: (map_uniq qb). + move => i j il jl /= eq1. + rewrite (surjective_pairing i) (surjective_pairing j). + move: (size_exp_XsubC i.2 (i.1)); rewrite eq1 size_exp_XsubC. + move /eq_add_S => ->. + have: root (('X - (i.1)%:P) ^+ i.2) (i.1). + move: (allP qc _ il); rewrite -lt0n => /prednK <-. + by rewrite root_exp_XsubC eqxx. + rewrite eq1; move: (allP qc _ jl); rewrite -lt0n => /prednK <-. + by rewrite root_exp_XsubC => /eqP ->. +move => i j il2 jl2. +pose zz:(R * nat) := (0, 0%N). +move: (nth_index zz il2)(nth_index zz jl2). +move: il2 jl2; rewrite -(index_mem) -(index_mem). +set i1 := index i l2; set j1 := index j l2 => ra rb rc rd. +set l3 := [seq z.1 | z <- l2]. +have ss: size l2 = size l3 by rewrite /l3 size_map. +move: (ra) (rb);rewrite ss => ra' rb'. +move: (nth_uniq 0 ra' rb' qb) => aux. +case eqq: (i1 == j1). by rewrite - rc - rd (eqP eqq) eqxx. +apply /orP; right. +rewrite coprimep_expl // coprimep_expr // coprimep_XsubC root_XsubC. +by rewrite - rc - rd -(nth_map zz 0) // -(nth_map zz 0) // -/l3 eq_sym aux eqq. +Qed. + +Lemma sorted_prop (s: seq R) i j: sorted <%R s -> + (i < size s)%N -> (j < size s)%N -> (i < j)%N -> s`_i < s`_j. +Proof. +move: i j; elim: s => // a l Hrec i j /= pal; case: i; last first. + move => i il; case: j => // j jl /=; rewrite ltnS; apply: Hrec => //. + apply: (path_sorted pal). +clear Hrec; case: j => // j _ jl _;move: a j jl pal. +elim:l => // a l Hrec b j /=;case: j => [_ | j jl]; move /andP => [pa pb] //=. +by apply:(lt_trans pa); apply /Hrec. +Qed. + +Lemma pos_root_deriv p: ((npos_roots p) <= (npos_roots p^`()).+1) %N. +Proof. +case (npos_roots0 p); last by move => ->. +move => [pnz dnz]. +move: (pos_split1 pnz) => [[pa pb pc pd] pe pf]. +set s := pos_roots p; set q := pos_cofactor p. +move: (erefl (pos_roots p)); rewrite -{2} /s; case s. + by rewrite /npos_roots;move => ->; rewrite big_nil. +move=> a l eq1. +set r:= [seq z.1 | z <- s]; set r1:= a.1; set rs:= [seq z.1 | z <- l]. +set rd:= [seq z.2 | z <- pos_roots p]. +have ss: size s = (size l).+1 by rewrite /s eq1. +pose zz:(R * nat) := (0, 0%N). +have p0: forall i, (i < size s)%N -> (nth zz s i).2 \in rd. + move => i qis; apply /mapP; exists (nth zz s i)=> //. + by apply /(nthP zz); exists i. +have p1: forall i: 'I_(size l)%N, + {c : R | c \in `] ((r1::rs)`_i), (rs`_i)[ & (p^`()).[c] = 0}. + move: pc;rewrite eq1 /=; move /(pathP 0); rewrite size_map => h. + move => [i isl]; move: (h _ isl); rewrite -/r1 -/rs => lt1. + have ha: forall j, (j< size s)%N -> (root p (r1 :: rs)`_j). + move => j js; rewrite pa rootM /root horner_prod; apply /orP; left. + rewrite (big_nth zz) big_mkord -/s (bigD1 (Ordinal js)) //= {1} /s eq1 /=. + rewrite horner_exp hornerXsubC -(nth_map _ 0) /= -?ss // subrr expr0n. + by rewrite (gtn_eqF (allP pd _ (p0 _ js))) mul0r eqxx. + have rp: p.[(a.1 :: rs)`_i] = p.[rs`_i]. + have ->: rs`_i = (r1 :: rs)`_(i.+1) by []. + by rewrite (eqP (ha _ _ )) ? (eqP (ha _ _ )) //; rewrite ss ltnS // ltnW. + exact: (rolle lt1 rp). +set l2 := [seq (s2val (p1 i), 1%N) | i <- (enum 'I_(size l)) ]. +set l3 := [seq (z.1, z.2.-1) | z <- pos_roots p]. +set f2 := \prod_(z <- l2) ('X - (z.1)%:P) ^+ (z.2). +set f3 := \prod_(z <- l3) ('X - (z.1)%:P) ^+ (z.2). +have p2: forall t, (t < size s)%N -> (r1 :: rs)`_t = (nth zz s t).1. + by move => t ts; rewrite - (nth_map zz 0) // /s eq1. +have ->: (npos_roots p = (\sum_(i <- l2++l3)i.2).+1)%N. + rewrite big_cat - addSn /l3 /l2 ! big_map sum1_card cardE size_enum_ord - ss. + rewrite - (sum1_size s) -/s - big_split /=. + rewrite /npos_roots ! (big_nth zz) ! big_mkord; apply: eq_bigr. + by move => [i iv] _; rewrite add1n (prednK (allP pd _ (p0 _ iv))). +have p4: (all (fun z => 0 < z) [seq z0.1 | z0 <- l2 ++ l3]). + have aa: forall t, t \in s -> 0 < t.1. + by move => t ts; apply: (allP pb); apply /mapP; exists t. + apply /allP => x /mapP [y]; rewrite mem_cat => /orP []; last first. + by move/mapP => [t /aa h -> ->]. + move/mapP => [t] _ -> -> /=; move: (s2valP (p1 t)). + rewrite itv_boundlr => /= /andP [lt1 _]; apply: lt_trans lt1. + have ts: (t < size s)%N by rewrite /s eq1 /= ltnS ltnW. + by rewrite (p2 _ ts); apply: aa;rewrite mem_nth. +have pcc: forall i j, (i (j (nth zz s i).1 < (nth zz s j).1 -> (i < j)%N. + move => i j il jl;case (ltngtP j i) => //; last by move => ->; rewrite ltxx. + rewrite - (lt_asym (nth zz s i).1 (nth zz s j).1); move => ij -> /=. + move: pc;rewrite -p2 // - p2 // eq1; set s1 := [seq z.1 | z <- a::l] => ha. + have ss1 : size s = size s1 by rewrite /s1 ss size_map. + rewrite ss1 in il jl; exact: (sorted_prop ha jl il ij). +have p5: f3 %| p^`(). + apply:Gauss_dvdp_prod2. + apply /allP => x /mapP [y ys -> /=]. + have: (('X - (y.1)%:P) ^+ y.2) %| p. + rewrite pa; apply:dvdp_mulr. + move: (nth_index zz ys) => h; move: ys; rewrite - index_mem => ys. + by rewrite (big_nth zz) big_mkord (bigD1 (Ordinal ys)) //= h dvdp_mulIl. + move /dvdpP => [q1 ->]; rewrite derivM; apply:dvdp_add;apply:dvdp_mull. + set e := y.2; case e => // n /=; rewrite exprS; apply : dvdp_mulIr. + rewrite deriv_exp - mulrnAl; apply : dvdp_mulIr. + rewrite /l3 -/s -map_comp. + apply: sorted_uniq. + exact: lt_trans. + exact: ltxx. + by apply: pc. +have xx: forall i: 'I_ (size l), + [/\ (i <= size l)%N, (i < size s)%N & (i.+1 < size s)%N]. + by move => i; rewrite ss !ltnS ltnW. +have p6: f2 %| p^`(). + apply:Gauss_dvdp_prod2. + apply/allP => x /mapP [t] _ -> /=; move: (s2valP' (p1 t)). + by rewrite dvdp_XsubCl /root=> ->; rewrite eqxx. + have ->:[seq z.1 | z <- l2] = [seq s2val (p1 i)| i <- enum 'I_(size l)]. + by rewrite /l2 - map_comp. + rewrite map_inj_uniq; first by apply: enum_uniq. + move => i j /= h. + move: (xx i) (xx j)=> [isl1 isl isl2] [jsl1 jsl jsl2]. + apply: val_inj => /=; apply: anti_leq. + move: (s2valP (p1 i)) (s2valP (p1 j)); rewrite !itv_boundlr => /=. + rewrite h; move/andP => [lt1 lt2] /andP [lt3 lt4]. + move: (lt_trans lt1 lt4) (lt_trans lt3 lt2). + have ->: rs`_i = (r1 :: rs)`_(i.+1) by []. + have ->: rs`_j = (r1 :: rs)`_(j.+1) by []. + rewrite !p2 // ? ss ? ltnS //. + move /(pcc _ _ isl jsl2) => sa /(pcc _ _ jsl isl2). + by rewrite ltnS => ->; rewrite -ltnS sa. +have p7: coprimep f2 f3. + apply: coprimep_prod; apply /allP => x xl3. + rewrite coprimep_sym; apply /coprimep_prod; apply /allP => y yl2. + apply:coprimep_expl; apply: coprimep_expr. + rewrite coprimep_XsubC root_XsubC; apply /negP => /eqP. + move: xl3 => /mapP [k ks] -> /=. + rewrite - (nth_index zz ks) -/s; set kis := (index k s). + move: yl2; move /mapP => [i] _ -> /= h1. + move: (s2valP (p1 i)); rewrite !itv_boundlr => /=; rewrite h1; clear h1. + have ->: rs`_i = (r1 :: rs)`_(i.+1) by []. + move: (xx i) => [il0 il1 il2]. + have il3: (kis < size s)%N by rewrite index_mem. + rewrite ! p2 // => /andP [la lb]. + move: (pcc _ _ il1 il3 la) (pcc _ _ il3 il2 lb). + by rewrite ltnS => lc ld; move: (leq_trans lc ld); rewrite ltnn. +have : (f2 * f3) %| p^`() by rewrite Gauss_dvdp // p6 p5. +move /dvdpP => [q1]; rewrite mulrC => sd. +have sa: p^`() = \prod_(z <- l2++l3) ('X - (z.1)%:P) ^+ z.2 * q1. + by rewrite big_cat. +move: (pos_split1 dnz) => [[qa qb qc qd] qe qf]. +set Fa := \prod_(z <- l2 ++l3) ('X - (z.1)%:P) ^+ z.2. +set Fb := \prod_(z <- pos_roots p^`()) ('X - (z.1)%:P) ^+ z.2. +set q2:= pos_cofactor p^`(). +have Fbm: Fb \is monic by apply:monic_prod_XsubCe. +suff cp: coprimep Fa q2. + move: (Gauss_dvdpl Fb cp); rewrite - qa {1} sa dvdp_mulIl => h. + move: (dvdp_leq (monic_neq0 Fbm) (esym h)). + by rewrite /npos_roots ! size_prod_XsubCe. +rewrite/Fa coprimep_sym;apply/coprimep_prod /allP => x xl. +rewrite coprimep_expr// coprimep_XsubC qe //. +by apply (allP p4); apply /mapP; exists x. +Qed. + +Lemma descartes_bis p: p != 0 -> + (odd (npos_roots p) = odd (schange p) /\ + ((npos_roots p) <= (schange p)) %N). +Proof. +move => pa; split; first by apply:schange_parity. +move: p {2}(size p) (leqnn (size p)) pa => p n; move:p; elim:n. + by move => p;rewrite size_poly_leq0 => ->. +move => n Hrec p spn pnz. +move: (schange_parity pnz) => od. +case (npos_roots0 p); [move => [_ dnz] | by move => ->]. +move: (leq_trans (lt_size_deriv pnz) spn); rewrite ltnS=> spln. +move:(Hrec _ spln dnz); rewrite - ltnS => /(leq_trans (pos_root_deriv p)) eq3. +move: od; case (schange_deriv p); move => -> //; move: eq3;set s := schange _. +by rewrite leq_eqVlt ltnS;case /orP => // /eqP -> /=;case (odd _). +Qed. + +End SignChangeRcf. diff --git a/theories/door_crossing.v b/theories/door_crossing.v new file mode 100644 index 0000000..7067e18 --- /dev/null +++ b/theories/door_crossing.v @@ -0,0 +1,1133 @@ +From HB Require Import structures. +From mathcomp Require Import all_ssreflect all_algebra all_real_closed archimedean reals. +From mathcomp.algebra_tactics Require Import ring lra. +Require Import casteljau convex counterclockwise intersection. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import Order.Theory. +Import GRing.Theory. +Import Num.Theory Num.Def. +Local Open Scope ring_scope. + +Section sandbox. + +Lemma poly_coord {R : rcfType} + (c : (R^o * R^o)%type) + (p : {poly R}) (t : R) : + p.[t] *: c = c.1 * p.[t] *: (1, 0) + c.2 * p.[t] *: (0, 1). +Proof. +congr (_, _); rewrite /= !scaler0 ?addr0 ?add0r mulrC /GRing.scale /=; ring. +Qed. + +Variable R : reals.Real.type. + +(* This version differs from the one in the hulls development to avoid + using Program Fixpoint. Here the sequence of control point is given + by a function and the degree is given as argument. *) +Fixpoint bezier (c : nat -> Plane R) (n : nat) (t : R) := + match n with + | 0 => c 0%N + | S p => (1 - t) *: (bezier c p t) + + t *: (bezier (c \o S) p t) + end. + +Definition f3pt (a b c : Plane R) := + [fun n : nat => a with 1%nat |-> b, 2%nat |-> c]. + +Lemma bezier_step_conv c n t : + bezier c (S n) t = + bezier (c \o S) n t <| t |> bezier c n t. +Proof. by rewrite /= /conv addrC. Qed. + +(* TODO: complain about the wrong error message for the following mistake. *) +(* Lemma bezier_bernstein2 c t : + bezier c 2 t = (bernp 0 1 2 0) *: c 0%N. *) + +Lemma bezier_bernstein2 c t : + bezier c 2 t = + \sum_(i < 3) (bernp 0 1 2 i).[t] *: c i. +Proof. +rewrite !big_ord_recr big_ord0 /= add0r. +rewrite /= scalerDr scalerA -!addrA; congr (_ *: _ + _). + by rewrite /bernp !hornerE /= subr0 expr1n invr1; ring. +rewrite !(scalerA, scalerDr) addrA -scalerDl; congr (_ *:_ + _ *: _). + by rewrite /bernp !hornerE /= subr0 expr1n invr1; ring. +by rewrite /bernp !hornerE /= subr0 expr1n invr1; ring. +Qed. + +(* The proofs of these lemmas follow a general pattern explained in file + casteljau. However, here, we can brute force the proof because we are + working with a known low degree. *) +Lemma bezier2_dichotomy_l (c : nat -> Plane R) (t u : R) : + bezier c 2 (t * u) = + bezier (f3pt (c 0%nat) (bezier c 1 u) (bezier c 2 u)) 2 t. +Proof. +rewrite /bezier /= !scalerDr !scalerA !addrA. +(* Make sure all instance of c 0 are grouped on the left and c 0 is + factored out. *) +rewrite !(addrAC _ (_ *: c (S O)) (_ *: c O)) -!scalerDl. +rewrite -!addrA; congr (_ *: _ + _); first by ring. +(* Now factor out all instances of c 1. *) +rewrite !addrA -!scalerDl; congr (_ *: _ + _ *: _); ring. +Qed. + +Lemma bezier2_dichotomy_r (c : nat -> Plane R) (t u : R) : + bezier c 2 (u + t * (1 - u)) = + bezier (f3pt (bezier c 2 u) (bezier (c \o S) 1 u) (c 2%nat)) 2 t. +Proof. +rewrite /bezier /= !scalerDr !scalerA !addrA. +(* There is only one instance of c 0 on the left, we can process it directly *) +rewrite -!addrA; congr (_ *: _ + _); first by ring. +rewrite !addrA -!scalerDl. +rewrite !(addrAC _ (_ *: c (S (S _))) (_ *: c (S O))) -!scalerDl. +rewrite -!addrA -!scalerDl. +congr (_ *: _ + _ *: _); ring. +Qed. + +Record edge := Bedge + { left_pt : Plane R; + right_pt : Plane R; + edge_cond : left_pt.1 < right_pt.1}. + +Record cell := + { left_pts : seq (Plane R); + right_pts : seq (Plane R); + low : edge; high : edge}. + +Definition valid_edge : edge -> Plane R -> bool := + fun g p => (left_pt g).1 <= p.1 <= (right_pt g).1. + +Definition point_on_edge (p : Plane R) (g : edge) := + valid_edge g p && (det (left_pt g) (right_pt g) p == 0). + +Notation "p '===' e" := (point_on_edge p e)( at level 70, no associativity). + +Definition dummy_pt : Plane R := (0, 0). + +Definition closed_cell_side_limit_ok c := + [&& left_pts c != [::], + all (fun p => p.1 == (last dummy_pt (left_pts c)).1) (left_pts c), + sorted >%R [seq p.2 | p <- left_pts c], + head dummy_pt (left_pts c) === high c, + last dummy_pt (left_pts c) === low c, + right_pts c != [::], + all (fun p => p.1 == (head dummy_pt (right_pts c)).1) (right_pts c), + sorted <%R [seq p.2 | p <- right_pts c], + head dummy_pt (right_pts c) === low c & + last dummy_pt (right_pts c) === high c]. + +Definition left_limit (c : cell) := (last dummy_pt (left_pts c)).1. + +Definition right_limit c := (last dummy_pt (right_pts c)).1. + +Definition point_under_edge (p : Plane R) (e : edge) : bool := + det p (left_pt e) (right_pt e) <= 0. + + (* returns true if p is strictly under e *) +Definition point_strictly_under_edge (p : Plane R) (e : edge) : bool := + det p (left_pt e) (right_pt e) < 0. + +Notation "p '<<=' e" := (point_under_edge p e)( at level 70, no associativity). +Notation "p '<<<' e" := (point_strictly_under_edge p e) + (at level 70, no associativity). + +Definition strict_inside_closed (p : Plane R) (c : cell) := + (p <<< high c) && (~~(p <<= low c)) && + (left_limit c < p.1 < right_limit c). + +Definition bottom_left_corner (c : cell) := last dummy_pt (left_pts c). + +Record vert_edge := { ve_x : R; ve_top : R; ve_bot : R}. + +Definition vert_edge_eqb (v1 v2 : vert_edge) := + let: Build_vert_edge v1x v1t v1b := v1 in + let: Build_vert_edge v2x v2t v2b := v2 in + (v1x == v2x) && (v1t == v2t) && (v1b == v2b). + +Lemma vert_edge_eqP : Equality.axiom vert_edge_eqb. +Proof. +move=> [vxa vta vba] [vxb vtb vbb] /=. +have [/eqP <-|/eqP anb] := boolP(vxa == vxb). + have [/eqP <-|/eqP anb] := boolP(vta == vtb). + have [/eqP <-| /eqP anb] := boolP(vba == vbb). + by apply:ReflectT. + by apply: ReflectF=> [] []. + by apply: ReflectF=> [] []. +by apply: ReflectF=> [] []. +Qed. + +Fail Check (fun (x : vert_edge) (l : seq vert_edge) => x \in l). + +HB.instance Definition _ := hasDecEq.Build _ vert_edge_eqP. + +Fixpoint seq_to_intervals_aux [A : Type] (a : A) (s : seq A) := +match s with +| nil => nil +| b :: tl => (a, b) :: seq_to_intervals_aux b tl +end. + +Definition seq_to_intervals [A : Type] (s : seq A) := +match s with + nil => nil +| a :: tl => seq_to_intervals_aux a tl +end. + +Definition cell_safe_exits_left (c : cell) : seq vert_edge := + let lx := (seq.head dummy_pt (left_pts c)).1 in + map (fun p => Build_vert_edge lx (p.1).2 (p.2).2) + (seq_to_intervals (left_pts c)). + +Definition cell_safe_exits_right (c : cell) : seq vert_edge := + let lx := (seq.head dummy_pt (right_pts c)).1 in + map (fun p => Build_vert_edge lx (p.1).2 (p.2).2) + (seq_to_intervals (rev (right_pts c))). + +Definition dummy_vert_edge := + {| ve_x := 0; ve_top := 0; ve_bot := 0|}. + +Definition on_vert_edge (p : Plane R) (v : vert_edge) : bool := + (p.1 == ve_x v) && (ve_bot v < p.2 < ve_top v). + +Check fun (v : vert_edge) (l : seq vert_edge) => v \in l. +Check fun (v : vert_edge)(c : cell) => + v \in cell_safe_exits_left c. + +Lemma detDM2 (l p1 p2 q1 q2 r1 r2 : R) : + l * det (p1, p2) (q1, q2) (r1, r2) = + det (p1, p2) (p1 + l * (q1 - p1), p2 + l * (q2 - p2)) (r1, r2). +Proof. by rewrite !develop_det /xcoord /ycoord /=; ring. Qed. + +Lemma detDM1 (l p1 p2 q1 q2 r1 r2 : R) : + l * det (p1, p2) (q1, q2) (r1, r2) = + det (q1 + l * (p1 - q1), q2 + l * (p2 - q2)) (q1, q2) (r1, r2). +Proof. by rewrite !develop_det /xcoord /ycoord /=; ring. Qed. + +Lemma detDM3 (l p1 p2 q1 q2 r1 r2 : R) : +det (p1, p2) (q1, q2) (r1, r2) = +det (p1, p2) (q1, q2) (r1 + l * (q1 - p1), r2 + l * (q2 - p2)). +Proof. by rewrite !develop_det /xcoord /ycoord /=; ring. Qed. + +Lemma detVert (p1 p2 q1 q2 r2 : R) : + det (p1, p2) (q1, q2) (q1, r2) = + (r2 - q2) * (q1 - p1). +Proof. rewrite !develop_det /xcoord /ycoord /=; ring. Qed. + +Lemma bezier1_conv c t : bezier c 1 t = c 0%nat <| (1 - t) |> c 1%nat. +Proof. rewrite /= /conv; congr (_ *: _ + _ *: _); ring. Qed. + +Lemma left_vertical_edge_wrt_high c v : + left_limit c < right_limit c -> + closed_cell_side_limit_ok c -> + v \in cell_safe_exits_left c -> + (ve_top v <= (head dummy_pt (left_pts c)).2) && + ((left_pt (high c)).1 <= ve_x v < (right_pt (high c)).1) && + (ve_x v == (head dummy_pt (left_pts c)).1). +Proof. +move=> llr /andP[] leftn0 /andP[] /allP samexl /andP[] sortl. +move=> /andP[] lonh /andP[] lonl. +move=> /andP[] rightn0 /andP[] /allP samexr /andP[] sortr /andP[] ronl ronh vin. +have {}samexl : + {in left_pts c, forall p, (head dummy_pt (left_pts c)).1 = p.1 }. + move=> x xin; rewrite (eqP (samexl x xin)). + rewrite -(eqP (samexl (head dummy_pt (left_pts c)) _)) //. + by move: leftn0; case (left_pts c)=> //= s l _; rewrite inE eqxx. +have vxleft : ve_x v = left_limit c. + move: vin. + rewrite /left_limit /cell_safe_exits_left. + elim: (left_pts c) leftn0 samexl => [ // | e1 [// | e2 tl] Ih] _ /= samexl. + rewrite inE=> /orP[/eqP -> /= | vin]. + by apply: samexl; rewrite inE mem_last orbT. + apply: (Ih isT)=> /=. + move=> x xin. rewrite -(samexl e2); last by rewrite !inE eqxx orbT. + by apply: samexl; rewrite inE xin orbT. + by rewrite -(samexl e2) //; rewrite !inE eqxx orbT. +apply/andP; split; last first. + rewrite vxleft /left_limit (samexl (last dummy_pt (left_pts c))) //. + by case: (left_pts c) leftn0=> [// | ? ?]; rewrite /= mem_last. +move: llr. +rewrite vxleft /left_limit -(samexl (last dummy_pt (left_pts c))); last first. + by case: (left_pts c) leftn0 => //= a tl _ ; rewrite mem_last. +move: lonh=> /andP[] /andP[] -> /= _ _ llr. +rewrite (lt_le_trans llr) ?andbT; last first. + by rewrite /right_limit; move: ronh=> /andP[] /andP[] _ ->. +move: vin; rewrite /cell_safe_exits_left. +elim: (left_pts c) leftn0 sortl samexl + => [// | e1 [ // | e2 tl] /(_ isT) Ih] _ /= /andP[] cmp s samexl. +rewrite inE=> /orP[/eqP -> // | vin ]. +apply: (le_trans _ (ltW cmp)). +apply Ih=> //=. + move=> x xin. + by rewrite -(samexl e2) ?inE ?eqxx ?orbT // (samexl x) // inE xin orbT. +by rewrite -(samexl e2) // !inE eqxx orbT. +Qed. + +Lemma seq_to_intervals_rcons [A : Type](e1 e2 : A) l : + seq_to_intervals (rcons (rcons l e2) e1) = + rcons (seq_to_intervals (rcons l e2)) (e2, e1). +Proof. by elim: l => [// | e3 [// | e4 l] /= Ih] //; rewrite Ih. Qed. + +Lemma right_vertical_edge_wrt_high c v : + left_limit c < right_limit c -> + closed_cell_side_limit_ok c -> + v \in cell_safe_exits_right c -> + (ve_top v <= (last dummy_pt (right_pts c)).2) && + ((left_pt (high c)).1 < ve_x v <= (right_pt (high c)).1) && + (ve_x v == (last dummy_pt (right_pts c)).1). +Proof. +move=> llr /andP[] leftn0 /andP[] /allP samexl /andP[] sortl. +move=>/andP[] lonh /andP[] lonl. +move=> /andP[] rightn0 /andP[] /allP samexr /andP[] sortr /andP[] ronl ronh vin. +have vxright : ve_x v = right_limit c. + move: vin. + rewrite /right_limit /cell_safe_exits_right. + elim/last_ind: (right_pts c) rightn0 samexr => [ // | lh e1 Ih] _ /=. + elim/last_ind: lh Ih => [ // | lh e2 _] Ih samexr. + rewrite last_rcons !rev_rcons/=. + rewrite inE=> /orP[/eqP -> /= | vin]. + by rewrite (eqP (samexr e1 _)) // mem_rcons inE eqxx. + rewrite (eqP (samexr e1 _)); last by rewrite mem_rcons inE eqxx. + rewrite -(eqP (samexr e2 _)); last by rewrite !(mem_rcons, inE) eqxx ?orbT. + rewrite [e2](_ : _ = last dummy_pt (rcons lh e2)); last by rewrite last_rcons. + apply: Ih=> /=. + by case lhq: lh. + move=> x xin. + rewrite (eqP (samexr x _)); last by rewrite mem_rcons inE xin orbT. + by rewrite 3!headI /=. + rewrite + [head _ (rcons _ _)](_ : _ = head dummy_pt (rcons lh e2)) in vin; last first. + by rewrite 3!headI /=. + by rewrite rev_rcons; apply: vin. +apply/andP; split; last by rewrite vxright. +move: llr. +rewrite vxright /right_limit. +move: ronh=> /andP[] /andP[] _ -> /= _ llr. +rewrite (le_lt_trans _ llr) ?andbT; last first. + rewrite /left_limit; move: lonh=> /andP[] /andP[] + _ _. + rewrite (eqP (samexl (head dummy_pt (left_pts c)) _)) //. + by case: (left_pts c) leftn0 => [// | a ?]; rewrite /= inE eqxx. +move: vin; rewrite /cell_safe_exits_right. +elim/last_ind: (right_pts c) rightn0 sortr samexr=> [// | + e1 ]. +elim/last_ind=> [// | l e2 _] Ih _ sortr samexr. +rewrite 2!rev_rcons /= inE last_rcons=> /orP[/eqP -> | vin]; first by []. +have cmp : e2.2 < e1.2. + move: sortr; rewrite -2!cats1 -catA /= map_cat=> /cat_sorted2[_ /=]. + by rewrite andbT. +have {}sortr : sorted <%R [seq p.2 | p <- rcons l e2]. + by move: sortr; rewrite -cats1 map_cat=> /cat_sorted2[]. +apply: (le_trans _ (ltW cmp)). +rewrite [e2](_ : _ = last dummy_pt (rcons l e2)); last by rewrite last_rcons. +apply Ih=> //=. + by case lq : l. + move=> x xin. + have -> : head dummy_pt (rcons l e2) = head dummy_pt (rcons (rcons l e2) e1). + by case lq : l. + by apply: samexr; rewrite mem_rcons inE xin orbT. +have -> : head dummy_pt (rcons l e2) = head dummy_pt (rcons (rcons l e2) e1). + by case lq : l. +by rewrite rev_rcons. +Qed. + +Lemma left_vertical_edge_wrt_low c v : + left_limit c < right_limit c -> + closed_cell_side_limit_ok c -> + v \in cell_safe_exits_left c -> + ((last dummy_pt (left_pts c)).2 <= ve_bot v) && + ((left_pt (low c)).1 <= ve_x v < (right_pt (low c)).1) && + (ve_x v == (last dummy_pt (left_pts c)).1). +Proof. +move=> llr /andP[] leftn0 /andP[] /allP samexl /andP[] sortl. +move=>/andP[] lonh /andP[] lonl. +move=> /andP[] rightn0 /andP[] /allP samexr /andP[] sortr /andP[] ronl ronh vin. +have {}samexl: {in left_pts c, forall p, (head dummy_pt (left_pts c)).1 = p.1 }. + move=> x xin; rewrite (eqP (samexl x xin)). + rewrite -(eqP (samexl (head dummy_pt (left_pts c)) _)) //. + by move: leftn0; case (left_pts c)=> //= s l _; rewrite inE eqxx. +have vxleft : ve_x v = left_limit c. + move: vin. + rewrite /left_limit /cell_safe_exits_left. + elim: (left_pts c) leftn0 samexl => [ // | e1 [// | e2 tl] Ih] _ /= samexl. + rewrite inE=> /orP[/eqP -> /= | vin]. + by apply: samexl; rewrite inE mem_last orbT. + apply: (Ih isT)=> /=. + move=> x xin. rewrite -(samexl e2); last by rewrite !inE eqxx orbT. + by apply: samexl; rewrite inE xin orbT. + by rewrite -(samexl e2) //; rewrite !inE eqxx orbT. +apply/andP; split; last by rewrite vxleft. +move: llr. +rewrite vxleft /left_limit. +move: lonl=> /andP[] /andP[] -> /= _ _ llr. +rewrite (lt_le_trans llr) ?andbT; last first. + rewrite /right_limit; move: ronl=> /andP[] /andP[] _ + _. + rewrite -(eqP (samexr (last dummy_pt (right_pts c)) _)) //. + by move: rightn0; case: (right_pts c)=> [// | ? ?]; rewrite /= mem_last. +move: vin; rewrite /cell_safe_exits_left. +elim: (left_pts c) leftn0 sortl samexl + => [// | e1 [ // | e2 tl] /(_ isT) Ih] _ /= /andP[] cmp s samexl. +rewrite inE=> /orP[/eqP -> /= | vin ]. + have sgt : subrel >%R (>=%R : rel R) by move=> x y /ltW. + have s' : path >=%R e2.2 [seq p.2 | p <- tl]. + by apply: (sub_path sgt). + case tlq : tl => [// | e3 tl']; rewrite -tlq. + move: s'; rewrite path_sortedE; last by apply/rev_trans/le_trans. + move=> /andP[] /allP /(_ (last e2 tl).2) + _; apply. + by apply/mapP; exists (last e2 tl); rewrite // tlq /= mem_last. +apply Ih=> //=. + move=> x xin. + by rewrite -(samexl e2) ?inE ?eqxx ?orbT // (samexl x) // inE xin orbT. +by rewrite -(samexl e2) // !inE eqxx orbT. +Qed. + +Lemma right_vertical_edge_wrt_low c v : + left_limit c < right_limit c -> + closed_cell_side_limit_ok c -> + v \in cell_safe_exits_right c -> + ((head dummy_pt (right_pts c)).2 <= ve_bot v) && + ((left_pt (low c)).1 < ve_x v <= (right_pt (low c)).1) && + (ve_x v == (head dummy_pt (right_pts c)).1). +Proof. +move=> llr /andP[] leftn0 /andP[] /allP samexl /andP[] sortl. +move=>/andP[] lonh /andP[] lonl. +move=> /andP[] rightn0 /andP[] /allP samexr /andP[] sortr /andP[] ronl ronh vin. +have vxright : ve_x v = right_limit c. + move: vin. + rewrite /right_limit /cell_safe_exits_right. + elim/last_ind: (right_pts c) rightn0 samexr => [ // | lh e1 Ih] _ /=. + elim/last_ind: lh Ih => [ // | lh e2 _] Ih samexr. + rewrite last_rcons !rev_rcons/=. + rewrite inE=> /orP[/eqP -> /= | vin]. + by rewrite (eqP (samexr e1 _)) // mem_rcons inE eqxx. + rewrite (eqP (samexr e1 _)); last by rewrite mem_rcons inE eqxx. + rewrite -(eqP (samexr e2 _)); last by rewrite !(mem_rcons, inE) eqxx ?orbT. + rewrite [e2](_ : _ = last dummy_pt (rcons lh e2)); last by rewrite last_rcons. + apply: Ih=> /=. + by case lhq: lh. + move=> x xin. + rewrite (eqP (samexr x _)); last by rewrite mem_rcons inE xin orbT. + by rewrite 3!headI /=. + rewrite [head _ (rcons _ _)] + (_ : _ = head dummy_pt (rcons lh e2)) in vin; last first. + by rewrite 3!headI /=. + by rewrite rev_rcons; apply: vin. +apply/andP; split; last first. + rewrite vxright /right_limit; apply: samexr. + by case: (right_pts c) rightn0=> [// | ? ?]; rewrite /= mem_last. +move: llr. +rewrite vxright /right_limit. +move: ronl=> /andP[] /andP[] _ + _ /=. +rewrite -(eqP (samexr (last dummy_pt (right_pts c)) _)); last first. + by case: (right_pts c) rightn0 => [// | ? ?]; rewrite /= mem_last. +move=> -> xcond; rewrite ?andbT. +rewrite (le_lt_trans _ xcond) ?andbT; last by move: lonl=> /andP[] /andP[]. +move: vin; rewrite /cell_safe_exits_right. +elim/last_ind: (right_pts c) rightn0 sortr samexr=> [// | + e1 ]. +elim/last_ind=> [// | l e2 _] Ih _ sortr samexr. +have cmp : e2.2 < e1.2. + move: sortr; rewrite -2!cats1 -catA /= map_cat=> /cat_sorted2[_ /=]. + by rewrite andbT. +have {}sortr : sorted <%R [seq p.2 | p <- rcons l e2]. + by move: sortr; rewrite -cats1 map_cat=> /cat_sorted2[]. +rewrite [head dummy_pt _](_ : _ = head e2 l); last by rewrite 2!headI /=. +rewrite 2!rev_rcons /= inE => /orP[/eqP -> /= | vin]. + case lq : l => [// | e3 l'] /=. + move: sortr; rewrite lq /= => /(sub_path ltW). + rewrite (path_sortedE le_trans)=> /andP[] /allP + _; apply. + by apply/mapP; exists e2; rewrite // mem_rcons inE eqxx. +rewrite [X in X.2 <= _](_ : _ = head dummy_pt (rcons l e2)); last first. + by case lq: l. +apply Ih=> //=. + by case lq : l. + move=> x xin. + have -> : head dummy_pt (rcons l e2) = head dummy_pt (rcons (rcons l e2) e1). + by case lq : l. + by apply: samexr; rewrite mem_rcons inE xin orbT. +have -> : head dummy_pt (rcons l e2) = head dummy_pt (rcons (rcons l e2) e1). + by case lq : l. +by rewrite rev_rcons 2!headI /=. +Qed. + +Lemma vert_projr (p q r : Plane R) : + p.1 != q.1 -> (det p q r == 0) = + (r.2 == q.2 + (r.1 - q.1) / (q.1 - p.1) * (q.2 - p.2)). +Proof. +case: p q r=> [p1 p2][q1 q2][r1 r2] /=; rewrite develop_det /= => e_cnd. +apply/idP/eqP; last first. + move=> -> /=; rewrite !mulrDl -(opprB q1 p1) !mulrN (mulrAC _ _ (q1 - p1)). + rewrite mulfVK; last by rewrite subr_eq0 eq_sym. + rewrite (mulrAC _ _ (q1 - p1)). + rewrite mulfVK; last by rewrite subr_eq0 eq_sym. + apply/eqP; ring. +rewrite !(addrAC _ (- (r2 * (p1 - q1)))) subr_eq0 eq_sym => /eqP r2Mdf. +have dn0 : (p1 - q1) != 0 by rewrite subr_eq0. +apply: (mulIf dn0); rewrite r2Mdf mulrDl (mulrAC _ _ (p1 - q1)) -(opprB p1 q1). +rewrite invrN !(mulrN, mulNr). +rewrite mulfVK //; ring. +Qed. + +Lemma vert_projl (p q r : Plane R) : + p.1 != q.1 -> (det p q r == 0) = + (r.2 == p.2 + (r.1 - p.1) / (q.1 - p.1) * (q.2 - p.2)). +Proof. +case: p q r=> [p1 p2][q1 q2][r1 r2] /=; rewrite develop_det /= => e_cnd. +apply/idP/eqP; last first. + move=> -> /=; rewrite !mulrDl -(opprB q1 p1) !mulrN (mulrAC _ _ (q1 - p1)). + rewrite mulfVK; last by rewrite subr_eq0 eq_sym. + rewrite (mulrAC _ _ (q1 - p1)). + rewrite mulfVK; last by rewrite subr_eq0 eq_sym. + apply/eqP; ring. +rewrite !(addrAC _ (- (r2 * (p1 - q1)))) subr_eq0 eq_sym => /eqP r2Mdf. +have dn0 : (p1 - q1) != 0 by rewrite subr_eq0. +apply: (mulIf dn0); rewrite r2Mdf mulrDl (mulrAC _ _ (p1 - q1)) -(opprB p1 q1). +rewrite invrN !(mulrN, mulNr). +rewrite mulfVK //; ring. +Qed. + +Lemma on_vert_edge_under_high_left v c p : + left_limit c < right_limit c -> + closed_cell_side_limit_ok c -> + on_vert_edge p v -> + v \in cell_safe_exits_left c -> + p <<< high c. +Proof. +move=> llr cok onv vin. +have /andP[/andP[vtople xcond] xcond2] := + left_vertical_edge_wrt_high llr cok vin. +move: (cok)=> /andP[] leftn0 /andP[] samexl /andP[] sortl /andP[] lonh _. +rewrite /point_strictly_under_edge. +set l := ((right_pt (high c)).1 - p.1) / + ((right_pt (high c)).1 - (left_pt (high c)).1). +set q := ((right_pt (high c)).1 - l * + ((right_pt (high c)).1 - (left_pt (high c)).1), + (right_pt (high c)).1 - l * + ((right_pt (high c)).2 - (left_pt (high c)).2)). +case pq : p => [p1 p2]. +case lq : (left_pt (high c)) => [q1 q2]. +case rq : (right_pt (high c)) => [r1 r2]. +have lv : l = (r1 - p1) / (r1 - q1) by rewrite /l pq rq lq /=. +have p1ltr1 : p1 < r1. + move: onv xcond => /andP[] /eqP + _. + by rewrite lq rq pq /= => -> => /andP[]. +have lgt0 : 0 < l. + rewrite /l divr_gt0 // subr_gt0 ?pq ?lq ?rq //=. + by move: (edge_cond (high c)); rewrite lq rq. +rewrite det_cyclique. +rewrite -(pmulr_rlt0 _ lgt0). +rewrite detDM1 det_cyclique. +have <- : p1 = r1 + l * (q1 - r1). + rewrite lv -(opprB r1 q1) mulrN mulfVK; first by ring. + rewrite subr_eq0; apply/eqP=> abs. + by have := edge_cond (high c); rewrite lq rq abs lt_irreflexive. +rewrite detVert lv. +rewrite nmulr_llt0; last by rewrite subr_lt0. +have proj2: (head dummy_pt (left_pts c)).2 = + r2 + (r1 - p1) / (r1 - q1) * (q2 - r2). + have ecnd : (left_pt (high c)).1 != (right_pt (high c)).1. + by apply/eqP=> abs; have := edge_cond (high c); rewrite abs lt_irreflexive. + have := vert_projr (head dummy_pt (left_pts c)) ecnd. + move: lonh=> /andP[] _ -> => /esym /eqP; rewrite ?pq ?lq ?rq /= => ->. + rewrite -(eqP xcond2); move: onv=>/andP[] /eqP <- _; rewrite pq /=; ring. +rewrite -proj2 subr_gt0. +apply: lt_le_trans vtople. +by move: onv=> /andP[] _ /andP[]; rewrite pq /=. +Qed. + +Lemma on_vert_edge_above_low_left v c p : + left_limit c < right_limit c -> + closed_cell_side_limit_ok c -> + on_vert_edge p v -> + v \in cell_safe_exits_left c -> + ~~ (p <<= low c). +Proof. +move=> llr cok onv vin. +have /andP[/andP[vtople xcond] xcond2] := + left_vertical_edge_wrt_low llr cok vin. +move: (cok)=> /andP[] leftn0 /andP[] samexl /andP[] sortl. +move=>/andP[] _ /andP[] lonl _. +rewrite /point_under_edge -ltNge. +set l := ((right_pt (low c)).1 - p.1) / ((right_pt (low c)).1 - (left_pt (low c)).1). +set q := ((right_pt (low c)).1 - l * ((right_pt (low c)).1 - (left_pt (low c)).1), + (right_pt (low c)).1 - l * ((right_pt (low c)).2 - (left_pt (low c)).2)). +case pq : p => [p1 p2]. +case lq : (left_pt (low c)) => [q1 q2]. +case rq : (right_pt (low c)) => [r1 r2]. +have lv : l = (r1 - p1) / (r1 - q1) by rewrite /l pq rq lq /=. +have p1ltr1 : p1 < r1. + move: onv xcond => /andP[] /eqP + _. + by rewrite lq rq pq /= => -> => /andP[]. +have lgt0 : 0 < l. + rewrite /l divr_gt0 // subr_gt0 ?pq ?lq ?rq //=. + by move: (edge_cond (low c)); rewrite lq rq. +rewrite det_cyclique. +rewrite -(pmulr_rgt0 _ lgt0). +rewrite detDM1 det_cyclique. +have <- : p1 = r1 + l * (q1 - r1). + rewrite lv -(opprB r1 q1) mulrN mulfVK; first by ring. + rewrite subr_eq0; apply/eqP=> abs. + by have := edge_cond (low c); rewrite lq rq abs lt_irreflexive. +rewrite detVert lv. +rewrite nmulr_lgt0; last by rewrite subr_lt0. +have proj2: (last dummy_pt (left_pts c)).2 = r2 + (r1 - p1) / (r1 - q1) * (q2 - r2). + have ecnd : (left_pt (low c)).1 != (right_pt (low c)).1. + by apply/eqP=> abs; have := edge_cond (low c); rewrite abs lt_irreflexive. + have := vert_projr (last dummy_pt (left_pts c)) ecnd. + move: lonl=> /andP[] _ -> => /esym /eqP; rewrite ?pq ?lq ?rq /= => ->. + rewrite -(eqP xcond2); move: onv=>/andP[] /eqP <- _; rewrite pq /=; ring. +rewrite -proj2 subr_lt0. +apply: (le_lt_trans vtople). +by move: onv=> /andP[] _ /andP[]; rewrite pq /=. +Qed. + +Lemma on_vert_edge_under_high_right v c p : + left_limit c < right_limit c -> + closed_cell_side_limit_ok c -> + on_vert_edge p v -> + v \in cell_safe_exits_right c -> + p <<< high c. +Proof. +move=> llr cok onv vin. +have /andP[/andP[vtople xcond] xcond2] := right_vertical_edge_wrt_high llr cok vin. +move: (cok); rewrite /closed_cell_side_limit_ok. +rewrite 4!andbA=> /andP[] _. +move=> /andP[] rightn0 /andP[] samexr /andP[] sortr /andP[] _ ronh. +rewrite /point_strictly_under_edge. +set l := (p.1 - (left_pt (high c)).1) / ((right_pt (high c)).1 - (left_pt (high c)).1). +set q := ((left_pt (high c)).1 + l * ((right_pt (high c)).1 - (left_pt (high c)).1), + (left_pt (high c)).1 + l * ((right_pt (high c)).2 - (left_pt (high c)).2)). +case pq : p => [p1 p2]. +case lq : (left_pt (high c)) => [q1 q2]. +case rq : (right_pt (high c)) => [r1 r2]. +have lv : l = (p1 - q1) / (r1 - q1) by rewrite /l pq rq lq /=. +have q1ltp1 : q1 < p1. + move: onv xcond => /andP[] /eqP + _. + by rewrite lq rq pq /= => -> => /andP[]. +have lgt0 : 0 < l. + rewrite /l divr_gt0 // subr_gt0 ?pq ?lq ?rq //=. + by move: (edge_cond (high c)); rewrite lq rq. +rewrite det_inverse det_cyclique oppr_lt0. +rewrite -(pmulr_rgt0 _ lgt0). +rewrite detDM1 det_cyclique. +have <- : p1 = q1 + l * (r1 - q1). + rewrite lv mulfVK; first by ring. + rewrite subr_eq0; apply/eqP=> abs. + by have := edge_cond (high c); rewrite lq rq abs lt_irreflexive. +rewrite detVert lv. +rewrite pmulr_lgt0; last by rewrite subr_gt0. +have proj2: (last dummy_pt (right_pts c)).2 = q2 + (p1 - q1) / (r1 - q1) * (r2 - q2). + have ecnd : (left_pt (high c)).1 != (right_pt (high c)).1. + by apply/eqP=> abs; have := edge_cond (high c); rewrite abs lt_irreflexive. + have := vert_projl (last dummy_pt (right_pts c)) ecnd. + move: ronh=> /andP[] _ -> => /esym /eqP; rewrite ?pq ?lq ?rq /= => ->. + rewrite -(eqP xcond2); move: onv=>/andP[] /eqP <- _; rewrite pq /=; ring. +rewrite -proj2 subr_gt0. +apply: lt_le_trans vtople. +by move: onv=> /andP[] _ /andP[]; rewrite pq /=. +Qed. + +Lemma on_vert_edge_above_low_right v c p : + left_limit c < right_limit c -> + closed_cell_side_limit_ok c -> + on_vert_edge p v -> + v \in cell_safe_exits_right c -> + ~~ (p <<= low c). +Proof. +move=> llr cok onv vin. +have /andP[/andP[vtople xcond] xcond2] := right_vertical_edge_wrt_low llr cok vin. +move: (cok); rewrite /closed_cell_side_limit_ok. +rewrite 4!andbA=> /andP[] _. +move=> /andP[] rightn0 /andP[] samexr /andP[] sortr /andP[] ronl _. +rewrite /point_under_edge -ltNge. +set l := (p.1 - (left_pt (low c)).1) / ((right_pt (low c)).1 - (left_pt (low c)).1). +set q := ((left_pt (low c)).1 + l * ((right_pt (low c)).1 - (left_pt (low c)).1), + (left_pt (low c)).1 + l * ((right_pt (low c)).2 - (left_pt (low c)).2)). +case pq : p => [p1 p2]. +case lq : (left_pt (low c)) => [q1 q2]. +case rq : (right_pt (low c)) => [r1 r2]. +have lv : l = (p1 - q1) / (r1 - q1) by rewrite /l pq rq lq /=. +have q1ltp1 : q1 < p1. + move: onv xcond => /andP[] /eqP + _. + by rewrite lq rq pq /= => -> => /andP[]. +have lgt0 : 0 < l. + rewrite /l divr_gt0 // subr_gt0 ?pq ?lq ?rq //=. + by move: (edge_cond (low c)); rewrite lq rq. +rewrite det_inverse det_cyclique oppr_gt0. +rewrite -(pmulr_rlt0 _ lgt0). +rewrite detDM1 det_cyclique. +have <- : p1 = q1 + l * (r1 - q1). + rewrite lv mulfVK; first by ring. + rewrite subr_eq0; apply/eqP=> abs. + by have := edge_cond (low c); rewrite lq rq abs lt_irreflexive. +rewrite detVert lv. +rewrite pmulr_llt0; last by rewrite subr_gt0. +have proj2: (head dummy_pt (right_pts c)).2 = q2 + (p1 - q1) / (r1 - q1) * (r2 - q2). + have ecnd : (left_pt (low c)).1 != (right_pt (low c)).1. + by apply/eqP=> abs; have := edge_cond (low c); rewrite abs lt_irreflexive. + have := vert_projl (head dummy_pt (right_pts c)) ecnd. + move: ronl=> /andP[] _ -> => /esym /eqP; rewrite ?pq ?lq ?rq /= => ->. + rewrite -(eqP xcond2); move: onv=>/andP[] /eqP <- _; rewrite pq /=; ring. +rewrite -proj2 subr_lt0. +apply: (le_lt_trans vtople). +by move: onv=> /andP[] _ /andP[]; rewrite pq /=. +Qed. + +Lemma conv_num_sg s (a b t : R) : + 0 < t < 1 -> sgz a = s -> sgz b = s -> sgz ((a : R^o) <| t |> b) = s. +Proof. +move=> tint. +have [ -> <- | agt0 <- | alt0 <-] := sgzP a. + have [ -> | // | // ] := sgzP b. + by rewrite convmm sgz0. + have [ // | bgt0 _ | // ] := sgzP b. + rewrite /conv; apply/gtr0_sgz/addr_gt0; apply/mulr_gt0; lra. +have [ // | // | blt0 _] := sgzP b. +rewrite /conv; apply/ltr0_sgz; rewrite -oppr_gt0 opprD. +apply/addr_gt0; rewrite -mulrN; apply/mulr_gt0; lra. +Qed. + +Lemma conv_num_gtl (a b t c : R) : + 0 < t < 1 -> c < a -> c <= b -> c < (a : R^o) <| t |> b. +Proof. +move=> tint clta cleb; rewrite /conv. +rewrite -[_ *: (a : R^o)]/(t * a). +rewrite -[_ *: (b : R^o)]/((1 - t) * b). +rewrite [X in _ < X] + (_ : _ = c + ((t * (a - c)) + (1 - t) * (b - c))); last by ring. +have fact1 : 0 < t * (a - c) by apply: mulr_gt0; lra. +have fact2 : 0 <= (1 - t) * (b - c) by apply: mulr_ge0; lra. +lra. +Qed. + +Lemma conv_num_ltr (a b t c : R) : + 0 < t < 1 -> a < c -> b <= c -> (a : R^o) <| t |> b < c. +Proof. +move=> tint clta cleb; rewrite /conv. +rewrite -[_ *: (a : R^o)]/(t * a). +rewrite -[_ *: (b : R^o)]/((1 - t) * b). +rewrite [X in X < _] + (_ : _ = c - ((t * (c - a)) + (1 - t) * (c - b))); last by ring. +have fact1 : 0 < t * (c - a) by apply: mulr_gt0; lra. +have fact2 : 0 <= (1 - t) * (c - b) by apply: mulr_ge0; lra. +lra. +Qed. + +Lemma conv_p1 (a b : Plane R) t : (a <| t |> b).1 = + ((a.1 : R^o) <| t |> b.1). +Proof. by []. Qed. + +Lemma safe_bezier2 p1 p2 p3 c1 c2 vert_e u : + closed_cell_side_limit_ok c1 -> + closed_cell_side_limit_ok c2 -> + strict_inside_closed p1 c1 -> + strict_inside_closed p3 c2 -> + vert_e \in cell_safe_exits_right c1 -> + vert_e \in cell_safe_exits_left c2 -> + on_vert_edge p2 vert_e -> + 0 < u < 1 -> + on_vert_edge (bezier (f3pt p1 p2 p3) 2 u) vert_e -> + forall t, 0 <= t <= 1 -> + let bzt := bezier (f3pt p1 p2 p3) 2 t in + (strict_inside_closed bzt c1) || + (strict_inside_closed bzt c2) || + on_vert_edge bzt vert_e. +Proof. +move=> ok1 ok2 p1in p3in v1 v2 p2in uin bzuin t tin. +have un0 : u != 0 by apply: lt0r_neq0; case/andP: uin. +set bzt := bezier _ 2 t; lazy zeta. +have [tu | nut] := eqVneq t u; first by rewrite /bzt tu bzuin !orbT. +have llr1 : left_limit c1 < right_limit c1. + by move: p1in=> /andP[] _ /andP[]; apply: lt_trans. +have llr2 : left_limit c2 < right_limit c2. + by move: p3in=> /andP[] _ /andP[]; apply: lt_trans. +have p2belh1 : p2 <<< high c1. + by apply: (on_vert_edge_under_high_right _ ok1 p2in v1). +have p2belh2 : p2 <<< high c2. + by apply: (on_vert_edge_under_high_left _ ok2 p2in v2). +have p2abol1 : ~~(p2 <<= low c1). + by apply: (on_vert_edge_above_low_right _ ok1 p2in v1). +have p2abol2 : ~~(p2 <<= low c2). + by apply: (on_vert_edge_above_low_left _ ok2 p2in v2). +have bzubelh1 : bezier (f3pt p1 p2 p3) 2 u <<< high c1. + by apply: (on_vert_edge_under_high_right _ ok1 bzuin v1). +have bzuabol1 : ~~(bezier (f3pt p1 p2 p3) 2 u <<= low c1). + by apply: (on_vert_edge_above_low_right _ ok1 bzuin v1). +have bzubelh2 : bezier (f3pt p1 p2 p3) 2 u <<< high c2. + by apply: (on_vert_edge_under_high_left _ ok2 bzuin v2). +have bzuabol2 : ~~(bezier (f3pt p1 p2 p3) 2 u <<= low c2). + by apply: (on_vert_edge_above_low_left _ ok2 bzuin v2). +have [P1 | P2] := ltrP t u. + apply/orP; left; apply/orP; left. + set t' := t / u. + have t'int : 0 <= t' < 1. + apply/andP; split. + rewrite /t'; apply divr_ge0; lra. + rewrite /t' ltr_pdivrMr; lra. + have tt' : t = t' * u by rewrite /t' mulfVK. + have := bezier2_dichotomy_l (f3pt p1 p2 p3) t' u; rewrite -tt' /bzt => ->. + set p2' := p2 <| u |> p1. + set p3' := bezier (f3pt p1 p2 p3) 2 u. + rewrite [bezier _ _ _](_ : _ = (p3' <| t' |> p2') <| t' |> + (p2' <| t' |> p1)); last first. + by rewrite !bezier_step_conv /= -/p2'. + have [-> | t'n0] := eqVneq t' 0; first by rewrite !conv0. + have t'int' : 0 < t' < 1 by lra. + rewrite /strict_inside_closed -andbA; apply/andP; split. + rewrite /point_strictly_under_edge !det_conv. + have sgp1 : sgz (det p1 (left_pt (high c1)) (right_pt (high c1))) = -1. + by apply:ltr0_sgz; move: p1in=> /andP[] /andP[]. + have sgp2' : sgz + ((det p2 (left_pt (high c1)) (right_pt (high c1)) : R ^o) <|u|> + det p1 (left_pt (high c1)) (right_pt (high c1))) = -1. + apply: conv_num_sg=> //. + apply: ltr0_sgz; exact p2belh1. + rewrite -sgz_lt0; set (tmp := sgz _); suff -> : tmp = -1 by []. + rewrite {}/tmp; apply: conv_num_sg => //. + apply: conv_num_sg=> //. + apply: ltr0_sgz; exact bzubelh1. + by apply: conv_num_sg. + apply/andP; split. + rewrite /point_under_edge -ltNge. + rewrite !det_conv. + have sgp1 : sgz (det p1 (left_pt (low c1)) (right_pt (low c1))) = 1. + by apply:gtr0_sgz; move: p1in=> /andP[] /andP[] _; rewrite -ltNge. + have sgp2' : sgz + ((det p2 (left_pt (low c1)) (right_pt (low c1)) : R ^o) <|u|> + det p1 (left_pt (low c1)) (right_pt (low c1))) = 1. + apply: conv_num_sg=> //. + apply: gtr0_sgz; rewrite ltNge; exact p2abol1. + rewrite -sgz_gt0; set (tmp := sgz _); suff -> : tmp = 1 by []. + rewrite {}/tmp; apply: conv_num_sg => //. + apply: conv_num_sg=> //. + apply: gtr0_sgz; rewrite ltNge; exact bzuabol1. + by apply: conv_num_sg. + have vx1 : ve_x vert_e = right_limit c1. + by have /andP[_ /eqP ->] := right_vertical_edge_wrt_high llr1 ok1 v1. + have lp2' : left_limit c1 < p2'.1. + rewrite conv_p1; apply: conv_num_gtl => //. + move: p2in=> /andP[] /eqP -> _. + by rewrite vx1. + by apply: ltW; move: p1in=> /andP[] _ /andP[]. + apply/andP; split. + rewrite conv_p1. + apply: conv_num_gtl=> //. + rewrite conv_p1. + apply: conv_num_gtl=> //; last by apply: ltW. + by move: bzuin; rewrite -/p3'=> /andP[] /eqP -> _; rewrite vx1. + rewrite conv_p1; apply/ltW/conv_num_gtl=> //; apply/ltW. + by move: p1in=> /andP[] _ /andP[]. + have p2'r : p2'.1 < right_limit c1. + rewrite conv_p1 convC. + apply: conv_num_ltr; first by lra. + by move: p1in=> /andP[] _ /andP[]. + by move: p2in=> /andP[] /eqP -> _; rewrite vx1. + apply: conv_num_ltr;[ done | | apply: ltW]. + rewrite conv_p1 convC; apply: conv_num_ltr => //; first by lra. + by move: bzuin=> /andP[] /eqP -> _; rewrite vx1. + apply: conv_num_ltr=> //; apply: ltW. + by move: p1in=> /andP[] _ /andP[]. +apply/orP; left; apply/orP; right. +have {P2}tgtu : u < t by lra. +set t' := (t - u) / (1 - u). +have tt' : t = u + t' * (1 - u) by rewrite /t' mulfVK; [ring | lra]. +have := bezier2_dichotomy_r (f3pt p1 p2 p3) t' u; rewrite -tt' /bzt => ->. +have [t1 | tn1] := eqVneq t 1. + rewrite /t' /= t1 divff; last by lra. + by rewrite subrr !(scale0r, add0r, addr0, scale1r). +have t'int : 0 < t' < 1. + rewrite /t'; apply/andP; split. + apply: divr_gt0; lra. + by rewrite ltr_pdivrMr; lra. +set p1' := bezier (f3pt p1 p2 p3) 2 u. +set p2' := p3 <| u |> p2. +rewrite [bezier _ 2 _](_ : _ = (p3 <| t' |> p2') <| t' |> (p2' <| t' |> p1')); + last first. + by rewrite !bezier_step_conv. +rewrite /strict_inside_closed -andbA; apply/andP; split. +rewrite /point_strictly_under_edge !det_conv. + have sgp3 : sgz (det p3 (left_pt (high c2)) (right_pt (high c2))) = -1. + by apply:ltr0_sgz; move: p3in=> /andP[] /andP[]. + have sgp2' : sgz + ((det p3 (left_pt (high c2)) (right_pt (high c2)) : R ^o) <|u|> + det p2 (left_pt (high c2)) (right_pt (high c2))) = -1. + apply: conv_num_sg=> //. + apply: ltr0_sgz; exact p2belh2. + rewrite -sgz_lt0; set (tmp := sgz _); suff -> : tmp = -1 by []. + rewrite {}/tmp; apply: conv_num_sg => //. + by apply: conv_num_sg. + apply: conv_num_sg=> //. + apply: ltr0_sgz; exact bzubelh2. +apply/andP; split. + rewrite /point_under_edge -ltNge. + rewrite !det_conv. + have sgp3 : sgz (det p3 (left_pt (low c2)) (right_pt (low c2))) = 1. + by apply: gtr0_sgz; move: p3in=> /andP[] /andP[] _; rewrite -ltNge. + have sgp2' : sgz + ((det p3 (left_pt (low c2)) (right_pt (low c2)) : R ^o) <|u|> + det p2 (left_pt (low c2)) (right_pt (low c2))) = 1. + apply: conv_num_sg=> //. + by apply: gtr0_sgz; rewrite ltNge; exact p2abol2. + rewrite -sgz_gt0; set (tmp := sgz _); suff -> : tmp = 1 by []. + rewrite {}/tmp; apply: conv_num_sg => //. + by apply: conv_num_sg. + apply: conv_num_sg=> //. + by apply: gtr0_sgz; rewrite ltNge; exact bzuabol2. +have vx2 : ve_x vert_e = left_limit c2. + have /andP[_ /eqP ->] := left_vertical_edge_wrt_high llr2 ok2 v2. + rewrite /left_limit; apply/eqP. + move: ok2=> /andP[] lc2n0 /andP[]. + move=> /allP /(_ (head dummy_pt (left_pts c2))) + _; apply. + by case : (left_pts c2) lc2n0 => [// | ? ?] _ /=; rewrite inE eqxx. +have p2'r : p2'.1 < right_limit c2. + apply: conv_num_ltr=> //. + by move: p3in=>/andP[] _ /andP[]. + move: p2in=> /andP[] /eqP -> _. + by rewrite vx2; apply: ltW. +apply/andP; split. + have p2'l : left_limit c2 < p2'.1. + apply: conv_num_gtl=> //. + by move: p3in=> /andP[] _ /andP[]. + by move: p2in=> /andP[] /eqP ->; rewrite vx2. + apply: conv_num_gtl;[done | | apply: ltW]. + apply: conv_num_gtl=> //. + by move: p3in=> /andP[] _ /andP[]. + by apply/ltW. + apply: conv_num_gtl=> //. + by move: bzuin=> /andP[] /eqP + _; rewrite -/p1' vx2 => ->. +apply: conv_num_ltr=> //. + apply: conv_num_ltr=> //. + by move: p3in=> /andP[] _ /andP[]. + by apply/ltW. +apply/ltW/conv_num_ltr=> //. +move: bzuin=> /andP[] + _; rewrite -/p1'=> /eqP ->. +by apply/ltW; rewrite vx2. +Qed. + +Definition midpoint (a b : Plane R) := a <| 1/2 |> b. + +Definition mkedge_aux (a b : Plane R) : {e : edge | + forall h : a.1 < b.1, e = Bedge h}. +case (boolP (a.1 < b.1)). +move=> h; exists (Bedge h)=> h0. + by rewrite (bool_irrelevance h h0). +move=> not_edge. +exists (@Bedge (0, 0) (1, 0) (ltr01 : (0,0).1 < (1, 0).1)). +by move=> h; case: (negP not_edge). +Defined. + +Definition mkedge (a b : Plane R) := sval (mkedge_aux a b). + +Lemma mkedgeE (a b : Plane R) (h : a.1 < b.1) : + mkedge a b = Bedge h. +Proof. +rewrite /mkedge; case: (mkedge_aux a b)=> v Pv /=; apply: Pv. +Qed. + +Fixpoint check_bezier_ccw (fuel : nat) (v : vert_edge) + (a b c : Plane R) : + option bool := +match fuel with +| O => None +| S p => + let top_edge := (ve_x v, ve_top v) in + if negb (point_under_edge top_edge (mkedge a c)) then + Some true + else if + point_under_edge top_edge (mkedge a b) || + point_under_edge top_edge (mkedge b c) + then + Some false + else + let b' := midpoint a b in + let b2 := midpoint b c in + let c' := midpoint b' b2 in + if c'.1 < ve_x v then + check_bezier_ccw p v c' b2 c + else if ve_x v < c'.1 then + check_bezier_ccw p v a b' c' + else + if c'.2 < ve_top v then + Some true + else + Some false +end. + +Lemma bezier_on_vertical_line (a b c : Plane R) (v : vert_edge) : + a.1 < b.1 < c.1 -> + {u | u \in `]0, 1[ & (bezier (f3pt a b c) 2 u).1 = b.1}. +Proof. +move=> abc. +set bezierx := + \sum_(i < 3) ((f3pt a b c) i).1 *: bernp 0 1 2 i - b.1%:P. +have bezierxq t : + (bezier (f3pt a b c) 2 t).1 = (bezierx + b.1%:P).[t]. + rewrite bezier_bernstein2 /bezierx. + rewrite addrNK !big_ord_recr /= !big_ord0 /= !add0r. + have expandscale (x y : R) : x *: (y : R^o) = x * y by []. + rewrite 3![in RHS] hornerE !hornerZ !expandscale. + (* Problem with the failure of ring here. *) + Fail ring. + by rewrite (mulrC a.1) (mulrC b.1) (mulrC c.1). +have bz0 : bezier (f3pt a b c) 2 0 = a. + by rewrite !bezier_step_conv /= !conv0. +have bz1 : bezier (f3pt a b c) 2 1 = c. + by rewrite !bezier_step_conv /= !conv1. +have : bezierx.[0] < 0. + move: (bezierxq 0); rewrite bz0 hornerE [X in _ + X]hornerE. + move=> /eqP; rewrite -subr_eq=> /eqP <-. + by rewrite subr_lt0; case/andP: abc. +have : 0 < bezierx.[1]. + move: (bezierxq 1); rewrite bz1 hornerE [X in _ + X]hornerE. + move=> /eqP; rewrite -subr_eq=> /eqP <-. + by rewrite subr_gt0; case/andP: abc. +move=> /gtr0_sg sg1 /ltr0_sg sg0. +have sgM : Num.sg bezierx.[0] * Num.sg bezierx.[1] = -1. + by rewrite sg1 sg0 mulr1. +have [u uint /rootP ur] := ivt_sign ler01 sgM. +exists u=> //. +by rewrite bezierxq hornerE ur add0r hornerE. +Qed. + +(* In triangle p q r, the distance from r to its projection on + line pq is det p q r / (q.1 - p.1) *) +Lemma diff_vert_y (a b c c' : Plane R) : + a.1 != b.1 -> + c' = (c.1, a.2 + (c.1 - a.1) / (b.1 - a.1) * (b.2 - a.2)) -> + (c.2 - c'.2 ) = det a b c / (b.1 - a.1). +Proof. +intros anb c'def. +have dn0 : b.1 - (a.1 : R^o) != 0. + by rewrite subr_eq0 eq_sym. +rewrite c'def /= (mulrAC _ _ (b.2 - a.2)) opprD addrA. +apply: (mulIf dn0); rewrite mulrBl !mulfVK //. +rewrite det_scalar_productE /rotate /scalar_product /= mulrN. +by rewrite mulrC; congr (_ - _); rewrite mulrC. +Qed. + +Lemma height_bezier2 (a b c p : Plane R) t: + a.1 < b.1 < c.1 -> + (* p is the vertical projection of bezier ... t on the straight line ab *) + det a b p = 0 -> + p.1 = (bezier (f3pt a b c) 2 t).1 -> + (bezier (f3pt a b c) 2 t).2 - p.2 = + t ^ 2 * det a b c / (b.1 - a.1). +Proof. +move=> abcdq p1q palign. +(* c' is the vertical projection of c on the straight line ab. *) +set c' := (c.1, a.2 + (c.1 - a.1) / (b.1 - a.1) * (b.2 - a.2)). +have anb : a.1 != b.1 by lra. +rewrite -[RHS]mulrA -(diff_vert_y anb erefl). +move: p1q palign => /eqP. +rewrite vert_projr; last by lra. +move=> /eqP /[dup] palign -> projP. +rewrite (mulrAC _ _ (b.2 - a.2)). +have dba : b.1 - a.1 != 0 by lra. +apply: (mulIf dba). +rewrite mulrBl (mulrDl b.2) mulfVK // projP. +rewrite (mulrBr (t ^ 2)) (mulrBl (b.1 - a.1)). +have tmp1 : t ^ 2 * c'.2 * (b.1 - a.1) = + t ^ 2 * (a.2 * ( b.1 - a.1) + (c.1 - a.1) * (b.2 - a.2)). + rewrite -mulrA; congr (_ * _). + by rewrite /= mulrDl (mulrAC _ _ (b.1 - a.1)) mulfVK. +rewrite !bezier_step_conv /=. +have tmp x (y : R^o) : x *: y = x * y by []. +rewrite !tmp tmp1 /=. +ring. +Qed. + +Lemma safe_bezier_ccw_corner_side (a b c : Plane R) (v : vert_edge) + (u : R): + ccw a b c -> + a.1 < b.1 < c.1 -> + a.1 < ve_x v < c.1 -> + on_vert_edge b v -> + u \in `]0, 1[ -> + (bezier (f3pt a b c) 2 u).1 = ve_x v -> + ve_bot v < (bezier (f3pt a b c) 2 u).2. +Proof. +move=> abc abc1 avc bon uin bzx. +move: (bon) => /andP[] /eqP bx /andP[]bl bh. +apply: (lt_trans bl). +rewrite -subr_gt0. +have abb : det a b b = 0. + by rewrite det_cyclique det_alternate. +have bzxb : b.1 = (bezier (f3pt a b c) 2 u).1 by rewrite bzx. +rewrite (height_bezier2 abc1 abb bzxb). +apply: divr_gt0; last by lra. +apply: mulr_gt0; last by []. +rewrite in_itv /= in uin. +have tmp : 0 < u < 1 by exact uin. +apply: mulr_gt0; lra. +Qed. + +Lemma under_proj e p : + valid_edge e p -> (p <<= e) = (p.2 <= (left_pt e).2 + + (p.1 - (left_pt e).1) * ((right_pt e).2 - (left_pt e).2) / + ((right_pt e).1 - (left_pt e).1)). +Proof. +move=> vep. +rewrite /point_under_edge det_cyclique. +have ecnd := edge_cond e. +have ecnd' : (left_pt e).1 != (right_pt e).1 by lra. +set p' := (p.1, (left_pt e).2 + (p.1 - (left_pt e).1) / + ((right_pt e).1 - (left_pt e).1) * + ((right_pt e).2 - (left_pt e).2)). +have := diff_vert_y ecnd'=> /(_ p p' erefl) /eqP. +rewrite subr_eq=> /eqP ->; rewrite /p' /=. +rewrite addrA (addrC _ (left_pt e).2) -!addrA. +rewrite lerD2. +rewrite addrC -lerBrDl mulrAC addrN. +rewrite pmulr_lle0 // invr_gt0/=. +by rewrite subr_gt0. +Qed. + +Lemma safe_bezier_ccw (a b c : Plane R) (v : vert_edge) (u : R) : + ccw a b c -> + a.1 < b.1 < c.1 -> + a.1 < ve_x v < c.1 -> + ~~((ve_x v, ve_top v) <<= mkedge a c) -> + u \in `]0, 1[ -> + (bezier (f3pt a b c) 2 u).1 = ve_x v -> + ve_bot v < (bezier (f3pt a b c) 2 u).2 -> + on_vert_edge (bezier (f3pt a b c) 2 u) v. +Proof. +move=> abc bint vint topP uin /[dup] bzx /eqP bzxb bzb. +rewrite /on_vert_edge bzxb bzb 2!andTb. +have ac_cond : a.1 < c.1 by lra. +have vav : valid_edge (mkedge a c) (ve_x v, ve_top v). + rewrite/valid_edge mkedgeE [(left_pt _).1]/= [(right_pt _).1]/=. + by rewrite ?ltW //; move: vint=> /andP[]. +move: topP. +rewrite (under_proj vav) -ltNge; apply le_lt_trans. +rewrite (_ : (ve_x v, ve_top v).1 = (bezier (f3pt a b c) 2 u).1); last first. + by rewrite bzx. +rewrite -under_proj; last by rewrite /valid_edge bzx; exact: vav. +rewrite /point_under_edge. +rewrite bezier_step_conv. +have vacp : valid_edge (mkedge a c) (bezier (f3pt a b c) 2 u). + rewrite/valid_edge mkedgeE [(left_pt _).1]/= [(right_pt _).1]/= bzx. + by rewrite ?ltW //; move: vint=> /andP[]. +rewrite det_conv -sgz_le0. +have Cuin : 0 < 1 - u < 1 by rewrite in_itv /= in uin; lra. +set X := (X in X <= 0). +suff : X = -1. + (* TODO : report + Fail Timeout 2 lra. *) + by move=> ->; apply: lerN10. +rewrite {}/X. +apply: conv_num_sg=> //. + apply: ltr0_sgz. + rewrite bezier_step_conv det_conv. + rewrite convC. + apply: conv_num_ltr=> //. + rewrite /=; move: abc; rewrite /ccw mkedgeE /= => abc. + by rewrite det_inverse oppr_lte0 -det_cyclique. + by rewrite /= mkedgeE /= -det_cyclique det_alternate. +apply: ltr0_sgz. +rewrite bezier_step_conv det_conv. +apply: conv_num_ltr=> //. + rewrite /=; move: abc; rewrite /ccw mkedgeE /= => abc. + by rewrite det_inverse oppr_lte0 -det_cyclique. +by rewrite mkedgeE /= det_alternate. +Qed. + +End sandbox. diff --git a/theories/encompass.v b/theories/encompass.v new file mode 100644 index 0000000..ea9c1e7 --- /dev/null +++ b/theories/encompass.v @@ -0,0 +1,224 @@ +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import reals ereal classical_sets. +Require Export preliminaries preliminaries_hull axiomsKnuth. + +(******************************************************************************) +(* encompass oriented s l == oriented is a ternary relation, s and l *) +(* are lists of points such that *) +(* oriented l_i l_i.+1 s_k for all i and k *) +(* encompass_aux oriented l h == h describes an open convex region that *) +(* contains l *) +(* encompass oriented l h == h describes a convex hull for the set of *) +(* points l where the last segment is formed by *) +(* the last and first elements *) +(******************************************************************************) + +Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory. + +Local Open Scope ring_scope. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section spec. +Variable plane : zmodType. +Variable oriented : plane -> plane -> plane -> bool. + +Definition is_left (p q r : plane) := [|| r == p, r == q | oriented p q r]. +Hint Unfold is_left : core. + +Definition all_left (x y : plane) : seq plane -> bool := all (is_left x y). + +Fixpoint encompass_aux (l h : seq plane) : bool := + match h with + | nil => false + | t1 :: nil => true + | t1 :: ((t2 :: _) as h') => all_left t1 t2 l && encompass_aux l h' + end. + +Definition encompass (s h : seq plane) := + match h with + | nil => false + | t :: h' => encompass_aux s (last t h' :: h) + end. + +Lemma encompassl0 l : encompass l [::] = false. +Proof. by []. Qed. + +Definition convexHullSpec (l h : seq plane) := + uniq h && all (mem l) h && encompass l h. + +(* TOTHINK: replace encompass : seq -> seq -> bool by a predicate + seq -> plane -> bool? *) + +Lemma encompass_auxE (l h : seq plane) : + encompass_aux l h = (h != [::]) && all (fun x => encompass_aux [:: x] h) l. +Proof. +elim: h =>// a'; case=> [ _ | b' l' IHl']. + by elim: l. +rewrite /= -/(encompass_aux l (b' :: l')) IHl' -all_predI; apply eq_all=>x. +by rewrite /= andbT. +Qed. + +Lemma encompassE (s h : seq plane) : + encompass s h = (h != [::]) && all (fun x => encompass [:: x] h) s. +Proof. by case: h =>// a l; rewrite {1}/encompass encompass_auxE. Qed. + +Lemma encompass_aux_all_index (l h : seq plane) : + encompass_aux l h = (h != [::]) && + [forall i : 'I_(size h), (i.+1mod == 0%N :> nat) || all_left h`_i h`_i.+1mod l]. +Proof. +elim: h=>// a; case. + by move=>/= _; apply/esym/forallP => i; rewrite modn1 eq_refl. +move=>b l' IHl' /=; rewrite -/(encompass_aux l (b :: l')) IHl' /=. +apply/idP/idP => [/andP[Habl H]|/forallP H]. + apply/forallP => -[] [//|n/=]. + rewrite ltnS => nlt. + move: H => /forallP/(_ (Ordinal nlt)). + move: nlt (nlt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> mm _|nm nm1]. + by rewrite modnn eqxx. + by rewrite modn_small ?ltnS// modn_small ?ltnS. +apply/andP; split; first by move: H => /(_ ord0). +apply/forallP => -[i ilt]. +move: H => /(_ (lift ord0 (Ordinal ilt))). +move: ilt (ilt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> mm _|ilt ilt1]. + by rewrite modnn eqxx. +by rewrite modn_small ?ltnS// modn_small ?ltnS. +Qed. + +Lemma encompass_all_index (l s : seq plane) : encompass s l = + (l != [::]) && [forall i : 'I_(size l), all_left l`_i l`_i.+1mod s]. +Proof. +case: l => // a l /=. +rewrite -/(encompass_aux s (a :: l)) encompass_aux_all_index. +apply/idP/idP => [H|/forallP H]. + apply/forallP => -[i ilt]. + move: ilt (ilt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> /= _|ilt ilt1]. + by rewrite modnn nth_last /=; move: H => /andP[H _]. + move: H => /andP[_ /andP [_ /forallP]] /(_ (Ordinal ilt1)) /=. + by rewrite modn_small ?ltnS. +apply/andP; split. + by move: H => /(_ ord_max); rewrite /= modnn nth_last. +apply/forallP => -[i ilt]. +move: ilt (ilt); rewrite {1}ltnS leq_eqVlt => /predU1P[-> /= _|ilt ilt1]. + by rewrite modnn. +by move: H => /(_ (Ordinal ilt1))/=; rewrite modn_small ?ltnS. +Qed. + +End spec. + +Module SpecKA (KA : KnuthAxioms). +Section Dummy. +Variable R : realType. +Let plane : vectType _ := (R^o * R^o)%type. + +Let oriented := KA.OT (R:=R). +Let Ax1 := KA.Axiom1 (R:=R). +Let Ax2 := KA.Axiom2 (R:=R). +Let Ax5 := KA.Axiom5 (R:=R). +Let Ax5' := KA.Axiom5' (R:=R). + +Lemma encompassll_spec (l : seq plane) : uniq l -> + encompass oriented l l = + (l != [::]) && + [forall i : 'I_(size l), [forall j : 'I_(size l), [forall k : 'I_(size l), + (i < j < k)%N ==> oriented l`_i l`_j l`_k]]]. +Proof. +move=> /uniqP-/(_ 0%R) lu; apply/idP/idP. + rewrite encompassE => /andP[-> /allP] ll /=. + have sD i j : (i.+1 < size l)%N -> (j < size l)%N -> j != i -> j != i.+1 -> + oriented l`_i l`_i.+1 l`_j. + move=> isl jl ji jis. + have /ll : l`_j \in l by rewrite mem_nth. + have il : (i < size l)%N by rewrite (leq_trans _ isl). + rewrite encompass_all_index => /andP[_] /forallP /(_ (Ordinal il)) /=. + rewrite Zp_succE andbT/= modn_small// => /or3P[| |//] /eqP/lu; rewrite 2!inE. + by move=> /(_ jl il)/eqP; rewrite (negbTE ji). + by move=>/(_ jl isl)/eqP; rewrite (negbTE jis). + apply/'forall_'forall_'forall_implyP => -[i ilt] [j jlt] [k klt] /= /andP[ij jk]. + elim: k => // k IHk in klt jk *. + have {}IHk := IHk (ltnW klt). + move: jk; rewrite leq_eqVlt => /predU1P[[jk]|]. + subst j. + do 2 apply: Ax1. + apply: sD => //; first by rewrite ltn_eqF. + by rewrite ltn_eqF// (leq_trans ij). + rewrite ltnS => jk; have {}IHk := IHk jk. + move: ij; rewrite leq_eqVlt => /predU1P[ij|ij]. + subst j. + apply: sD => //. + by rewrite gtn_eqF// ltnS (leq_trans _ jk)// -addn2 leq_addr. + by rewrite gtn_eqF// (leq_trans jk). + apply: (@Ax5 _ l`_i.+1 _ l`_k). + - apply: sD => //; first by rewrite (leq_trans ij)// ltnW. + by rewrite gtn_eqF// (ltn_trans _ ij). + by rewrite gt_eqF. + - apply: sD; first by rewrite (leq_trans ij)// ltnW. + by rewrite (ltn_trans _ klt). + by rewrite gtn_eqF// (ltn_trans _ jk)// (ltn_trans _ ij). + by rewrite gtn_eqF// (ltn_trans ij). + - apply: sD => //; first by rewrite (leq_trans ij)// ltnW. + rewrite gtn_eqF// ltnS (leq_trans _ (ltnW jk))// (leq_trans _ ij)//. + by rewrite -addn2 leq_addr. + by rewrite gtn_eqF// (leq_trans ij)// (leq_trans (ltnW jk)). + - exact IHk. + - do 2 apply Ax1. + apply: sD => //. + by rewrite ltn_eqF// (ltn_trans _ jk)// (leq_trans _ ij). + by rewrite ltn_eqF// ltnS (leq_trans _ (ltnW jk))// ltnW// (ltn_trans _ ij). +rewrite encompassE => /andP[l0 sD] /=; rewrite l0 /=. +have id x : x \in l -> exists2 n, (n < size l)%N & l`_n = x. + by move=> xl; exists (index x l); [rewrite index_mem|rewrite nth_index]. +apply/allP => _ /id[i il <-]. +rewrite encompass_all_index; rewrite l0; apply/forallP => -[j jlt]. +rewrite /all_left/= /is_left/= andbT. +have [->|ij] := eqVneq i j. + exact/or3P/Or31. +destruct l as [|a l] => //=. +have [ijs|ijs] := eqVneq i (j.+1 %% (size l).+1)%N. + by apply/or3P/Or32; rewrite -ijs. +apply/or3P/Or33; move: jlt; rewrite leq_eqVlt => /predU1P[[je]|jlt]. + subst j; rewrite modnn. + do 2 apply Ax1. + move: sD => /'forall_'forall_'forall_implyP + /(_ ord0 (Ordinal il) (Ordinal (leqnn _))); + apply => /=. + rewrite lt0n. + move: ijs; rewrite modnn => ->/=. + move: il; rewrite leq_eqVlt => /predU1P[[/eqP]|]. + by rewrite (negbTE ij). + by rewrite ltnS. +move:ijs; rewrite modn_small => // ijs. +have [ji|ji] := ltnP j.+1 i. + move: sD => /'forall_'forall_'forall_implyP + /(_ (Ordinal (leq_trans (leqnSn _) jlt)) (Ordinal jlt) (Ordinal il)). + apply => /=. + by rewrite ltnS leqnn. +apply: Ax1. +move: sD => /'forall_'forall_'forall_implyP + /(_ (Ordinal il) (Ordinal (leq_trans (leqnSn _) jlt)) (Ordinal jlt)). +apply => /=. +rewrite ltnS leqnn andbT ltnNge. +rewrite leq_eqVlt eq_sym (negbTE ij)/=. +rewrite leq_eqVlt eq_sym (negbTE ijs)/=. +by rewrite ltnNge ji. +Qed. + +Lemma encompassll_subseq (l l' : seq plane) : uniq l -> + encompass oriented l l -> + subseq l' l -> + l' != [::] -> + encompass oriented l' l'. +Proof. +move=> lu; rewrite (encompassll_spec lu) => ll l'l l'0. +have l'u := subseq_uniq l'l lu; rewrite (encompassll_spec l'u) l'0 /=. +apply/'forall_'forall_'forall_implyP => i j k /andP[ij jk]. +move: l'l => /subseq_incl-/(_ 0%R) [f [fl flt]]. +move: ll => /andP[_] /'forall_'forall_'forall_implyP + /(_ (f i)) /(_ (f j)) /(_ (f k)); rewrite 3!fl; apply. +by apply/andP; split; apply: flt. +Qed. + +End Dummy. +End SpecKA. diff --git a/theories/generic_trajectories.v b/theories/generic_trajectories.v new file mode 100644 index 0000000..b665b3d --- /dev/null +++ b/theories/generic_trajectories.v @@ -0,0 +1,1139 @@ +From mathcomp Require Import all_ssreflect. +Require Import ZArith (* List *) String OrderedType OrderedTypeEx FMapAVL. +Require Import shortest_path. + +Notation head := seq.head. +Notation sort := path.sort. + +(* I did not have the courage to understand how to use CoqEAL + this first version uses only vanilla Coq data structures. It could still + use more mathcomp functions, like "has" instead of "existsb" *) + +(* FIRST PART: Vertical cell decomposition. *) +(********************************************) +(* The first data structures and algorithms are taken from + github.com/ybertot/VerticalCells, which was initially a master internship + by Thomas Portet. *) +(* The main function is edges_to_cells. The input should respect + data invariants: + - all edge extremities are inside the box defined by the bottom and + top edge + - all edges should have a left_pt that has a lower x coordinate than the + right_pt + - no two edges should cross. + At the time of writing these lines, the proof of correctness is not + complete, due to the complexity of the function "step". Three important + properties need to be satisfied: + - edges given in the input never collide with the interior of cells, + - points in the left_pts and right_pts sequences are vertically aligned + and are the only potentially colliding points in these segments + - the elements of left_pts have an x coordinate that is strictly smaller than + the elements of right_pts *) + +Notation seq := list. + +Section generic_implementation. + +(* In the original development R has type numFieldType and the various + operations are taken from that structure. *) +Variable R : Type. + +Variables R_eqb R_leb : R -> R -> bool. + +Variables R_add R_sub R_mul R_div : R -> R -> R. + +Definition R_ltb : R -> R -> bool := + fun x y => andb (negb (R_eqb x y)) (R_leb x y). + +Notation "x * y" := (R_mul x y). + +Notation "x - y" := (R_sub x y). + +Notation "x + y" := (R_add x y). + +Notation "x / y" := (R_div x y). + +Variable pt_distance : R -> R -> R -> R -> R. + +Variable R1 : R. + +Let R0 := R_sub R1 R1. + +Let R2 := R_add R1 R1. + +Record pt := Bpt {p_x : R; p_y : R}. +(* In the original development, edge have the data invariant that + the left point has a first coordinate strictly less than the right point. *) + +Variable edge : Type. +Variable Bedge : pt -> pt -> edge. +Variables left_pt right_pt : edge -> pt. + +Definition same_x (p : pt) (v : R) := + R_eqb (p_x p) v. + +Record event := + Bevent {point : pt; outgoing : seq edge}. + +Record cell := Bcell {left_pts : list pt; right_pts : list pt; + low : edge; high : edge}. + +Definition dummy_pt := ({| p_x := R1; p_y := R1|}). + +Definition dummy_edge := Bedge dummy_pt dummy_pt. + +Definition dummy_cell := + {| left_pts := nil; right_pts := nil; low := dummy_edge; high := dummy_edge|}. + +Definition dummy_event := + {| point := dummy_pt; outgoing := nil|}. + +(* In the original development pt, edge, and cell are eq_types *) +Definition pt_eqb (a b : pt) : bool := + let: Bpt a_x a_y := a in + let: Bpt b_x b_y := b in + (R_eqb a_x b_x) && (R_eqb a_y b_y). + +Definition edge_eqb (g1 g2 : edge) : bool := + pt_eqb (left_pt g1) (left_pt g2) && pt_eqb (right_pt g1) (right_pt g2). + +(* The boolean value inc stands for incoming, meaning that we are looking *) +(* at the right extremity of an edge. *) +Fixpoint add_event (p : pt) (e : edge) (inc : bool) (evs : seq event) : + seq event := + match evs with + | nil => if inc then (Bevent p nil :: nil) + else (Bevent p (e :: nil) :: nil) + | ev1 :: evs' => + let p1 := point ev1 in + if pt_eqb p p1 then + if inc then Bevent p1 (outgoing ev1) :: evs' + else Bevent p1 (e :: outgoing ev1) :: evs' else + if R_ltb (p_x p) (p_x p1) then + if inc then + Bevent p nil :: evs else + Bevent p (e :: nil) :: evs + else if R_eqb (p_x p) (p_x p1) && R_ltb (p_y p) (p_y p1) then + if inc then + Bevent p nil :: evs else + Bevent p (e :: nil) :: evs else + ev1 :: add_event p e inc evs' + end. + +Fixpoint edges_to_events (s : seq edge) : seq event := + match s with + | nil => nil + | e :: s' => + add_event (left_pt e) e false + (add_event (right_pt e) e true (edges_to_events s')) + end. + +(* this function removes consecutives duplicates, meaning the seq needs + to be sorted first if we want to remove all duplicates *) +Fixpoint no_dup_seq_aux [A : Type] (eqb : A -> A -> bool) (s : seq A) : (seq A) := + match s with + | nil => nil + | a::q => + match q with + | nil => s + | b::r => + if eqb a b then no_dup_seq_aux eqb q else a::(no_dup_seq_aux eqb q) + end + end. + +Notation no_dup_seq := (no_dup_seq_aux pt_eqb). + +Definition valid_edge e p := (R_leb (p_x (left_pt e)) (p_x p)) && +(R_leb (p_x p) (p_x (right_pt e))). + +(* TODO: check again the mathematical formula after replacing the infix *) +(* operations by prefix function calls. *) +Definition vertical_projection (p : pt) (e : edge) : option pt := + if valid_edge e p then + Some(Bpt (p_x p) (R_add + (R_mul (R_sub (p_x p) (p_x (left_pt e))) + (R_div (R_sub (p_y (right_pt e)) (p_y (left_pt e))) + (R_sub (p_x (right_pt e)) (p_x (left_pt e))))) + (p_y (left_pt e)))) + else None. + +Section area3_def. + +Local Notation "x + y" := (R_add x y). +Local Notation "x - y" := (R_sub x y). +Local Notation "x * y" := (R_mul x y). + +Definition area3' (a : pt) (b : pt) (c : pt) : R := + let: Bpt a_x a_y := a in + let: Bpt b_x b_y := b in + let: Bpt c_x c_y := c in + (((c_x * a_y - a_x * c_y) - + (b_x * a_y - a_x * b_y)) + + b_x * c_y) - c_x * b_y. + +Definition area3 (a : pt) (b : pt) (c : pt) : R := + let: Bpt a_x a_y := a in + let: Bpt b_x b_y := b in + let: Bpt c_x c_y := c in + b_x * c_y + a_x * b_y + c_x * a_y - + b_x * a_y - a_x * c_y - c_x * b_y. + +End area3_def. + +Definition point_under_edge (p : pt) (e : edge) : bool := + R_leb (area3 p (left_pt e) (right_pt e)) R0. + +Notation "p >>> g" := (negb (point_under_edge p g)) + (at level 70, no associativity). + +Definition point_strictly_under_edge (p : pt) (e : edge) : bool := + R_ltb (area3 p (left_pt e) (right_pt e)) R0. + +Notation "p <<< g" := (point_strictly_under_edge p g) + (at level 70, no associativity). + +Definition edge_below (e1 : edge) (e2 : edge) : bool := +(point_under_edge (left_pt e1) e2 && + point_under_edge (right_pt e1) e2) +|| (negb (point_strictly_under_edge (left_pt e2) e1) && + negb (point_strictly_under_edge (right_pt e2) e1)). + +Definition inter_at_extb (e1 e2 : edge) : bool := + (pt_eqb (left_pt e1) (left_pt e2) && + pt_eqb (left_pt e1) (left_pt e2)) || + ((edge_below e1 e2 || edge_below e2 e1) && + ((R_eqb (area3 (left_pt e2) (right_pt e2) (left_pt e1) ) R0 && + valid_edge e2 (left_pt e1)) ==> + (pt_eqb (left_pt e1) (left_pt e2) || pt_eqb (left_pt e1) (right_pt e2))) && + ((R_eqb (area3 (left_pt e2) (right_pt e2) (right_pt e1)) R0 && + valid_edge e2 (right_pt e1)) ==> + (pt_eqb (right_pt e1) (left_pt e2) || pt_eqb (right_pt e1) (right_pt e2))) && + ((R_eqb (area3 (left_pt e1) (right_pt e1) (left_pt e2)) R0 && + valid_edge e1 (left_pt e2)) ==> + (pt_eqb (left_pt e2) (left_pt e1) || pt_eqb (left_pt e2) (right_pt e1))) && + ((R_eqb (area3 (left_pt e1) (right_pt e1) (right_pt e2)) R0 && + valid_edge e1 (right_pt e2)) ==> + (pt_eqb (right_pt e2) (left_pt e1) || pt_eqb (right_pt e2) (right_pt e1)))). + +Fixpoint no_intersections (s : seq edge) : bool := + match s with + | nil => true + | a :: s' => forallb (inter_at_extb a) s' && no_intersections s' + end. + +Definition contains_point (p : pt) (c : cell) : bool := + negb (point_strictly_under_edge p (low c)) && point_under_edge p (high c). + +Definition close_cell (p : pt) (c : cell) := + match vertical_projection p (low c), + vertical_projection p (high c) with + | None, _ | _, None => c + | Some p1, Some p2 => + Bcell (left_pts c) (no_dup_seq (p2 :: p :: p1 :: nil)) (low c) (high c) + end. + +Definition closing_cells (p : pt) (contact_cells: seq cell) : seq cell := + List.map (fun c => close_cell p c) contact_cells. + +Definition pvert_y (p : pt) (e : edge) := + match vertical_projection p e with + Some p' => p_y p' + | None => R0 + end. + +Fixpoint opening_cells_aux (p : pt) (out : seq edge) (low_e high_e : edge) + : seq cell * cell := + match out with + | [::] => + let op0 := vertical_projection p low_e in + let op1 := vertical_projection p high_e in + match (op0,op1) with + | (None,_) | (_,None) => ([::], dummy_cell) + | (Some p0,Some p1) => + ([::] , Bcell (no_dup_seq ([:: p1; p; p0])) [::] low_e high_e) + end + | c::q => + let op0 := vertical_projection p low_e in + let (s, nc) := opening_cells_aux p q c high_e in + match op0 with + | None => ([::], dummy_cell) + | Some p0 => + (Bcell (no_dup_seq [:: p; p0]) [::] low_e c :: s, nc) + end + end. + +Fixpoint open_cells_decomposition_contact open_cells pt : + option (seq cell * seq cell * cell) := +if open_cells is c :: q then + if contains_point pt c then + if open_cells_decomposition_contact q pt is Some(cc, lc, c') then + Some(c :: cc, lc, c') + else + Some([::], q, c) + else + None +else + None. + +Fixpoint open_cells_decomposition_rec open_cells pt : + seq cell * seq cell * cell * seq cell := +if open_cells is c :: q then + if contains_point pt c then + if open_cells_decomposition_contact q pt is Some(cc, lc, c') then + ([::], c :: cc, c', lc) + else + ([::], [::], c, q) + else + let '(fc, cc, c', lc) := open_cells_decomposition_rec q pt in + (c :: fc, cc, c', lc) +else + ([::], [::], dummy_cell, [::]). + +Definition open_cells_decomposition (open_cells : seq cell) (p : pt) : + seq cell * seq cell * cell * seq cell * edge * edge := +let '(fc, cc, c', lc) := open_cells_decomposition_rec open_cells p in +(fc, cc, c', lc, low (head c' cc), high c'). + +Record scan_state := + Bscan {sc_open1 : seq cell; + lst_open : cell; + sc_open2 : seq cell; + sc_closed : seq cell; + lst_closed : cell; + lst_high : edge; + lst_x : R}. + +Definition update_closed_cell (c : cell) (p : pt) : cell := + let ptseq := right_pts c in + let newptseq := seq.head dummy_pt ptseq :: p :: behead ptseq in + Bcell (left_pts c) newptseq (low c) (high c). + +Definition set_left_pts (c : cell) (l : seq pt) := + {| left_pts := l; right_pts := right_pts c; low := low c; high := high c |}. + +Definition set_pts (c : cell) (l1 l2 : seq pt) := + {| left_pts := l1; right_pts := l2; low := low c; high := high c |}. + +(* This function is to be called only when the event is in the middle + of the last opened cell. The point e needs to be added to the left + points of one of the newly created open cells, but the one that receives + the first segment of the last opening cells should keep its existing + left points.*) +Definition update_open_cell (c : cell) (e : event) : seq cell * cell := + let ps := left_pts c in + if outgoing e is [::] then + ([::], set_left_pts c [:: head dummy_pt ps, point e & behead ps]) + else + match + opening_cells_aux (point e) (sort edge_below (outgoing e)) + (low c) (high c) with + | ([::], c') => (* this is an absurd case. *) + ([::], c) + | (c'::tlc', lc') => + (set_left_pts c' (point e :: behead ps) :: tlc', lc') + end. + +Definition update_open_cell_top (c : cell) (new_high : edge) (e : event) := + if outgoing e is [::] then + let newptseq := +(* when function is called, (point e) should alread be in the left points. *) + [:: Bpt (p_x (point e)) (pvert_y (point e) new_high) & + left_pts c] in + ([::], Bcell newptseq (right_pts c) (low c) new_high) + else + match opening_cells_aux (point e) (sort edge_below (outgoing e)) + (low c) new_high with + | ([::], lc) => (* this is not supposed to happen *) ([::], lc) + | (f :: q, lc) => + (set_left_pts f (point e :: behead (left_pts c)) :: q, lc) + end. + +Definition simple_step (fc cc lc : seq cell) (lcc : cell) (le he : edge) + (closed_cells : seq cell) (last_closed : cell) ev := + let new_closed := closing_cells (point ev) cc in + let last_new_closed := close_cell (point ev) lcc in + let closed_cells' := closed_cells ++ last_closed :: new_closed in + let (nos, lno) := + opening_cells_aux (point ev) (sort edge_below (outgoing ev)) le he in + Bscan (fc ++ nos) lno lc closed_cells' last_new_closed he (p_x (point ev)). + +Definition step (st : scan_state) (e : event) : scan_state := + let p := point e in + let '(Bscan op1 lsto op2 cls cl lhigh lx) := st in + if negb (same_x p lx) then + let '(first_cells, contact_cells, last_contact, last_cells, + lower_edge, higher_edge) := + open_cells_decomposition (op1 ++ lsto :: op2) p in + simple_step first_cells contact_cells last_cells last_contact + lower_edge higher_edge cls cl e + else if p >>> lhigh then + let '(fc', contact_cells, last_contact, last_cells, + low_edge, higher_edge) := + open_cells_decomposition op2 p in + let first_cells := op1 ++ lsto :: fc' in + simple_step first_cells contact_cells last_cells last_contact + low_edge higher_edge cls cl e + else if p <<< lhigh then + let new_closed := update_closed_cell cl (point e) in + let (new_opens, new_lopen) := update_open_cell lsto e in + Bscan (op1 ++ new_opens) new_lopen op2 cls new_closed lhigh lx + else (* here p === lhigh *) + let '(fc', contact_cells, last_contact, last_cells, lower_edge, + higher_edge) := + open_cells_decomposition (lsto :: op2) p in + (* we know lsto was just open, so that its left limit is lx + and its right limit is bounded by p_x (right_pt lhigh), which + is necessarily p_x (point e). lsto is necessarily the + first cell of contact_cells. So the first element of + contact_cells should not be closed. It can just be + disregarded. *) + let closed := closing_cells p (seq.behead contact_cells) in + let last_closed := close_cell p last_contact in + let (new_opens, new_lopen) := update_open_cell_top lsto higher_edge e in + Bscan (op1 ++ fc' ++ new_opens) new_lopen last_cells + (closed ++ cl :: cls) last_closed higher_edge lx. + +Definition leftmost_points (bottom top : edge) := + if R_ltb (p_x (left_pt bottom)) (p_x (left_pt top)) then + if vertical_projection (left_pt top) bottom is Some pt then + no_dup_seq [:: left_pt top; pt] + else + [::] + else + if vertical_projection (left_pt bottom) top is Some pt then + no_dup_seq [:: pt; left_pt bottom] + else + [::]. + +Definition rightmost_points (bottom top : edge) := + if R_ltb (p_x (right_pt bottom)) (p_x (right_pt top)) then + if vertical_projection (right_pt bottom) top is Some pt then + [:: pt; right_pt bottom] + else + [::] + else + if vertical_projection (right_pt top) bottom is Some pt then + no_dup_seq [:: right_pt top; pt] + else + [::]. + +Definition complete_last_open (c : cell) := + match c with + | Bcell lpts rpts le he => + Bcell lpts (rightmost_points le he) le he + end. + +Definition midpoint (p1 p2 : pt) : pt := + {| p_x := R_div (R_add (p_x p1) (p_x p2)) R2; + p_y := R_div (R_add (p_y p1) (p_y p2)) R2|}. + + (* The center of the cell is computed using the middle of the high edge + the middle of the low edge, and their middle. *) + +Definition cell_center (c : cell) := + midpoint + (midpoint (seq.last dummy_pt (left_pts c)) + (head dummy_pt (right_pts c))) + (midpoint (head dummy_pt (left_pts c)) + (seq.last dummy_pt (right_pts c))). + +Definition start_open_cell (bottom top : edge) := + Bcell (leftmost_points bottom top) [::] bottom top. + +Definition start (first_event : event) (bottom : edge) (top : edge) : + scan_state := + let (newcells, lastopen) := + opening_cells_aux (point first_event) + (path.sort edge_below (outgoing first_event)) bottom top in + (Bscan newcells lastopen [::] [::] + (close_cell (point first_event) (start_open_cell bottom top)) + top (p_x (point first_event))). + +Definition left_limit (c : cell) := p_x (seq.head dummy_pt (left_pts c)). + +Definition right_limit c := p_x (seq.head dummy_pt (right_pts c)). + +Definition cmp_option := cmp_option _ R_ltb. + +Definition strict_inside_closed p c := + negb (point_under_edge p (low c)) && + point_strictly_under_edge p (high c) && + (R_ltb (left_limit c) (p_x p) && + (R_ltb (p_x p) (right_limit c))). + +Definition bare_closed_cell_side_limit_ok c := + [&& size (left_pts c) != 0%N, + all (fun p : pt => R_eqb (p_x p) (left_limit c)) (left_pts c), + sorted (fun x y => R_ltb y x) [seq p_y p | p <- left_pts c], + (R_eqb + (area3 (head dummy_pt (left_pts c)) (left_pt (high c)) (right_pt (high c))) + R0 && valid_edge (high c) (head dummy_pt (left_pts c))), + (R_eqb + (area3 (seq.last dummy_pt (left_pts c)) (left_pt (low c)) (right_pt (low c))) + R0 && valid_edge (low c) (seq.last dummy_pt (left_pts c))), + size (right_pts c) != 0%N, + all (fun p : pt => R_eqb (p_x p) (right_limit c)) (right_pts c), + sorted (fun x y => R_ltb y x) [seq p_y p | p <- right_pts c], + (R_eqb (area3 (head dummy_pt (right_pts c)) + (left_pt (high c)) (right_pt (high c))) R0 && + valid_edge (high c) (head dummy_pt (right_pts c))) & + (R_eqb (area3 (seq.last dummy_pt (right_pts c)) (left_pt (low c)) + (right_pt (low c))) + R0 && valid_edge (low c) (seq.last dummy_pt (right_pts c)))]. + +Definition check_bounding_box (bottom top : edge) := + let cc := complete_last_open (start_open_cell bottom top) in + edge_below bottom top && + R_ltb (left_limit cc) (right_limit cc) && + bare_closed_cell_side_limit_ok cc && + strict_inside_closed (cell_center cc) cc. + +Definition complete_process (bottom top : edge) (events : seq event) : seq cell := + match events with + | [::] => + if check_bounding_box bottom top then + [:: complete_last_open (start_open_cell bottom top)] + else + [::] + | ev0 :: events => + let start_scan := start ev0 bottom top in + let final_scan := foldl step start_scan events in + map complete_last_open + (sc_open1 final_scan ++ lst_open final_scan :: sc_open2 final_scan) ++ + lst_closed final_scan :: sc_closed final_scan + end. + +(* This is the main function of vertical cell decomposition. *) +Definition edges_to_cells bottom top edges := + complete_process bottom top (edges_to_events edges). + +(* SECOND PART : computing a path in the cell graph *) +(* To compute a path that has reasonable optimzation, we compute a shortest *) +(* path between reference points chosen inside doors. *) + +(* defining the connection relation between adjacent cells. Two cells + are adjacent when it is possible to move from one cell directly to the + other without colliding an obstacle edge. In the data structure, it means + that they share a vertical edge. *) +Record vert_edge := + { ve_x : R; ve_top : R; ve_bot : R}. + +Definition vert_edge_eqb (v1 v2 : vert_edge) := + let: Build_vert_edge v1x v1t v1b := v1 in + let: Build_vert_edge v2x v2t v2b := v2 in + R_eqb v1x v2x && R_eqb v1t v2t && R_eqb v1b v2b. + +(* the lists of points left_pts and right_pts for each cell define the + extremities of the doors, but we wish to have a list of all doors, + obtained by making intervals between two points. *) +Fixpoint seq_to_intervals_aux [A : Type] (a : A) (s : seq A) := +match s with +| nil => nil +| b :: tl => (a, b) :: seq_to_intervals_aux b tl +end. + +Definition seq_to_intervals [A : Type] (s : seq A) := +match s with + nil => nil +| a :: tl => seq_to_intervals_aux a tl +end. + +(* Vertical edges are collected from the left_pts and right_pts sequences. *) +Definition cell_safe_exits_left (c : cell) : seq vert_edge := + let lx := p_x (head dummy_pt (left_pts c)) in + map (fun p => Build_vert_edge lx (p_y (fst p)) (p_y (snd p))) + (seq_to_intervals (left_pts c)). + +Definition cell_safe_exits_right (c : cell) : seq vert_edge := + let lx := p_x (head dummy_pt (right_pts c)) in + map (fun p => Build_vert_edge lx (p_y (fst p)) (p_y (snd p))) + (seq_to_intervals (right_pts c)). + +(* The index_seq function is a trick to circumvent the absence of a mapi + function in Coq code. It makes it possible to build a list of pairs, + where each element is annotated with its position in the list. *) +Definition index_seq {T : Type} (s : list T) : list (nat * T) := + zip (iota 0 (size s)) s. + +(* Given a set of cells (given as a sequence), we wish to construct all + the vertical edges (called doors) connecting two cells, and we wish each + door to contain information about the cells they are connected to, here + their rank in the sequence of cells. *) + +Definition door := (vert_edge * nat * nat)%type. + +Definition cells_to_doors (s : list cell) := + let indexed_s := index_seq s in + let vert_edges_and_right_cell := + flatten (map (fun '(i, c) => + (map (fun v => (v, i))) (cell_safe_exits_left c)) + indexed_s) in + let vert_edges_and_both_cells := + flatten (map (fun '(v, i) => + (map (fun '(i', c') => (v, i, i')) + (filter (fun '(i', c') => + existsb (vert_edge_eqb v) (cell_safe_exits_right c')) + indexed_s))) + vert_edges_and_right_cell) in + vert_edges_and_both_cells. + +Definition on_vert_edge (p : pt) (v : vert_edge) : bool := + R_eqb (p_x p) (ve_x v) && R_ltb (ve_bot v) (p_y p) && + R_ltb (p_y p) (ve_top v). + +Definition vert_edge_midpoint (ve : vert_edge) : pt := + {|p_x := ve_x ve; p_y := R_div ((R_add (ve_top ve) (ve_bot ve))) R2|}. + +(* When a vertical edge contains the source or the target, we wish this + point to be considered as the reference point for that edge. *) +Definition vert_edge_to_reference_point (s t : pt) (v : vert_edge) := + if on_vert_edge s v then s + else if on_vert_edge t v then t + else vert_edge_midpoint v. + +(* Each door has one or two neighboring cells, the neighboring doors + are those doors that share one of these neighboring cells. Here we only + want to know the index of the neighbors. We make sure to avoid including + the current door in the neighbors. *) +Definition one_door_neighbors + (indexed_doors : seq (nat * door)) + (i_d : nat * door) : list nat := + match i_d with + | (j, (v0, i0, i'0)) => + map fst + (filter (fun '(vi, (v, i, i')) => (Nat.eqb i i0 || Nat.eqb i i'0 || + Nat.eqb i' i0 || Nat.eqb i' i'0) && (negb (Nat.eqb j vi))) + indexed_doors) + end. + +(* For each extremity, we check whether it is already inside an existing + door. If it is the case, we need to remember the index of that door. + If the extremity is not inside a door, then we create a fictitious door, + where the neighboring cells both are set to the one cell containing this + point. *) +Definition add_extremity_reference_point + (indexed_cells : seq (nat * cell)) + (p : pt) (doors : seq door) := + let purported_index := + seq.find (fun '(v, _, _) => on_vert_edge p v) doors in + if purported_index < size doors then + (doors, purported_index) + else + let '(i, c) := + head (size indexed_cells, dummy_cell) + (filter (fun '(i', c') => strict_inside_closed p c') indexed_cells) in + (rcons doors ({|ve_x := p_x p; ve_top := p_y p; ve_bot := p_y p|}, i, i), size doors). + +(* This function makes sure that the sequence of doors contains a door + for each of the extremities, adding new doors when needed. It returns + the updated sequence of doors and the indexes for the doors containing + each of the extremities. *) +Definition doors_and_extremities (indexed_cells : seq (nat * cell)) + (doors : seq door) (s t : pt) : seq door * nat * nat := + let '(d_s, i_s) := + add_extremity_reference_point indexed_cells s doors in + let '(d_t, i_t) := + add_extremity_reference_point indexed_cells t d_s in + (d_t, i_s, i_t). + +(* In the end the door adjacency map describes the graph in which we + want to compute paths. *) +Definition door_adjacency_map (doors : seq door) : + seq (seq nat) := + let indexed_doors := index_seq doors in + map (fun i_d => one_door_neighbors indexed_doors i_d) indexed_doors. + +Definition dummy_vert_edge := + {| ve_x := R0; ve_top := R0; ve_bot := R0|}. + +Definition dummy_door := (dummy_vert_edge, 0, 0). + +(* To compute the distance between two doors, we compute the distance + between the reference points. TODO: this computation does not take + into account the added trajectory to go to a safe point inside the + cell where the doors are vertically aligned. *) +Definition distance (doors : seq door) (s t : pt) + (i j : nat) := + let '(v1, _, _) := seq.nth dummy_door doors i in + let '(v2, _, _) := seq.nth dummy_door doors j in + let p1 := vert_edge_to_reference_point s t v1 in + let p2 := vert_edge_to_reference_point s t v2 in + pt_distance (p_x p1) (p_y p1) (p_x p2) (p_y p2). + +(* The function cells_too_doors_graph constructs the graph with + weighted edges. *) +Definition cells_to_doors_graph (cells : seq cell) (s t : pt) := + let regular_doors := cells_to_doors cells in + let indexed_cells := index_seq cells in + let '(full_seq_of_doors, i_s, i_t) := + doors_and_extremities indexed_cells regular_doors s t in + let adj_map := door_adjacency_map full_seq_of_doors in + let neighbors_and_distances := + [seq [seq (j, distance full_seq_of_doors s t i j) | j <- neighbors] + | '(i, neighbors) <- index_seq adj_map] in + (full_seq_of_doors, neighbors_and_distances, i_s, i_t). + +(* We can now call the shortest path algorithm, where the nodes are + door indices. *) +Definition node := nat. + +Definition empty := @nil (node * seq node * option R). + +(* The shortest graph algorithm relies on a priority queue. We implement + such a queue by maintaining a sorted list of nodes. *) +Notation priority_queue := (list (node * seq node * option R)). + +Definition node_eqb := Nat.eqb. + +(* To find a element in the priority queue, we just traverse the list + until we find one node that that the same index. *) +Fixpoint gfind (q : priority_queue) n := + match q with + | nil => None + | (n', p, d) :: tl => if node_eqb n' n then Some (p, d) else gfind tl n + end. + +(* To remove an element, we traverse the list. Note that we only remove + the first instance. *) +Fixpoint remove (q : priority_queue) n := + match q with + | nil => nil + | (n', p', d') :: tl => + if node_eqb n' n then + tl + else + (n', p', d') :: remove tl n + end. + +(* To insert a new association in the priority queue, we are careful to + insert the node in the right place comparing the order. *) +Fixpoint insert (q : priority_queue) n p d := + match q with + | nil => (n, p, d) :: nil + | (n', p', d') :: tl => + if cmp_option d d' then + (n, p, d) :: q + else + (n', p', d') :: insert tl n p d + end. + +Definition update q n p d := + insert (remove q n) n p d. + +Definition pop (q : priority_queue) : + option (node * seq node * option R * priority_queue) := + match q with + | nil => None + | v :: tl => Some (v, tl) + end. + +(* This function takes as input the sequence of cells, the source and + target points. It returns a tuple containing: + - the graph of doors, + this graph is a sequence of pairs, where the first component is + is door, and the second component is the sequence of nodes + - the path, when it exists, + - the index of the doors containing the source and targt points *) +Definition c_shortest_path cells s t := + let '(adj, i_s, i_t) := cells_to_doors_graph cells s t in + (adj, shortest_path R R0 R_ltb R_add node node_eqb + (seq.nth [::] adj.2) i_s i_t _ empty + gfind update pop (iota 0 (size adj.2)), i_s, i_t). + +(* Each point used in the doors is annotated with the doors on which they + are and the cells they connect. The last information may be useless + since we have now door information. *) +Record annotated_point := + Apt { apt_val : pt; door_index : option nat; cell_indices : seq nat}. + +(* This value (1/16) of margin is suitable for the demo environment. In real + life, this should be a parameter of the algorithm. *) +Definition margin := R1 / ((R1 + R1) * + (R1 + R1) * (R1 + R1) * (R1 + R1) * (R1 * R1)). + + +(* Given two points p1 and p2 on a side of a cell, this computes a point + inside the cell that is a sensible intermediate point to move from p1 + to p2 while staying safely inside the cell. *) +Definition safe_intermediate_point_in_cell (p1 p2 : pt) (c : cell) + (ci : nat) := + let new_x := p_x (cell_center c) in + let new_y := R_div (R_add (p_y p1) (p_y p2)) R2 in + if R_ltb new_x (p_x p1) then + let new_pt := {|p_x := p_x p1 - margin; p_y := new_y|} in + if strict_inside_closed new_pt c then + Apt new_pt None (ci :: nil) + else + Apt (cell_center c) None (ci :: nil) + else + let new_pt := {|p_x := p_x p1 + margin; p_y := new_y|} in + if strict_inside_closed new_pt c then + Apt new_pt None (ci :: nil) + else + Apt (cell_center c) None (ci :: nil). + + +(* When two neighbor doors are aligned vertically, they have a neighboring + cell in common. This can be computed by looking at the intersection + between their lists of neighboring cells. *) +Definition intersection (s1 s2 : seq nat) := + [seq x | x <- s1 & existsb (fun y => Nat.eqb x y) s2]. + +Definition common_index (s1 s2 : seq nat) := + let intersect := intersection s1 s2 in + seq.head 0 intersect. + +Definition door_to_annotated_point s t (d : door) + (door_index : nat) := + let p' := vert_edge_to_reference_point s t d.1.1 in + let annot := + if Nat.eqb d.1.2 d.2 then [:: d.2] else [:: d.1.2 ; d.2] in + Apt p' (Some door_index) annot. + +Fixpoint a_shortest_path (cells : seq cell) + (doors : seq door * seq (seq (nat * R))) + s t (p : annotated_point) (path : seq node) := + match path with + | nil => [:: p] + | p'i :: tlpath => + let d' := seq.nth dummy_door doors.1 p'i in + let a_p' := door_to_annotated_point s t d' p'i in + if R_eqb (p_x (apt_val p)) (p_x (apt_val a_p')) then + let ci := common_index (cell_indices p) (cell_indices a_p') in + let p_extra : annotated_point := + safe_intermediate_point_in_cell (apt_val p) (apt_val a_p') + (seq.nth dummy_cell cells ci) ci in + p :: p_extra :: a_shortest_path cells doors s t a_p' tlpath + else + p :: a_shortest_path cells doors s t a_p' tlpath + end. + +Definition path_reverse (s : seq (annotated_point * annotated_point)) := + List.map (fun p => (snd p, fst p)) (List.rev_append s nil). + +Definition intersect_vert_edge (p1 p2 : pt) (ve : vert_edge) : pt := + Bpt (ve_x ve) + (p_y p1 + (ve_x ve - p_x p1) / (p_x p2 - p_x p1) * (p_y p2 - p_y p1)). + +Definition optim_three (doors : seq door) (p1 p2 p3 : annotated_point) := + let p1' := apt_val p1 in + let p3' := apt_val p3 in + if p2 is Apt p2' (Some d_i) cells then + let d := (seq.nth dummy_door doors d_i).1.1 in + if R_ltb (p_x p1') (ve_x d) && R_ltb (ve_x d) (p_x p3') then + if R_ltb R0 (area3 p1' p2' p3') then + if R_ltb R0 (area3 p1' p3' (Bpt (ve_x d) (ve_top d))) then + let p2_2 := intersect_vert_edge p1' p3' d in + Apt p2_2 (Some d_i) cells + else + if R_ltb (ve_bot d) (ve_top d - margin) then + Apt (Bpt (ve_x d) (ve_top d - margin)) (Some d_i) cells + else + p2 + else + if R_ltb (area3 p1' p3' (Bpt (ve_x d) (ve_bot d))) R0 then + let p2_2 := intersect_vert_edge p1' p3' d in + Apt p2_2 (Some d_i) cells + else + if R_ltb (ve_bot d + margin) (ve_top d) then + Apt (Bpt (ve_x d) (ve_bot d + margin)) (Some d_i) cells + else + p2 + else if R_ltb (p_x p3') (ve_x d) && R_ltb (ve_x d) (p_x p1') then + if R_ltb R0 (area3 p1' p2' p3') then + if R_ltb R0 (area3 p1' p3' (Bpt (ve_x d) (ve_bot d))) then + let p2_2 := intersect_vert_edge p1' p3' d in + Apt p2_2 (Some d_i) cells + else + if R_ltb (ve_bot d + margin) (ve_top d) then + Apt (Bpt (ve_x d) (ve_bot d + margin)) (Some d_i) cells + else + p2 + else + if R_ltb (area3 p1' p3' (Bpt (ve_x d) (ve_top d))) R0 then + let p2_2 := intersect_vert_edge p1' p3' d in + Apt p2_2 (Some d_i) cells + else + if R_ltb (ve_bot d) (ve_top d - margin) then + Apt (Bpt (ve_x d) (ve_top d - margin)) (Some d_i) cells + else + p2 + else + p2 + else + p2. + +Fixpoint local_improvements (doors : seq door) + (p : seq (annotated_point * annotated_point)) : + seq (annotated_point * annotated_point) := +match p with +| (p1, p2) :: ((_ , p3) :: _) as tl => + match local_improvements doors tl with + | [::] => p + | (_, p3') :: tl' => + let p2' := optim_three doors p1 p2 p3' in + (p1, p2') :: (p2', p3') :: tl' + end +| _ => p +end. + +Definition source_to_target + (cells : seq cell) (source target : pt) : + option (seq door * + seq (annotated_point * annotated_point)) := + let '(doors, opath, i_s, i_t) := + c_shortest_path cells source target in + if Nat.eqb i_s i_t then + Some (doors.1, [:: (Apt source None [::], Apt target None [::])]) + else + let last_point := + door_to_annotated_point source target + (seq.nth dummy_door doors.1 i_t) i_t in + if opath is Some path then + match a_shortest_path cells doors source target + last_point path with + | nil => None + | a :: tl => + Some(doors.1, + local_improvements doors.1 + (path_reverse (seq_to_intervals_aux a tl))) + end + else + None. + +(* THIRD PART: Producing a smooth trajectory. *) +(* We produce a smooth trajectory by replacing every angle by a Bezier curve. + We first add anchor points in the middle of each straight line segment. + These anchor points only have the constraints to be in a single cell and + the curve will pass through these anchor points no matter what + transformation will happen later. Then broken line paths between + anchor points are replaced by Bezier curves, thus keeping the invariant + that the new smooth path connects the anchor points correctly. *) + +(* The point of this function is to add anchor points in the middle + of each segment. The annotation for these anchor points is the + cell in which they appear, but this information is not going to play + a significant role in the current version of the program. *) +Fixpoint break_segments (s : seq (annotated_point * annotated_point)) : + seq (annotated_point * annotated_point) := + match s with + | (Apt p1 door_index1 a1, Apt p2 door_index2 a2) :: tl => + (Apt p1 door_index1 a1, Apt (midpoint p1 p2) None (intersection a1 a2)) :: + (Apt (midpoint p1 p2) None (intersection a1 a2), Apt p2 door_index2 a2) :: + break_segments tl + | nil => nil + end. + +(* The connection at anchor points is straight (because it comes + from a straight line segment. The connection between two anchor points + is a broken line (an angle). The idea is to replace this broken line + by a bezier curve, which by construction will be tangent with the + initial segment. However, there may be cases where this Bezier curve does + not pass through the authorized door. *) +Variant curve_element := + straight (x y : annotated_point) | bezier (x y z : annotated_point). + +(* This function assumes that every other straight line segment goes into + an angle, and the other go into a straight connection. The angles + (represented by adjacent pairs) are then replace by Bezier curves. + the last element is left as is. *) +(* The input of this function is guaranteed to have b = b' in the second + pattern matching rule below. *) +Fixpoint smoothen_aux (s : seq (annotated_point * annotated_point)) : + seq curve_element := +match s with +| nil => nil +| (a, b) :: nil => straight a b :: nil +(* Here we know the anonymous variable to have the same value as b *) +| (a, b) :: (_ , c) :: tl => bezier a b c :: smoothen_aux tl +end. + +(* Here we move from a sequence of straight line segments given by pairs + of points with anchor points to a sequence of curve elements. + Actually only the first one and the last one are straight, all the rest + are Bezier curve elements. *) +Definition smoothen (s : seq (annotated_point * annotated_point)) : + seq curve_element := +match s with +| (a, b) :: tl => straight a b :: smoothen_aux tl +| nil => nil +end. + +(* The curve produced by smoothen only guarantees to be a continuous + path from the initial point to the last point going through the anchor + points, but now we have lost the guarantee that this path goes through + the doors. The next functions detect collisions and repair the curve. *) + +(* We now have two functions to check whether a Bezier curve does pass + through the door. They implement specialized code and require fuel to + operate. the result is an optional boolean. When the boolean is given + and true, we are sure the curve passes through the door, when the + boolean is given and false, we are sure the curve hits an obstacle, + when the boolean is not given (answer is None), we don't know, but + for this algorithm, this is interpreted as a failure to pass through the + door. In practice, the fuel does not need to be big, because curve size + is divided by 2 at each iteration. + + This function is to be used when p_x a < p_x b < p_x c and + a b c is ccw (counter clockwise). It assumes that there is no need to + check the bottom point. *) +Fixpoint check_bezier_ccw (fuel : nat) (v : vert_edge) + (a b c : pt) : + option bool := +match fuel with +| O => None +| S p => + let top_of_edge := Bpt (ve_x v) (ve_top v) in + if negb (point_under_edge top_of_edge (Bedge a c)) then + Some true + else if + point_under_edge top_of_edge (Bedge a b) || + point_under_edge top_of_edge (Bedge b c) + then + Some false + else + let b' := midpoint a b in + let b2 := midpoint b c in + let c' := midpoint b' b2 in + if R_ltb (p_x c') (ve_x v) then + check_bezier_ccw p v c' b2 c + else if R_ltb (ve_x v) (p_x c') then + check_bezier_ccw p v a b' c' + else + if R_ltb (p_y c') (ve_top v) then + Some true + else + Some false +end. + +(* This function is to be used when p_x a < p_x b < p_x c and + a b c is cw (clockwise). + It assumes that there is no need to check the top point. *) +Fixpoint check_bezier_cw (fuel : nat) (v : vert_edge) + (a b c : pt) : + option bool := +match fuel with +| O => None +| S p => + let bot_of_edge := Bpt (ve_x v) (ve_bot v) in + if point_strictly_under_edge bot_of_edge (Bedge a c) then + Some true + else if + negb (point_strictly_under_edge bot_of_edge (Bedge a b)) || + negb (point_strictly_under_edge bot_of_edge (Bedge b c)) + then + Some false + else + let b' := midpoint a b in + let b2 := midpoint b c in + let c' := midpoint b' b2 in + if R_ltb (p_x c') (ve_x v) then + check_bezier_cw p v c' b2 c + else if R_ltb (ve_x v) (p_x c') then + check_bezier_cw p v a b' c' + else + if R_ltb (ve_bot v) (p_y c') then + Some true + else + Some false +end. + +(* This function verifies that the Bezier curve does pass through the + door that was initially given has a constraint for the broken line. This + is done by performing a dichotomy on the Bezier curve until we either + see explicitely that the condition is met or that the condition is + violated. When the condition is violated, a new Bezier curve is proposed + and by creating two new anchor points half way between the previous + anchor points and the chosen point (normally the middle of the door) and + verification starts again with the new Bezier curve, which is closer to + the broken line trajectory. + This function should normally be based on well-founded recursion, but + for executability we rely on a fuel, which does not need to be enormous + because the size of the bezier curve element is divided by 2 at each + iteration. + This function may replace a faulty curve element with a sequence of + three new elements, so all results have to be concatened later. *) +Definition fuel_constant := 20. + +Fixpoint check_curve_element_and_repair + (fuel : nat) doors (e : curve_element) : + seq curve_element := +match e with +| straight p1 p2 => straight p1 p2 :: nil +| bezier p1 p2 p3 => + if door_index p2 is Some n then + let vedge := + (seq.nth dummy_door doors n).1.1 in + let e' := + (if R_ltb (p_x (apt_val p1)) (p_x (apt_val p2)) then + bezier p1 p2 p3 + else + bezier p3 p2 p1) in + match e' with + |straight _ _ => e' :: nil + | bezier p1' p2' p3' => + let check_function := + if R_ltb R0 + (area3 (apt_val p1') (apt_val p2') (apt_val p3')) then + check_bezier_ccw + else + check_bezier_cw in + match check_function fuel_constant vedge + (apt_val p1')(apt_val p2')(apt_val p3') with + | Some true => bezier p1 p2 p3 :: nil + | _ => + match fuel with + | S p => + straight p1 + (Apt (midpoint (apt_val p1) (apt_val p2)) + None (cell_indices p1)) + :: + check_curve_element_and_repair p doors + (bezier (Apt (midpoint (apt_val p1) (apt_val p2)) None + (cell_indices p1)) + p2 + (Apt (midpoint (apt_val p2) (apt_val p3)) None (cell_indices p3))) + ++ + straight (Apt (midpoint (apt_val p2) (apt_val p3)) + None (cell_indices p3)) p3 :: nil + | _ => + straight p1 p2 :: straight p2 p3 :: nil + end + end + end + else + (bezier p1 p2 p3 :: nil) +end. + +Definition smooth_from_cells (cells : seq cell) + (initial final : pt) : seq curve_element := + match source_to_target cells initial final with + | Some (doors, s) => + List.concat + (List.map (check_curve_element_and_repair fuel_constant doors) + (smoothen (break_segments s))) + | None => nil + end. + +(* This function only computes the piecewise straight line trajectory, + starting from the sequence of edges and the source and target. *) +Definition point_to_point (bottom top : edge) (obstacles : seq edge) + (initial final : pt) : seq curve_element := + let cells := edges_to_cells bottom top obstacles in + match source_to_target cells initial final with + | Some (doors, s) => + List.map (fun '(a, b) => straight a b) s + | None => nil + end. + +(* This function wraps up all operations: + - constructing the cells + - constructing the broken line + - constructing the smooth line + - repairing the faulty bezier elements. *) +Definition smooth_point_to_point (bottom top : edge) (obstacles : seq edge) + (initial final : pt) : seq curve_element := + let cells := edges_to_cells bottom top obstacles in + smooth_from_cells cells initial final. + +End generic_implementation. diff --git a/theories/hulls.v b/theories/hulls.v new file mode 100644 index 0000000..650a1be --- /dev/null +++ b/theories/hulls.v @@ -0,0 +1,327 @@ +Require Export encompass conv. +From mathcomp Require Import all_ssreflect all_algebra vector reals normedtype. +From mathcomp Require Import classical_sets boolp mathcomp_extra. +Require Import counterclockwise. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +From mathcomp.algebra_tactics Require Import ring. +From mathcomp.zify Require Import zify. + +Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory. + +Section hull_def. +Local Open Scope classical_set_scope. +Local Open Scope ring_scope. +Definition hull (R : realType) (T : lmodType R) (X : set T) : set T := + [set p : T | exists n (g : 'I_n -> T) (d : 'I_n -> R), + [/\ (forall i, 0 <= d i)%R, + (\sum_(i < n) d i = 1%R), + g @` setT `<=` X & + p = \sum_(i < n) (d i) *: (g i)] ]. +End hull_def. + +Module Spec := SpecKA(ccw_KA). + +Section spec. +Variable R : realType. +Let Plane := Plane R. + +Open Scope ring_scope. +Open Scope order_scope. + +Section hull_prop. +Local Open Scope classical_set_scope. +Variable A : lmodType R. +Implicit Types X Y : set A. + +Lemma subset_hull X : X `<=` hull X. +Proof. +move=> x xX; rewrite /hull; exists 1%N, (fun=> x), (fun=>1%R). +split=> //. +- by rewrite big_ord_recl big_ord0 addr0. +- by move=> d [i _ <-]. +- by rewrite big_ord_recl big_ord0 scale1r addr0. +Qed. + +Lemma hull0 : hull set0 = set0 :> set A. +Proof. +rewrite funeqE => d; rewrite propeqE; split => //. +move=> [n [g [e [e0 e1 gX ->{d}]]]]. +destruct n as [|n]; first by rewrite big_ord0 in e1; move:(@ltr01 R); rewrite e1 ltxx. +exfalso; apply: (gX (g ord0)); exact/imageP. +Qed. + +Lemma hull_eq0 X : (hull X == set0) = (X == set0). +Proof. +apply/idP/idP=> [/eqP abs|]; last by move=> /eqP ->; rewrite hull0. +apply/negPn/negP => /set0P[/= d] => dX. +move: abs; rewrite funeqE => /(_ d); rewrite propeqE /set0 => -[H _]; apply H. +exact/subset_hull. +Qed. + +Lemma hull_monotone X Y : X `<=` Y -> hull X `<=` hull Y. +Proof. +move=> H a [n [g [d [d0 d1 gX ae]]]]; exists n, g, d; split => //. +by eapply subset_trans; first exact: gX. +Qed. + +Lemma hull2 (x y : A) : + hull [set x; y]%classic = ((fun t => x <| t |> y) @` `[0%R, 1%R])%classic. +Proof. +rewrite eqEsubset; split; last first. + move=> z [t /andP [t0 t1]] <-. + rewrite bnd_simp in t0, t1. + exists 2%N, (fun i => if i == 0 then x else y), + (fun i => if i == 0 then t else `1- t). + split; first by case; case=>//= n _; rewrite subr_ge0. + - by rewrite big_ord_recl big_ord1/= addrCA subrr addr0. + - by move=>a[]; case; case=>/= [|n] _ _ <-; [left|right]. + - by rewrite big_ord_recl big_ord1. +move=>z [n][g][d][d0 d1 gxy ->]. +move:d1=>/esym/eqP; rewrite -subr_eq0 (bigID [pred i | g i == x])//= opprD. +rewrite addrCA addrC subr_eq0=>/eqP/esym=>d1. +exists (\sum_(i < n | g i == x) d i). + rewrite inE; apply/andP; rewrite 2!bnd_simp {2}d1 -[(_<=1)%R]subr_ge0 opprB. + by rewrite addrCA subrr addr0; split; apply sumr_ge0. +rewrite/conv {2}d1 opprB addrCA subrr addr0 [RHS](bigID [pred i | g i == x])//=. +congr (_ + _); rewrite scaler_suml; apply: congr_big=>// i. + by move=> /eqP ->. +have /gxy[->|->//] : range g (g i) by []. +by rewrite eqxx. +Qed. + +Lemma hull_convex X : forall x y, + (hull X) x -> (hull X) y -> hull [set x; y] `<=` hull X. +Proof. +move=> + + [n][g][d][d0 d1 gX->] [m][h][e][e0 e1 hX ->]. +rewrite hull2=>_ _ x [t] /andP. +rewrite !bnd_simp -[(_ <= 1)%R]subr_ge0 => [[t0 t1]] <-. +exists (n + m)%N, (fun i=> match split i with inl i => g i | inr i => h i end), + (fun i=> match split i with inl i => t * (d i) + | inr i => (`1- t) * e i end); split. +- by move=>i; case: (split i)=>j; apply mulr_ge0. +- rewrite big_split_ord/= -{1}(add_onemK t); congr +%R. + rewrite -{3}(mulr1 t) -{1}d1 mulr_sumr; apply congr_big=>// i _. + case: (splitP (lshift m i)). + by move=>j ij; congr (_ * d _); apply val_inj. + by move=> k/= ink; move: (ltn_ord i); rewrite ink -ltn_subRL subnn ltn0. + rewrite -{2}(mulr1 (`1- t)) -{1}e1 mulr_sumr; apply congr_big=>// i _. + case: (splitP (rshift n i))=>/=. + by move=> j/= nij; move: (ltn_ord j); rewrite -nij -ltn_subRL subnn ltn0. + by move=>j /eqP; rewrite eqn_add2l=>/eqP ij; congr (_ * e _); apply val_inj. +- by move=>y/= [i] _; case: split=>j <-; [ apply gX | apply hX ]. +- rewrite big_split_ord /conv; congr +%R; rewrite scaler_sumr; + apply congr_big => // i _; rewrite scalerA. + + case: (splitP (lshift m i)). + by move=> j ij; congr (_ * d _ *: g _); apply val_inj. + by move=> k/= ink; move: (ltn_ord i); rewrite ink -ltn_subRL subnn ltn0. + + case: (splitP (rshift n i)) =>/=. + by move=> j/= nij; move: (ltn_ord j); rewrite -nij -ltn_subRL subnn ltn0. + by move=> j /eqP; rewrite eqn_add2l => /eqP ij; congr (_ * e _ *: h _); apply val_inj. +Qed. + +End hull_prop. + +Let oriented := fun p q r : Plane => 0%:R <= det p q r. + +Lemma is_left_oriented (p q r : Plane) : + encompass.is_left oriented p q r = oriented p q r. +Proof. +apply/idP/idP; last by rewrite/encompass.is_left; move=>->; rewrite !orbT. +by move=>/or3P[| |//] /eqP re; subst r; rewrite /oriented det_cyclique; [ rewrite det_cyclique |]; rewrite det_alternate. +Qed. + +Lemma encompass_correct (l : seq Plane) (p : Plane) : + uniq l -> + (3 <= size l)%N -> + encompass (ccw (R:=R)) l l -> + encompass oriented [:: p] l -> + exists t : 'I_(size l) -> R, + (forall i, 0 <= t i)%R /\ (\sum_i t i = 1%:R) /\ p = \sum_i t i *: l`_i. +Proof. +move: l p. +have orientedW: forall a b c, encompass.is_left oriented a b c -> oriented a b c. + move=>a b c /or3P[| |//] /eqP<-; rewrite /oriented. + by rewrite 2!det_cyclique det_alternate. + by rewrite det_cyclique det_alternate. +have H3 a b c p : uniq [:: a; b; c] -> + encompass (ccw (R:=R)) [:: a; b; c] [:: a; b; c] -> + encompass oriented [::p] [:: a; b; c] -> + exists t : 'I_3 -> R, (forall i, 0 <= t i)%R /\ (\sum_i t i = 1%:R) /\ p = \sum_i t i *: [:: a; b; c]`_i. + rewrite/uniq !in_cons negb_or 2!in_nil 2!orbF=>/andP [/andP[/negPf ab /negPf ac] /andP[/negPf bc _]] /andP[/andP [_ /andP [h _]] _] /= /andP [/andP [/orientedW cap _]] /andP [/andP [/orientedW abp _]] /andP [/andP [/orientedW bcp _] _]. + move: h; rewrite/encompass.is_left bc eq_sym ab =>/= cab. + exists (fun i => [:: det c p b / det c a b; det c a p / det c a b; det p a b / det c a b]`_i); split. + case; case; [| case; [| case=>//]]; move=>/= _; (apply mulr_ge0; [| by rewrite invr_ge0; apply ltW]). + - by rewrite 2!det_cyclique. + - by []. + - by rewrite det_cyclique. + move: cab; rewrite /ccw lt0r=>/andP[cab _]. + split. + by rewrite !big_ord_recr big_ord0 /= add0r -2!mulrDl addrC addrA -decompose_det divff. + rewrite !big_ord_recr big_ord0 /= add0r. + apply (scalerI cab). + rewrite 2!scalerDr 3!scalerA 3!mulrA 3![det c a b * _]mulrC -3!mulrA divff// 3!mulr1. + apply/pair_eqP; apply/andP; split; apply/eqP; rewrite !develop_det /xcoord /ycoord; cbn; ring. +move=> l p. +elim: l=>// a; case=>// b; case=>// c; case. + by move=>IHl abc _; apply H3. +move=>d l IHl lu sl ll lp. +case labp: (oriented b (last d l) p). + move:H3=>/(_ a b (last d l) p); case. + - move: lu; apply subseq_uniq=>/=. + by rewrite eq_refl eq_refl -/(subseq [:: last d l] (c :: d :: l)) sub1seq in_cons mem_last orbT. + - apply (Spec.encompassll_subseq lu)=>//. + by rewrite /= eq_refl /= eq_refl -/(subseq [:: last d l] (c :: d :: l)) sub1seq in_cons mem_last orbT. + - apply/andP; split. + by move:lp=>/andP[lp _]; move:lp. + apply/andP; split. + by move:lp=>/andP[_ /andP[ap _]]. + by rewrite /=/encompass.is_left labp !orbT. + move=>f [f0 [f1 fp]]. + exists (fun i:'I_(size l).+4 => (i == ord0)%:R * f ord0 + (i == lift ord0 ord0)%:R * f (lift ord0 ord0) + (i == ord_max)%:R * f ord_max). + split. + move=>i. + apply addr_ge0; [apply addr_ge0|]; apply mulr_ge0; try apply f0; apply ler0n. + split; rewrite big_ord_recr /= eq_refl mul1r 2!mul0r 2!add0r big_ord_recl /= mul1r 2!mul0r 2!addr0 big_ord_recl /= mul1r 2!mul0r addr0 add0r. + rewrite -f1 ![\sum_i f _]big_ord_recl big_ord0 addr0 -!addrA; congr (_ + (_ + _)). + rewrite -[f (lift _ (lift _ _))]add0r; congr (_ + f _); last by apply val_inj. + rewrite -{3}(mul0r (\sum_(i < (size l).+1) 0)) mulr_sumr. + apply congr_big=>// [[i ilt]] _. + have ->: (widen_ord (leqnSn (size l).+3) (lift ord0 (lift ord0 (Ordinal ilt))) == ord_max) = false. + by apply /negP=>/eqP/(f_equal val)/=; rewrite /bump/= 2!add1n=>/eqP; rewrite 2!eqSS=>/eqP ile; move:ilt; rewrite -ile ltnn. + by rewrite 3!mul0r 2!addr0. + rewrite fp ![\sum_i f _ *: _]big_ord_recl big_ord0 addr0 -!addrA; congr (_ + (_ + _)). + rewrite (nth_last _ (d :: l))/= -[f (lift _ (lift _ _)) *: _]add0r; congr (_ + f _ *: _); last by apply val_inj. + rewrite -{1}(scale0r (\sum_(i < (size l).+1) 0)) scaler_sumr. + apply congr_big=>// [[i ilt]] _. + have ->: (widen_ord (leqnSn (size l).+3) (lift ord0 (lift ord0 (Ordinal ilt))) == ord_max) = false. + by apply /negP=>/eqP/(f_equal val)/=; rewrite /bump/= 2!add1n=>/eqP; rewrite 2!eqSS=>/eqP ile; move:ilt; rewrite -ile ltnn. + by rewrite 2!mul0r 2!addr0 2!scale0r. +case: IHl. + - by move: lu=>/andP[_ lu]. + - by []. + - move: ll=>/Spec.encompassll_subseq; apply=>//; apply subseq_cons. + - apply/andP; split. + 2: by move: lp=>/andP[_ /andP [_ lp]]. + rewrite/= andbT; apply/or3P/Or33. + by rewrite/oriented det_inverse 2!det_cyclique leNgt oppr_lt0; apply/negP=>/ltW; move: labp; rewrite /oriented=>->. +move=>f [f0 [f1 fp]]. +exists (fun i=> + match ord_S_split i with + | inleft j => f (proj1_sig j) + | inright _ => 0%:R + end). +split. + by move=>i; case: (ord_S_split i). +split; rewrite big_ord_recl; (case (ord_S_split ord0); [ by move=>[j H] | move=>_]); [| rewrite scale0r]; rewrite add0r. + rewrite -f1; apply congr_big=>// [[i ilt]] _. + case (ord_S_split _)=>// [[j jlt]] /=; congr (f _); apply val_inj=>/=. + by move:jlt=>/(f_equal val)=>/=/eqP; rewrite /bump/= 2!add1n eqSS=>/eqP. +rewrite fp; apply congr_big=>// [[i ilt]] _. +case (ord_S_split _)=>// [[j jlt]] /=; congr (f _ *: _); apply val_inj=>/=. +by move:jlt=>/(f_equal val)=>/=/eqP; rewrite /bump/= 2!add1n eqSS=>/eqP. +Qed. + +Lemma detD (p q r : Plane) : det 0 p (q+r) = det 0 p q + det 0 p r. +Proof. by rewrite 3!det_scalar_productE /scalar_product/=; ring. Qed. + +Lemma det_sum (p : Plane) (n : nat) (f : 'I_n -> Plane) : + det 0 p (\sum_(i < n) f i) = \sum_(i < n) det 0 p (f i). +Proof. +elim: n f. + by move=>f; rewrite 2!big_ord0 -det_cyclique det_alternate. +move=>n IHn f. +by rewrite 2!big_ord_recl detD IHn. +Qed. + +Lemma encompass_complete (l : seq Plane) (p : Plane) : + uniq l -> + (3 <= size l)%N -> + encompass (ccw (R:=R)) l l -> + (exists t : 'I_(size l) -> R, + (forall i, 0 <= t i)%R /\ + (\sum_i t i = 1%:R) /\ + p = \sum_i t i *: l`_i) -> + encompass oriented [:: p] l. +Proof. +move=>lu ls ll [f [f0 [f1 fp]]]; subst p. +rewrite encompass_all_index; apply/andP; split. + by case: l lu ls ll f f0 f1. +apply/forallP=>[[i ilt]]. +rewrite/= andbT is_left_oriented /oriented. +wlog: l lu ls ll f f0 f1 i ilt / l`_i == 0%R. + move=>h. + set l' := [seq x - l`_i | x <- l]. + have subl': forall a b, (a < size l) -> (b < size l) -> l'`_a - l'`_b = l`_a - l`_b. + by move=>a b al bl; rewrite (nth_map 0)// (nth_map 0)// opprD [-_ - - _]addrC -!addrA; congr GRing.add; rewrite addrA subrr add0r. + suff: (0%:R <= det l'`_i l'`_(Zp_succ (Ordinal ilt)) (\sum_(i0 < size l) f i0 *: l'`_i0))%R. + congr (_ <= _)%R; rewrite 2!det_scalar_productE; congr (scalar_product _ (rotate _)). + - by apply subl'=>//; case: (Zp_succ (Ordinal ilt)). + - rewrite [l'`_i](nth_map 0)// subrr subr0 -[l`_i]scale1r. + have->: (1 = 1%:R)%R by []. + rewrite -f1 scaler_suml -sumrB; apply congr_big=>// [[j jlt]] _. + by rewrite -scalerBr (nth_map 0). + move:h=>/(_ l'); rewrite size_map; apply. + - rewrite map_inj_uniq=>//; apply addIr. + - by []. + - rewrite Spec.encompassll_spec. + 2: by rewrite map_inj_uniq=>//; apply addIr. + apply/andP; split. + by destruct l. + rewrite size_map. + apply/forallP=>[[a alt]]. + apply/forallP=>[[b blt]]. + apply/forallP=>[[c clt]]. + apply/implyP=>abc. + rewrite /ccw_KA.OT /ccw det_scalar_productE subl'// subl'//. + by move:ll; rewrite Spec.encompassll_spec=>// /andP[_] /forallP /(_ (Ordinal alt)) /forallP /(_ (Ordinal blt)) /forallP /(_ (Ordinal clt)) /implyP /(_ abc); rewrite /ccw_KA.OT /ccw det_scalar_productE. + - apply f0. + - exact f1. + - by rewrite (nth_map 0)// subrr. +move=>/eqP li0; rewrite li0 det_sum; apply sumr_ge0=>[[j jlt]] _. +rewrite det_scalar_productE 2!subr0 rotateZ scalar_productZR; apply mulr_ge0. + apply f0. +move:ll; rewrite encompassE =>/andP[_ /allP ll]. +have/ll: l`_(Ordinal jlt) \in l by rewrite mem_nth. +rewrite encompass_all_index=>/andP[_] /forallP /(_ (Ordinal ilt))/=; rewrite andbT. +rewrite li0// => /or3P[/eqP ->|/eqP ->|]. +- by rewrite -{2}(scale0r 0) rotateZ scalar_productZR mul0r. +- by rewrite scalar_product_rotatexx. +- by rewrite /ccw det_scalar_productE 2!subr0=>/ltW. +Qed. + +Lemma encompassP (l : seq Plane) (p : Plane) : + uniq l -> + (3 <= size l)%N -> + encompass (ccw (R:=R)) l l -> + reflect (p \in hull (fun x => x \in l)) (encompass oriented [:: p] l). +Proof. +move=>lu ls ll; apply/(iffP idP). + move=>/(encompass_correct lu ls ll)[f [f0 [f1 ->]]]. + rewrite inE/hull/=; exists (size l), (fun i=> l`_i), f; split => //. + by move =>// x/= [i] _ <-{x}; exact: (@mem_nth Plane). +rewrite inE/hull/= =>[[n [g [d [d0 d1 gl pe]]]]]. +apply encompass_complete=>//. +exists (fun i=> \sum_(j < n | g j == l`_i) d j); split. + by move=>i; apply sumr_ge0. +split. + rewrite -(big_map (fun i: 'I_(size l) => l`_i) xpredT (fun x=> \sum_(j < n | g j == x) d j)). + rewrite (map_comp (fun i : nat => l`_i) (@nat_of_ord (size l))). + move:(val_enum_ord (size l)); rewrite enumT=>->. + rewrite map_nth_iota0// take_size -big_partition//. + by apply/allP=>i _; apply gl. +transitivity (\sum_(i < size l) \sum_(j < n | g j == l`_i) d j *: g j). + rewrite -(big_map (fun i: 'I_(size l) => l`_i) xpredT (fun x=> \sum_(j < n | g j == x) d j *: g j)). + rewrite (map_comp (fun i : nat => l`_i) (@nat_of_ord (size l))). + move:(val_enum_ord (size l)); rewrite enumT=>->. + rewrite map_nth_iota0// take_size -big_partition//. + by apply/allP=>i _; apply gl. +apply congr_big=>//i _. +rewrite scaler_suml. +by apply congr_big=>//j/eqP->. +Qed. + +End spec. diff --git a/theories/intersection.v b/theories/intersection.v new file mode 100644 index 0000000..ea9d5b0 --- /dev/null +++ b/theories/intersection.v @@ -0,0 +1,371 @@ +Require Export counterclockwise conv encompass preliminaries. +From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals. +From mathcomp Require Import normedtype order boolp classical_sets. +From mathcomp Require Import constructive_ereal. + +(******************************************************************************) +(* separated a b c d == true if a = b or (ab) intersects [c,d] *) +(* intersect a b c d == true if [a, b] and [c, d] intersect *) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +From mathcomp.algebra_tactics Require Import ring. +From mathcomp.zify Require Import zify. + +Import GRing Num.Theory Order.POrderTheory Order.TotalTheory. + +Local Open Scope order_scope. +Local Open Scope ring_scope. + +Module Spec := SpecKA(ccw_KA). + +Section Plane. +Variable R : realType. +Let Plane := Plane R. + +Definition separate (a b c d : Plane) := (det a b c * det a b d <= 0) && + ((a == b) ==> between a c d) && + ((det a b c == 0) ==> (det a b d == 0) ==> (a != b) ==> + [|| between a c d, between b c d | (between c a b && between d a b)]). + +Lemma separateCl (a b c d : Plane) : separate a b c d = separate b a c d. +Proof. +rewrite/separate 2![det _ b _]det_inverse mulrN mulNr opprK. +rewrite -2![det a _ _]det_cyclique 2!oppr_eq0 eq_sym. +rewrite orbA (orbC (_ a c d)) -orbA. +congr (_ && _ && (_ ==> _ ==> _ ==> (_ || _))). +- by apply implyb_id2l=>/eqP->. +- by rewrite !(@betweenC _ _ a b). +Qed. + +Lemma separateCr (a b c d : Plane) : separate a b c d = separate a b d c. +Proof. +rewrite/separate mulrC ![_ _ c d]betweenC; congr andb. +by rewrite -Bool.implb_curry andbC Bool.implb_curry andbC. +Qed. + +Definition intersect (a b c d : Plane) := separate a b c d && separate c d a b. + +Lemma intersectCl (a b c d : Plane) : intersect a b c d = intersect b a c d. +Proof. by rewrite/intersect separateCl; congr andb; apply separateCr. Qed. + +Lemma intersectCr (a b c d : Plane) : intersect a b c d = intersect a b d c. +Proof. by rewrite/intersect separateCr; congr andb; apply separateCl. Qed. + +Lemma intersect_correct a b c d : intersect a b c d -> + exists p, between p a b && between p c d. +Proof. +have sm t u : t *: (u : R^o) = t * u by []. +wlog abc0: a b c d / 0 <= det a b c. + move=>h. + case ge0: (0 <= det a b c); first by apply h. + move:ge0=>/negP/negP; rewrite leNgt -oppr_gt0 -det_inverse -det_cyclique negbK intersectCl=>/ltW ge0 bacd. + by move:(h _ _ _ _ ge0 bacd)=>[p]; rewrite betweenC=>pb; exists p. +case ab: (a == b). + by move=>/andP[/andP[/andP[_]]]; rewrite ab/==>acd _ _; exists a; rewrite betweenl. +case cd: (c == d). + by move=>/andP[_]/andP[/andP[_]]; rewrite cd/==>cab _; exists c; rewrite betweenl andbT. +move=>/andP[/andP [/andP[absep _] ab0]] /andP[/andP[cdsep _] cd0]. +move: abc0; rewrite le0r => /orP[|]. + move=>/eqP/det0_aligned; case; first by move=>abe; move:ab; rewrite abe eqxx. + move=>[t] ce; move: cdsep cd0; rewrite cd -ce 2!det_conv -![det _ d _]det_cyclique 2!det_alternate /conv 4!sm 2!mulr0 add0r addr0 det_inverse -det_cyclique mulrN mulNr mulrACA oppr_le0. + case tlt: ((1-t) * t < 0). + rewrite nmulr_rge0// -expr2=>badle. + have-> : (det b a d = 0) by apply/eqP; rewrite -sqrf_eq0; apply/eqP/le_anti/andP; split=>//; apply sqr_ge0. + rewrite 2!mulr0 oppr0 eqxx/= =>/or3P[| |]; last first. + by move=>/andP[acd _]; exists a; rewrite betweenl. + by exists d; rewrite betweenr andbT. + by move=> cdb; exists (a <| t |> b); rewrite betweenl andbT. + move=>_ _; exists (a <| t |> b); rewrite betweenl andbT; apply between_conv. + by exists t; rewrite eqxx andbT in01M_ge0 leNgt mulrC tlt. +move:ab0=> _ abc; move:absep; rewrite pmulr_rle0// =>abd. +set t := det a b d / (det d a b - det c a b). +have denom: det d a b - det c a b != 0 by rewrite 2![det _ a b]det_cyclique subr_eq0; apply/negP=>/eqP detE; move:(le_lt_trans abd abc); rewrite detE ltxx. +have: det a b (c <| t |> d) == 0 by rewrite -det_cyclique det_conv convrl sm -opprB mulrN /t -mulrA [_^-1 * _]mulrC divff// mulr1 det_cyclique subrr. +move=>/eqP /det0_aligned; case; first by move=>/eqP; rewrite ab. +move=>[u utE]. +case u01: (in01 u). + exists (a <| u |> b); apply/andP; split. + apply between_conv. + by exists u; rewrite u01 eqxx. + rewrite utE; apply between_conv. + exists t; rewrite eqxx andbT in01M_ge0 -(divff denom) /t -mulrBl mulrACA addrAC ![det _ a b]det_cyclique subrr add0r mulrN -mulNr -expr2; apply mulr_ge0; last first. + by apply sqr_ge0. + by apply mulr_ge0; [ rewrite oppr_ge0 | apply ltW ]. +move:u01; rewrite in01M_ge0 leNgt=>/negbT; rewrite negbK=>u01. +move:(u01); rewrite -oppr_gt0 lt0r oppr_eq0 mulf_eq0 negb_or=>/andP[/andP [/lregP u0 /lregP u1] _]. +have: det (a <| u |> b) c d == 0 by rewrite utE det_conv -[det d _ _]det_cyclique 2!det_alternate convmm. +rewrite det_conv 2![det _ c d]det_cyclique addr_eq0 2!sm=>/eqP udetE. +move:cdsep; rewrite -(nmulr_rge0 _ u01) mulrACA udetE mulNr oppr_ge0 -expr2=>det2_le0. +have /eqP cdb0: det c d b == 0 by rewrite -(mulrI_eq0 _ u1) -sqrf_eq0; apply/eqP/le_anti/andP; split=>//; apply sqr_ge0. +move:udetE=>/eqP; rewrite cdb0 mulr0 oppr0 mulrI_eq0// =>/eqP cda0. +move:cd0; rewrite cdb0 cda0 eqxx cd/= =>/or3P[cab|dab|]; last first. +- by move=>/andP[acd _]; exists a; rewrite betweenl. +- by exists d; rewrite betweenr andbT. +- by exists c; rewrite betweenl andbT. +Qed. + +Lemma intersect_complete a b c d : + (exists p, between p a b && between p c d) -> intersect a b c d. +Proof. +have sm: forall t u, t *: (u : R^o) = t*u by []. +move:a b c d. +suff: forall a b c d, (exists p : counterclockwise.Plane R, between p a b && between p c d) -> separate a b c d. + move=> h a b c d abcd; apply/andP; split; apply h=>//. + by move:abcd=>[p]; rewrite andbC=>pabcd; exists p. + move=>a b c d [p] /andP[/between_conv] [t] /andP[t01] /eqP pe /between_conv [u] /andP[u01] /eqP pe'; subst p; rewrite/separate -andbA. +apply/andP; split. + have: det (a <| t |> b) a b == 0 by rewrite det_conv -[det b a b]det_cyclique 2!det_alternate convmm. + rewrite pe' det_conv 2![det _ a b]det_cyclique addr_eq0 2!sm=>/eqP detE. + move:u01; rewrite in01M_ge0 le0r =>/orP[|]. + rewrite mulf_eq0 subr_eq0 => /orP[|] /eqP ue; move:detE=>/eqP. + by rewrite ue mul0r subr0 mul1r eq_sym oppr_eq0=>/eqP->; rewrite mulr0. + by rewrite -ue mul1r subrr mul0r oppr0=>/eqP->; rewrite mul0r. + by move=>ui; rewrite -(pmulr_rle0 _ ui) mulrACA detE mulNr oppr_le0 -expr2; apply sqr_ge0. +case ab : (a == b)=>/=. + by move: ab=>/eqP ab; subst b; rewrite 2!det_alternate eqxx/= andbT; apply between_conv; exists u; apply/andP; split=>//; rewrite -pe' convmm. +apply/implyP=>/eqP/det0_aligned[]; first by move=>/eqP; rewrite ab. +move=>[t'] ce; apply/implyP=> /eqP/det0_aligned[]; first by move=>/eqP; rewrite ab. +move=>[u'] de. +wlog: c d u t' u' pe' u01 ce de / t' <= u'. + move=>h. + case tu: (t' <= u'); first by apply (h c d u t' u'). + move:tu; rewrite leNgt=>/negbT; rewrite negbK=>/ltW ut. + by rewrite 2![_ _ c d]betweenC andbC; apply (h d c (1-u) u' t')=>//; rewrite -?in01_onem -?convC. +move=>tu. +move:pe'; rewrite -{1}ce -{1}de /conv 3![(_ - _) *: b]scalerBl scale1r 3![_ *: _ + (_ - _)]addrCA -3!scalerBr 2![_ *: (_ + _ *: _)]scalerDr addrACA -scalerDl [u+(1-u)]addrCA subrr addr0 scale1r 2!scalerA -scalerDl=>/addrI/eqP. +rewrite -subr_eq0 -scalerBl scaler_eq0 2!subr_eq0 ab orbF=>tconv. +case t0: (t' < 0). + apply/or3P/Or32. + apply/between_depl; exists (a-b), t', u'; rewrite -ce -de 2!convrl 2!eqxx 2!andbT nmulr_rle0//. + move:u01 tconv=>/andP[u0]; rewrite -[u<=1]subr_ge0 le0r subr_eq0 -invr_gt0 => /orP[|]. + by move=>/eqP<-; rewrite subrr mul1r mul0r addr0=>/eqP te; move:t01=>/andP[]; rewrite te leNgt t0. + move=>ugt0. + have un0: (1-u)^-1 != 0 by apply/negP=>/eqP ue; move:ugt0; rewrite ue ltxx. + move:un0 (un0); rewrite {1}invr_eq0=>un0 /rregP ureg. + rewrite -subr_eq0 -(mulIr_eq0 _ ureg) opprD addrA mulrBl mulrAC divff// mul1r subr_eq0=>/eqP<-; apply mulr_ge0; last by apply ltW. + apply addr_ge0; first by move:t01=>/andP[t0' _]. + by rewrite -mulrN mulr_ge0 // oppr_ge0 ltW. +move:t0=>/negbT; rewrite -leNgt=>t0. +case u1: (1 < u'). + apply/or3P/Or31. + apply/between_depl; exists (b - a), (1 - t'), (1 - u'); rewrite -2!convlr ce de 2!eqxx 2!andbT. + move:u01 tconv=>/andP; rewrite le0r=>[[/orP[|]]]. + move=>/eqP-> _; rewrite subr0 mul0r mul1r add0r=>/eqP tu'. + by move:t01; rewrite tu'=>/andP[_]/(lt_le_trans u1); rewrite ltxx. + move:u1; rewrite -subr_lt0=>ugt1 u0 u1; rewrite nmulr_lle0//. + have un0 : u != 0 by rewrite gt_eqF. + move:(un0); rewrite -invr_eq0=>/rregP ureg. + rewrite -subr_eq0 -(mulIr_eq0 _ ureg) opprD addrCA addrC mulrBl mulrAC divff// mul1r subr_eq0=>/eqP<-; rewrite -(pmulr_rge0 _ u0) mulrBr mulrCA divff// 2!mulr1 opprB addrA subr_ge0. + move:t01=>/andP[_] t1. + apply (le_trans t1); rewrite -subr_ge0 addrAC -opprB -mulrN1 -mulrDr [-1+_]addrC. + by rewrite mulr_ge0// subr_ge0// -subr_le0 ltW. +move:u1=>/negbT; rewrite -leNgt=>u1. +apply/or3P/Or33. +apply/andP; split; apply between_conv. + by exists t'; rewrite ce eqxx andbT /in01 t0/= (le_trans tu). +by exists u'; rewrite de eqxx andbT /in01 u1 (le_trans t0). +Qed. + +Lemma is_left_oriented (p q r : Plane) : + encompass.is_left (@wccw R) p q r = wccw p q r. +Proof. +apply/idP/idP; last by rewrite/encompass.is_left; move=>->; rewrite !orbT. +by move=>/or3P[| |//] /eqP re; subst r; rewrite /wccw det_cyclique; + [rewrite det_cyclique |]; rewrite det_alternate. +Qed. + +(* We prove that if a segment does not intersect the border of a + convex set C, then either the segment is included in C, or they are + disjoint. + + C is represented by a list of points that generate it (as given by + the output of Jarvis' algorithm). + + We prove the result by contradiction, assuming that one point of + the segment lies inside C and another one is outside. We + immediately reduce to the case where the ends of the segment verify + this property. + + Let [a, b] be the segment, with a in C and b outside. Notice that + t \mapsto b <| t |> a is a continuous curve from a to b, hence we + expect it to cross the border of C. Let I = \{t \in [0, 1], + b <| t |> a \in C\} and t = sup(I). t is well defined because I is not + empty (as 0 \in I) and bounded (by 1). C being defined by a set of + large inequalities, + + we show b <| t |> a \in C. Then we show that at + least one inequality is an equality. Let this constraint being + given by two points x and y of the list defining C. Then b <| t |> a + is on the line (xy) and every other point of the list is strictly + to the left of the line (xy), hence every other inequality is + strict. Then, looking at the inequalities involving x and y, we + show that b <| t |> a is between x and y, which concludes the proof. + *) + +Lemma hull_border_no_intersection (l : seq Plane) (a b : Plane) : + (3 <= size l)%N -> + uniq l -> + encompass (@ccw R) l l -> + (forall i : 'I_(size l), ~~ intersect l`_i l`_i.+1mod a b) -> + (forall t, in01 t -> + encompass (@ccw R) [:: a <| t |> b] l) \/ + (forall t, in01 t -> + ~~ encompass (@wccw R) [:: a <| t |> b] l). +Proof. +have sm t u : t *: (u : R^o) = t * u by []. +move=> ls /uniqP lu ll lab. +have l0 : l != [::] by destruct l. +(* We start the proof by contradiction. *) +apply/or_asboolP/negPn; rewrite negb_or; apply/negP => /andP[/existsp_asboolPn [t /asboolPn]]. +rewrite asbool_imply negb_imply 2!asboolb => /andP[t01 ltab]. +move=> /existsp_asboolPn [u /asboolPn]. +rewrite asbool_imply negb_imply 2!asboolb negbK => /andP[u01 luab]. +(* We have two points, exactly one of them being encompassed by l, + we may assume that they are the ends of the segment. *) +wlog : a b t u lab t01 ltab u01 luab / (t == 0) && (u == 1). + move=> /(_ (a <| u |> b) (a <| t |> b) 0 1); apply. + - move=> i. + apply/negP => /intersect_correct[p]/andP[pl pab]. + move: (lab i) => /negP; apply; apply intersect_complete. + exists p; apply/andP; split=>//; refine (between_trans _ _ pab). + by apply between_conv; exists u; apply/andP; split => //. + by apply between_conv; exists t; apply/andP; split => //. + - by apply in010. + - by rewrite conv0. + - by apply in011. + - by rewrite conv1. + - by apply/andP; split. +move=>/andP[/eqP t0 /eqP u1]; subst t u; clear t01 u01. +move:ltab luab; rewrite conv0 conv1 => lb la. +(* We define I = \{t \in R, b <| t |> a is encompassed by l\}. + We show that I is not empty and bounded. *) +set I := [set t | in01 t && encompass (@wccw R) [:: b <| t |> a] l]%classic. +have I0 : I 0 by apply/andP; split; [apply in010 | rewrite conv0 ]. +have Ib : has_sup I. + split; first by exists 0. + by exists 1 => x /andP[/andP[_]]. +move: la; rewrite encompass_all_index l0/= =>/forallP. +setoid_rewrite andbT. +setoid_rewrite is_left_oriented; rewrite /wccw => la. +(* All constraints being a large inequality, they are all satisfied by sup I. *) +have lt (i : 'I_(size l)) : wccw l`_i l`_i.+1mod (b <| sup I |> a). + rewrite /wccw leNgt -det_cyclique det_conv convrl sm -opprB mulrN. + rewrite subr_lt0; apply/negP=>liI. + have abl0 : 0 < det a l`_i l`_i.+1mod - det b l`_i l`_i.+1mod. + rewrite ltNge; apply/negP => abl. + move: (sup_upper_bound Ib)=>/(_ 0 I0)Ige. + move:(mulr_le0_ge0 abl Ige); rewrite mulrC=>/(lt_le_trans liI). + rewrite ltNge=>/negP; apply. + by rewrite det_cyclique; apply la. + move:abl0 (abl0); rewrite {1}lt0r => /andP[abl0 _]. + rewrite -invr_gt0 => abl_gt0. + move:(liI); rewrite -subr_gt0 -(pmulr_lgt0 _ abl_gt0) mulrBl. + rewrite -mulrA divff// mulr1 => eps0. + move: (sup_adherent eps0 Ib) => [t]/andP[t01]. + rewrite encompass_all_index l0/= => /forallP/(_ i). + rewrite andbT is_left_oriented /wccw -det_cyclique det_conv convrl. + rewrite sm -opprB mulrN -(pmulr_lge0 _ abl_gt0) mulrBl -mulrA. + rewrite divff// mulr1 subr_ge0=>lit. + rewrite opprB addrCA subrr addr0=>/(le_lt_trans lit). + by rewrite ltxx. +have I1 : sup I <= 1. + apply sup_le_ub; first by exists 0. + by move=>x /andP[/andP[_]]. +(* At least one inequality is an equality, otherwise we would find + t > sup I that verifies all of them. *) +have : [exists i : 'I_(size l), det l`_i l`_i.+1mod (b <| sup I |> a) <= 0]. + move:I1; rewrite -subr_ge0 le0r subr_eq0 subr_gt0 => /orP[/eqP<-| I1]. + rewrite conv1; move:lb; rewrite encompass_all_index l0/= =>/forallPn[i]. + rewrite andbT !negb_or -leNgt =>/andP[_] /andP[lb det_le0]. + by apply/existsP; exists i. + rewrite -[_ _ _]negbK; apply/negP =>/existsPn Isubopt. + (* Each inequality defines a quantity by which we may exceed sup I + without falsifying it. The inequalities being strict, these + quantities are all positive, hence their mini too. Alas, R has + no maximum, and hence min has no neutral elemnt, so we work in + \bar R. *) + set t := \meet_(i < size l | 0 < det a l`_i l`_i.+1mod - det b l`_i l`_i.+1mod) + ((det l`_i l`_i.+1mod a) / (det l`_i l`_i.+1mod a - det l`_i l`_i.+1mod b))%:E. + have It : ((sup I)%:E < mine t 1%:E)%E. + rewrite ltxI lte_fin I1 andbT ereal_meets_gt// ?ltey//. + move=>i abl_gt0; move:(abl_gt0); rewrite lt0r=>/andP[abl0 _]. + rewrite lte_fin -subr_gt0 -(pmulr_lgt0 _ abl_gt0) mulrBl mulrAC -mulrA. + rewrite -2![det l`_i _ _]det_cyclique divff// mulr1. + by move:(Isubopt i); rewrite -ltNge -det_cyclique det_conv convrl sm -opprB mulrN. + have tfin : (fine (mine t 1%:E))%:E = mine t 1%:E. + apply/(@fineK R)/fin_numP; split; apply/negP=>/eqP tinf. + suff : (-oo < mine t 1)%E by rewrite tinf ltxx. + rewrite ltxI; apply/andP; split; last by apply: ltNye. + by apply ereal_meets_gt=>// i _; apply ltNye. + suff : (mine t 1 < +oo)%E by rewrite tinf ltxx. + by rewrite ltIx [(1 < +oo)%E]ltey orbT. + move: It; rewrite -tfin lte_fin ltNge=>/negP; apply. + have t01: in01 (fine (mine t 1%E)). + apply/andP; split; rewrite -lee_fin tfin; last by rewrite lteIx le_refl orbT. + rewrite ltexI; apply/andP; split; last by rewrite lee_fin ler01. + apply: Order.TMeetTheory.meets_ge => i abgt; rewrite lee_fin; apply: (mulr_ge0 (la _)). + by apply ltW; rewrite invr_gt0 -2![det l`_i _ _]det_cyclique. + apply: sup_upper_bound => //; apply/andP; split => //. + rewrite encompass_all_index l0/=; apply/forallP => i. + rewrite is_left_oriented andbT /wccw -det_cyclique det_conv convrl sm. + rewrite -opprB mulrN subr_ge0. + have [/[dup]|able0] := ltP 0 (det a l`_i l`_i.+1mod - det b l`_i l`_i.+1mod). + rewrite {1}lt0r -invr_gt0=>/andP[ab0 _] abgt0. + rewrite -subr_ge0 -(pmulr_lge0 _ abgt0) mulrBl subr_ge0 -mulrA divff// mulr1. + rewrite -lee_fin tfin leIx; apply/orP; left. + rewrite ![det _ l`_i _]det_cyclique /t. + by move:abgt0; rewrite invr_gt0=>abgt; exact: Order.TMeetTheory.meets_inf. + rewrite {2}[det a _ _]det_cyclique (le_trans _ (la i))// mulr_ge0_le0 //. + by move:t01 => /andP[]. +move=> /existsP[i] iable0. +(* We want to show that b <| sup I |> a suits. + We show that it is between] a and b and between l`_i and l`_(i+1). + This gives a witness to contradict the hypo (lab i). *) +move: lab =>/(_ i)/negP; apply; apply intersect_complete. +exists (b <| sup I |> a); apply/andP; split; last first. + rewrite betweenC; apply between_conv; exists (sup I); apply/andP; split=>//. + apply/andP; split=>//. + by apply sup_upper_bound. +(* First, b <| sup I |> a, l`_i and l`_(i+1) are aligned. *) +have : det l`_i l`_i.+1mod (b <| sup I |> a) = 0. + by apply: le_anti; apply/andP; split => //; apply: lt. +move=>/det0_aligned[/lu|]. + rewrite 2!inE. + move=>/(_ (ltn_ord i) (ltn_ord i.+1mod)); rewrite Zp_succE. + move:(ltn_ord i); rewrite leq_eqVlt => /predU1P[il|isl]. + rewrite il modnn=>i0; move:il; rewrite i0=>s1; move:ls; rewrite s1=>/ltnW. + by rewrite ltnn. + by rewrite modn_small// => /n_Sn. +move=>[t] tie; apply between_conv; exists t; rewrite tie eqxx andbT. +(* b <| sup I |> a is l`_i <| t |> l`_(i+1) for some t. We show 0 <= t <= 1 + by contradiction by looking at the inequalities + 0 <= det l`_j l`_(j+1) (b <| sup I |> a) for j = i+1 and j = i-1. *) +apply/negPn/negP; rewrite negb_and -2!ltNge => /orP[t0|]. + move:lt=>/(_ (Zp_succ i)); rewrite -tie /wccw -det_cyclique det_conv det_alternate /conv scaler0 addr0 sm nmulr_rge0// =>ile. + move:ll; rewrite encompass_all_index l0/= =>/forallP/(_ i)/allP/(_ l`_(Zp_succ (Zp_succ i))). + have /[swap]/[apply] : l`_i.+1mod.+1mod \in l by apply mem_nth. + rewrite /encompass.is_left /ccw ltNge ile orbF => /orP[|] /eqP/lu; rewrite 2!inE=>/(_ (ltn_ord _) (ltn_ord _)); rewrite !Zp_succE=>/eqP; rewrite -2!addn1 modnDml -addnA addn1. + by rewrite -{2}(modn_small (ltn_ord i)) -{2}(addn0 i) eqn_modDl modn_small// mod0n=>/eqP. + rewrite eqn_modDl modn_small// modn_small; last by apply ltnW. + by move=>/eqP. +rewrite -subr_lt0 => t0. +have predi_ltl : ((i + (size l).-1) %% (size l) < size l)%N by apply/ltn_pmod/ltnW/ltnW. +have succ_predi : Zp_succ (Ordinal predi_ltl) = i. + apply val_inj; rewrite Zp_succE -addn1 modnDml -addnA addn1 prednK; last by do 2 apply ltnW. + by rewrite modnDr modn_small. +move:lt=>/(_ (Ordinal predi_ltl)); rewrite succ_predi -tie /wccw -det_cyclique det_conv -det_cyclique det_alternate /conv scaler0 add0r sm nmulr_rge0// =>ile. +move:ll; rewrite encompass_all_index l0/= =>/forallP/(_ (Ordinal predi_ltl))/allP/(_ l`_(Zp_succ i)). +have /[swap]/[apply] : l`_(Zp_succ i) \in l by apply mem_nth. +rewrite succ_predi /encompass.is_left /ccw ltNge -det_cyclique ile orbF => /orP[|] /eqP/lu; rewrite 2!inE=>/(_ (ltn_ord _) (ltn_ord _)); rewrite !Zp_succE=>/eqP. + rewrite -addn1 eqn_modDl modn_small//; last by apply ltnW. + rewrite modn_small; last by rewrite prednK=>//; do 2 apply ltnW. + rewrite -eqSS prednK; last by do 2 apply ltnW. + by move=>/eqP s2; move:ls; rewrite s2 ltnn. +by rewrite -{2}(modn_small (ltn_ord i)) -addn1 -{2}(addn0 i) eqn_modDl mod0n modn_small; last by apply ltnW. +Qed. + +End Plane. diff --git a/theories/isolate.v b/theories/isolate.v new file mode 100644 index 0000000..2270bb4 --- /dev/null +++ b/theories/isolate.v @@ -0,0 +1,689 @@ +From HB Require Import structures. +From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype order. +From mathcomp Require Import div finfun bigop prime binomial ssralg finset fingroup finalg archimedean. +From mathcomp Require Import mxalgebra perm zmodp matrix ssrint. +(*From mathcomp Require Import (*refinements NB(rei) funperm*).*) +From mathcomp Require Import seq rat. +Require Import (*seqpoly*) pol square_free casteljau desc. + +From mathcomp Require Import ssrnum ssrint realalg poly. +Require Import poly_normal. +Import Order.Theory GRing.Theory Num.Theory. + +(* Bernstein coefficients for half intervals can be computed using the + algorithm by de Casteljau. *) +Open Scope ring_scope. + +Fixpoint casteljau (l : seq rat) (n : nat) : nat -> rat := + match n with + O => fun j => nth 0 l j + | S p => fun j => ((casteljau l p j + casteljau l p j.+1)/(1+1))%R + end. + +(* This computes the Bernstein coefficients for the left hand side + half. *) +Definition dicho_l n l := + map (fun i => casteljau l i 0) (iota 0 (S n)). + +Definition dicho_r n l := + map (fun i => casteljau l (n - i) i) (iota 0 (S n)). + +(* +Fixpoint count_root n d (l : seq rat) : option nat := + match n with + 0 => None + | S p => + match qe_rcf_th.changes (seqn0 l) with + 0%N => Some 0%N + | 1%N => Some 1%N + |_ => let l2 := dicho_r d l in + match count_root p d l2, count_root p d (dicho_l d l) with + Some v1, Some v2 => + if head 0 l2 == 0 then Some (v1 + v2 + 1)%N else Some (v1 + v2)%N + | _, _ => None + end + end + end. +*) + +Section dicho_correct. +Variable R : numFieldType. + +Lemma casteljau_correct (l : seq rat) k n : + ratr (casteljau l k n) = + de_casteljau (R:=R) (1/(1+1)) (1/(1+1)) + (fun i => ratr (nth 0 l i)) k n. +Proof. +elim : k n => [ n | k Ik n]; first by []. +rewrite /= rmorphM rmorphD rmorphV; last by rewrite unitf_gt0 //. +by rewrite /= rmorphD !rmorph1 !Ik mulrDl !mul1r !(mulrC (_ ^-1)). +Qed. + +Lemma dicho_l_correct (n : nat) (l : seq rat) (k : nat) : + (size l <= n.+1)%nat -> (k <= n)%nat -> + ratr (nth 0 (dicho_l n l) k) = + dicho' (R := R) (1/(1+1)) (1/(1+1)) (fun i => ratr (nth 0 l i)) k. +Proof. +move => sl kn. +rewrite /dicho_l /dicho'. +have kn' : (k < size (iota 0 n.+1))%nat. + by rewrite size_iota. +rewrite (nth_map 0%nat 0 (fun v => casteljau l v 0)) //. +by rewrite nth_iota // add0n casteljau_correct. +Qed. + +Lemma dicho_r_correct (n : nat) (l : seq rat) (k : nat) : + (size l <= n.+1)%nat -> (k <= n)%nat -> + ratr (nth 0 (dicho_r n l) k) = + dicho (R := R) (1/(1+1)) (1/(1+1)) n (fun i => ratr (nth 0 l i)) k. +Proof. +move => sl kn. +rewrite /dicho_r /dicho. +have kn' : (k < size (iota 0 n.+1))%nat. + by rewrite size_iota. +rewrite (nth_map 0%nat 0 (fun v => casteljau l (n - v) v)) //. +by rewrite nth_iota // add0n casteljau_correct. +Qed. + +End dicho_correct. + +Inductive root_info A : Type := + | Exact (x : A) + | One_in (x y : A) + | Zero_in (x y : A) + | Unknown (x y : A). + +(* +Fixpoint isol_rec n d (a b : rat) (l : seq rat) acc : seq (root_info rat) := + match n with + O => Unknown _ a b::acc + | S p => + match qe_rcf_th.changes (seqn0 l) with + | 0%nat => Zero_in _ a b::acc + | 1%nat => One_in _ a b::acc + | _ => + let c := ((a + b)/(1+1)) in + let l2 := dicho_r d l in + isol_rec p d a c (dicho_l d l) + (if head 0 l2 == 0 then + Exact _ c::isol_rec p d c b l2 acc + else isol_rec p d c b l2 acc) + end + end. +*) + +Definition root_info_eq (R : eqType) + (x y : root_info R) : bool := + match x, y with + Exact a, Exact b => a == b :> R + | Zero_in a1 a2, Zero_in b1 b2 => (a1 == b1 :> R) && (a2 == b2 :> R) + | One_in a1 a2, One_in b1 b2 => (a1 == b1 :> R) && (a2 == b2 :> R) + | Unknown a1 a2, Unknown b1 b2 => (a1 == b1 :> R) && (a2 == b2 :> R) + | _, _ => false + end. + +Lemma root_info_eqP : forall (R : eqType), Equality.axiom (root_info_eq R). +Proof. +by move => R [x|x y|x y|x y] [z |z t|z t|z t]; + (apply: (iffP idP); + first (rewrite //=; try (case/andP=> /eqP -> /eqP -> //); + move=>/eqP ->)) => //; case=> -> //= -> /=; + apply/andP; split. +Qed. + +Section more_on_dicho. + +Lemma dicho_ext : + forall (R : comRingType) (a b : R) n f1 f2 p, (p <= n)%N -> + (forall i, (i <= n)%N -> f1 i = f2 i) -> + dicho a b n f1 p = dicho a b n f2 p. +Proof. +move=> R a b n f1 f2 p pn q; rewrite /dicho; apply: ext_dc => i ci1 ci2. +by apply/q/(leq_trans ci2); rewrite subnKC. +Qed. + +End more_on_dicho. + +Section count_root_correct. + +Variable R : archiFieldType. + +(*TODO(rei, gave up when moving to MathComp 2): Definition R' : archiFieldType := (R : rcfType).*) + +(* +Lemma count_root_correct0 n (l : seq rat) q d (a b: R') : + (0 < d)%N -> a < b -> q != 0 -> size l = d.+1 -> + q = \sum_(i < d.+1) (nth 0 (map ratr l) i) *: + bernp a b d i -> count_root n d l = Some 0%N -> + forall (x : R'), a < x < b -> q.[x]!=0. +Proof. +move=> dgt0; elim: n l a b => [ | n In l a b ab qn0 sl qq]; first by []. +rewrite /=. +have anb : a != b. + by apply/negP => aqb; move: ab; rewrite ltr_neqAle aqb. +have bman0 : b - a != 0 by rewrite subr_eq0 eq_sym. +have twogt0 : (0 < 1 + 1 :> R'). + by apply: addr_gt0; apply: ltr01. +have twon0 : (1 + 1 != 0 :> R'). + by apply/negP => two0; move: twogt0; rewrite ltr_neqAle eq_sym two0. +have twoV : forall a, a = a/(1 + 1) + a/(1+1) :> R'. + by move=> y; rewrite -mulrDl -(mulr1 y) -mulrDr mulrK // mulr1. +have altm : a < (a + b)/(1 + 1). + by rewrite {1}[a]twoV mulrDl ltr_add2l ltr_pM2r // invr_gt0. +have mltb : (a + b)/(1 + 1) < b. + by rewrite {2}[b]twoV mulrDl ltr_add2r ltr_pM2r // invr_gt0. +have mna : (a + b)/(1 + 1) != a. + by apply/negP => ma; move:altm; rewrite ltr_neqAle eq_sym ma. +have mnb : (a + b)/(1 + 1) != b. + by apply/negP => mb; move:mltb; rewrite ltr_neqAle mb. +case ch: (qe_rcf_th.changes (seqn0 l)) => [ | nch]. + move => _; apply: (ch0_correct (d := d) ab qn0 qq) => //. + (* The following proof exactly common with isol_rec_no_root, except for hypothesis + that are discarded at the time of tactic elim *) + elim: {qq sl} l ch => /= [| e l Il]; first by []. + case e0 : (e == 0). + by rewrite (eqP e0) rmorph0 eqxx. + case h : (_ == 0). + move/negbT : e0 => /negP; case. + by rewrite -(fmorph_eq0 (ratr_rmorphism (RealAlg.alg_of_rcfType R))) h. + rewrite /=. + move/eqP; rewrite addn_eq0 => /andP [pe /eqP pl]. + apply/eqP; rewrite addn_eq0; apply/andP; split; last first. + by apply/eqP; apply: Il. + set (u := ratr e). + have sr : (head 0 (seqn0 l) < 0) = + (head 0 (seqn0 [seq ratr i | i <- l]) < 0 :> RealAlg.alg_of_rcfType R). + elim : {Il pl pe} l => [ | e' l' Il']; first by rewrite /= ltrr. + rewrite /=; case he' : (e' == 0) => /=. + by rewrite (eqP he') rmorph0 eqxx /=. + by rewrite fmorph_eq0 he' /= ltrq0. + have sr' : (0 < head 0 (seqn0 l)) = + (0 < head 0 (seqn0 [seq ratr i | i <- l]) :> RealAlg.alg_of_rcfType R). + elim : {Il pl pe sr} l => [ | e' l' Il']; first by rewrite /= ltrr. + rewrite /=; case he' : (e' == 0) => /=. + by rewrite (eqP he') rmorph0 eqxx /=. + by rewrite fmorph_eq0 he' /= ltr0q. + case u0 : (u < 0). + rewrite nmulr_rlt0; last by []. + move: u0; rewrite ltrq0 => u0. + by rewrite -sr' -(nmulr_rlt0 _ u0). + move: u0; rewrite ltrNge ler_eqVlt eq_sym h /= => /negbFE => u0. + rewrite pmulr_rlt0; last by []. + by move: u0; rewrite ltr0q => u0; rewrite -sr -(pmulr_rlt0 _ u0). + (* end of common proof. *) +case: {ch} nch => [| _]; first by []. +case cr1 : (count_root n d (dicho_r d l)) => [ [ | v1] | //]; + case cr2 : (count_root n d (dicho_l d l)) => [ [ | v2] | //]; + case cc : ((casteljau l (d - 0) 0) == 0) => //. +move => _ x axb. +case xm : (x < (a + b) / (1 + 1)). + have axm : (a < x < (a + b)/(1 + 1)). + by case/andP: axb => [ax xb]; rewrite ax xm. + have sl' : size (dicho_l d l) = d.+1 by rewrite /dicho_l size_map size_iota. + have qq' : q = \sum_(i < d.+1) + [seq ratr i | i <- dicho_l d l]`_i *: + bernp (R:=R') a ((a + b) / (1 + 1)) d i. + have sll : (size l <= d.+1)%N by rewrite sl leqnn. + have dlc := fun k => dicho_l_correct (RealAlg.alg_of_rcfType R) d l k sll. + set f := fun i : 'I_d.+1 => + dicho' ((b - (a + b)/(1+1)) / (b - a)) (((a + b)/(1+1) - a) / (b - a)) + [eta nth 0 [seq ratr v | v <- l]] i *: bernp a ((a + b)/(1+1)) d i. + have bodyq : + forall i : 'I_d.+1, true -> + [seq ratr i | i <- dicho_l d l]`_i *: bernp a ((a + b)/(1+1)) d i = f i. + rewrite /f. + have -> : (b - (a + b)/(1 + 1))/(b - a) = 1/(1 + 1). + rewrite (addrC a) {1}[b]twoV !mulrDl opprD mulrBl addrA. + by rewrite mulNr addrK -!mulrBl mulrC mulrA mulVf. + have -> : ((a + b) / (1 + 1) - a) / (b - a) = 1/(1 + 1). + rewrite (addrC a) {2}[a]twoV (mulrDl b) opprD addrA addrK -mulrBl. + by rewrite mulrC mulrA mulVf. + move=> [i id] _; congr (_ *: _). + rewrite /nat_of_ord (nth_map 0 0) ?sl' // dlc /dicho'. + apply: ext_dc => j j0 ji. + by rewrite (nth_map 0 0) // (leq_ltn_trans ji) // sl. + by rewrite -ltnS. + rewrite (eq_bigr f bodyq) /f. + by apply:(dicho'_correct (c :=fun i => [seq ratr v | v <- l]`_i) anb mna qq). + by apply: (In _ _ _ altm qn0 sl' qq' cr2 _ axm). +set f := fun i : 'I_d.+1 => + dicho ((b - (a + b)/(1+1)) / (b - a)) (((a + b)/(1+1) - a) / (b - a)) + d [eta nth 0 [seq ratr v | v <- l]] i *: bernp ((a + b)/(1+1)) b d i. +have sll : (size l <= d.+1)%N by rewrite sl leqnn. +have drc := fun k => dicho_r_correct (RealAlg.alg_of_rcfType R) d l k sll. +have sl' : size (dicho_r d l) = d.+1 by rewrite /dicho_l size_map size_iota. +have bodyq : + forall i : 'I_d.+1, true -> + [seq ratr i | i <- dicho_r d l]`_i *: bernp ((a + b)/(1+1)) b d i = f i. + rewrite /f. + have -> : (b - (a + b)/(1 + 1))/(b - a) = 1/(1 + 1). + rewrite (addrC a) {1}[b]twoV !mulrDl opprD mulrBl addrA. + by rewrite mulNr addrK -!mulrBl mulrC mulrA mulVf. + have -> : ((a + b) / (1 + 1) - a) / (b - a) = 1/(1 + 1). + rewrite (addrC a) {2}[a]twoV (mulrDl b) opprD addrA addrK -mulrBl. + by rewrite mulrC mulrA mulVf. + move=> [i id] _; congr (_ *: _). + rewrite /nat_of_ord (nth_map 0 0) ?sl' // drc /dicho. + apply: ext_dc => j j0 ji. + by rewrite (nth_map 0 0) // sl (leq_ltn_trans ji) // subnKC. + by rewrite -ltnS. +have qq' : q = \sum_(i < d.+1) + [seq ratr i | i <- dicho_r d l]`_i *: + bernp (R:=R') ((a + b) / (1 + 1)) b d i. + rewrite (eq_bigr f bodyq) /f. + apply:(dicho_correct (c :=fun i => [seq ratr v | v <- l]`_i) anb mnb qq). +move/negP/negP: xm ; rewrite -lerNgt ler_eqVlt => /orP [/eqP xm | xm]; last first. + have mxb : ((a + b)/(1 + 1) < x < b). + by case/andP: axb => [ax xb]; rewrite xb xm. + by apply: (In _ _ _ mltb qn0 sl' qq' cr1 _ mxb). +rewrite qq' (big_morph (fun p => horner p x) (fun p q => hornerD p q x) + (horner0 x)). +have b0m := fun i (id : (i <= d)%N) => bern0_a mnb dgt0 id. +have all0 : forall (i : 'I_d), true -> + ([seq ratr i | i <- dicho_r d l]`_(lift ord0 i) *: + bernp (R:=R') x b d (lift ord0 i)).[x] = 0. + move => i _. + have id: (lift ord0 i <= d)%N by case: i => [i id]. + have : (lift ord0 i != 0) by case: {id} i => [i id']. + rewrite -(b0m _ id) xm /R' hornerZ => /eqP ->. + by rewrite mulr0. +rewrite big_ord_recl big1; last by rewrite xm. +rewrite addr0 hornerZ mulf_neq0 //. + by rewrite /= fmorph_eq0 cc. +by rewrite -xm (b0m _ (leq0n d)). +Qed. +*) + +End count_root_correct. + +Section isol_rec_correct. + +Variable R : archiFieldType. + +(*NB(rei): couldn't type Unknown rat a b a few lines below +Lemma isol_rec_acc : forall n d a b l acc, exists l'', + @isol_rec R n d a b l acc = l''++acc. +Proof. +elim => [| n In] d a b l acc. + by rewrite /=; exists [:: Unknown rat a b]. +rewrite /=; case: (qe_rcf_th.changes (seqn0 l)) => [ | n0]; + first by exists [:: Zero_in _ a b]. +case: n0 => [ | n1]; first by exists [:: One_in rat a b]. +case: (In d ((a + b) / (1+1)) b (dicho_r d l) acc) => [l1 l1q]. +case: (casteljau l (d - 0) 0 == 0). + case: (In d a ((a + b) / (1+1)) (dicho_l d l) + (Exact _ ((a + b) / (1+1))::l1++acc)) => [l2 l2q]. + exists (l2++Exact _ ((a + b) / (1+1))::l1). + by rewrite -(cat1s _ l1) l1q l2q -!catA. +case: (In d a ((a + b) / (1+1)) (dicho_l d l) (l1++acc)) => [l2 l2q]. +by exists (l2++l1); rewrite l1q l2q -!catA. +Qed.*) + +HB.instance Definition _ := hasDecEq.Build _ (root_info_eqP R). + +(*Canonical root_info_eqType (R : eqType) := + Eval hnf in EqType (root_info R) (root_info_eqMixin R). + +Arguments root_info_eqP {R x y}. +Prenex Implicits root_info_eqP.*) + + +(* NB(rei): typing issue with {realclosure _} +Lemma isol_rec_no_root n (l : seq rat) q d (a b:rat) a' b' acc : + a < b -> q != 0 -> size l = d.+1 -> + ~~ (Zero_in rat a' b' \in acc) -> + Zero_in rat a' b' \in isol_rec n d a b l acc -> + q = \sum_(i < d.+1) (nth 0 (map ratr l) i) *: + bernp (ratr a) (ratr b) d i -> + forall (x : {realclosure R}), ratr a' < x < ratr b' -> q.[x]!=0. +Proof. +set two := (1 + 1: RealAlg.alg_of_rcfType R); have twon0 : two != 0. + have twogt0' : 0 < two by apply: addr_gt0; apply:ltr01. + by move: twogt0'; rewrite ltr_neqAle eq_sym=>/andP []. +elim: n l q d a b a' b' acc => [ | n In] l q d a b a' b' acc ab qn0 sl nin /=. + by rewrite in_cons =>/orP [ // | ] => in_indeed; move:nin; rewrite in_indeed. +have rcfab : (ratr a < ratr b :> RealAlg.alg_of_rcfType R). + (* could not use directly apply: ltr_rat; obviously I did not understand + that morphism properties are rewriting properties *) + by rewrite ltr_rat. +have rabd : ratr a != ratr b :> RealAlg.alg_of_rcfType R. + apply/negP; move/eqP => rab. + have aqb: a == b by apply/eqP/(fmorph_inj (ratr_rmorphism _) rab). + by move: ab; rewrite ltr_neqAle aqb. +have rbman0 : ratr b - ratr a != 0 :> RealAlg.alg_of_rcfType R. + by rewrite subr_eq0 eq_sym. +have twogt0 : 0 < 1 + 1 :> rat by apply: addr_gt0; rewrite ltr01 . +have a1b1 : (a + b)/(1+1) < b :> rat. + rewrite -(ltr_pM2r twogt0) mulfVK. + by rewrite mulrDr mulr1 ltr_add2r. + by move: twogt0; rewrite ltr_neqAle eq_sym=>/andP; case. +have a2b2 : a < (a + b)/(1+1) :> rat. + rewrite -(ltr_pM2r twogt0) mulfVK. + by rewrite mulrDr mulr1 ltr_add2l. + by move: twogt0; rewrite ltr_neqAle eq_sym=>/andP; case. +have rmbd: (ratr a + ratr b)/(1+1) != ratr b :> RealAlg.alg_of_rcfType R. + apply/negP;move=> /eqP. + rewrite -(rmorph1 ((ratr_rmorphism _))) -!rmorphD -fmorphV -rmorphM => rmb. + have mqb: (a + b)/(1 + 1) == b. + by apply/eqP/(fmorph_inj (ratr_rmorphism _) rmb). + by move: a1b1; rewrite ltr_neqAle mqb. +have ramd: ratr a != (ratr a + ratr b)/(1+1) :> RealAlg.alg_of_rcfType R. + apply/negP;move=> /eqP. + rewrite -(rmorph1 ((ratr_rmorphism _))) -!rmorphD -fmorphV -rmorphM => ram. + have aqm: a == (a + b)/(1 + 1). + by apply/eqP/(fmorph_inj (ratr_rmorphism _) ram). + by move: a2b2; rewrite ltr_neqAle aqm. +have sd : size (dicho_r d l) = d.+1 by rewrite /dicho_r size_map size_iota. + have sl' : (size l <= d.+1)%N by rewrite leq_eqVlt sl eqxx. +have sd' : size (dicho_l d l) = d.+1 by rewrite /dicho_l size_map size_iota. +case ch: (qe_rcf_th.changes (seqn0 l)) => [ | nch]. + rewrite in_cons=> /orP [ /eqP[-> ->] | abs] qq x intx. + apply: (ch0_correct (d := d) rcfab qn0 qq) => //. + elim: {qq sl sd sd' sl'} l ch => /= [| e l Il]; first by []. + case e0 : (e == 0). + by rewrite (eqP e0) rmorph0 eqxx. + case h : (_ == 0). + move/negbT : e0 => /negP; case. + by rewrite -(fmorph_eq0 (ratr_rmorphism (RealAlg.alg_of_rcfType R))) h. + rewrite /=. + move/eqP; rewrite addn_eq0 => /andP [pe /eqP pl]. + apply/eqP; rewrite addn_eq0; apply/andP; split; last first. + by apply/eqP; apply: Il. + set (u := ratr e). + have sr : (head 0 (seqn0 l) < 0) = + (head 0 (seqn0 [seq ratr i | i <- l]) < 0 :> RealAlg.alg_of_rcfType R). + elim : {Il pl pe} l => [ | e' l' Il']; first by rewrite /= ltrr. + rewrite /=; case he' : (e' == 0) => /=. + by rewrite (eqP he') rmorph0 eqxx /=. + by rewrite fmorph_eq0 he' /= ltrq0. + have sr' : (0 < head 0 (seqn0 l)) = + (0 < head 0 (seqn0 [seq ratr i | i <- l]) :> RealAlg.alg_of_rcfType R). + elim : {Il pl pe sr} l => [ | e' l' Il']; first by rewrite /= ltrr. + rewrite /=; case he' : (e' == 0) => /=. + by rewrite (eqP he') rmorph0 eqxx /=. + by rewrite fmorph_eq0 he' /= ltr0q. + case u0 : (u < 0). + rewrite nmulr_rlt0; last by []. + move: u0; rewrite ltrq0 => u0. + by rewrite -sr' -(nmulr_rlt0 _ u0). + move: u0; rewrite ltrNge ler_eqVlt eq_sym h /= => /negbFE => u0. + rewrite pmulr_rlt0; last by []. + by move: u0; rewrite ltr0q => u0; rewrite -sr -(pmulr_rlt0 _ u0). + by case/negP: nin. +case: {ch} nch. + rewrite in_cons; case/orP; last by move=>abs; move:nin; rewrite abs. + by move/eqP. +case zac1: (Zero_in rat a' b' \in + (if casteljau l (d - 0) 0 == 0 + then + Exact rat ((a + b) / (1 + 1)) + :: isol_rec n d ((a + b) / (1 + 1)) b (dicho_r d l) acc + else isol_rec n d ((a + b) / (1 + 1)) b (dicho_r d l) acc)). + move => _ _ qq. + have zac2 : Zero_in rat a' b' \in + isol_rec n d ((a + b) / (1 + 1)) b (dicho_r d l) acc. + move: zac1; case: (casteljau l (d - 0) 0 == 0); last by []. + by rewrite in_cons; case/orP => [/eqP | ]. + apply: (In _ q d _ _ a' b' acc a1b1 qn0 sd nin zac2). + move=> {zac1 In zac2}. + have drc := fun k => dicho_r_correct (RealAlg.alg_of_rcfType R) d l k sl'. + have bodyq : + forall i : 'I_d.+1, + [seq ratr i | i <- dicho_r d l]`_i *: + bernp (ratr ((a + b)/(1+1))) (ratr b) d i = + dicho ((ratr b - (ratr a + ratr b)/(1+1)) / (ratr b - ratr a)) + (((ratr a + ratr b)/(1+1) - ratr a) / (ratr b - ratr a)) d + [eta nth 0 [seq ratr v | v <- l]] i *: + bernp (R:=RealAlg.alg_of_rcfType R) ((ratr a + ratr b)/(1+1)) (ratr b) d i. + (* TODO : find the politically correct way to do "simpl nat_of_ord" without simplifying everywhere *) + move=> [i id]; simpl nat_of_ord. + move: (id); rewrite ltnS => id'. + rewrite -[X in X - _/_](mulfVK twon0) mulrDr mulr1 -mulrDl -mulrBl opprD. + rewrite addrA (addrC _ (- ratr b)) !addrA addNr add0r (mulrC ((_ - _) / _)). + rewrite mulrA mulVr //. + rewrite -[X in _/_ - X](mulfVK twon0) mulrDr mulr1 -mulrDl -mulrBl opprD. + rewrite !addrA (addrC (_ + _) (- ratr a)) !addrA addNr add0r. + rewrite -mulrA (mulrC (_^-1)) mulrA mulrV //. + rewrite rmorphM rmorphD rmorphV // rmorphD rmorph1. + congr (_ *: _); rewrite (nth_map 0 0); last by rewrite sd. + rewrite drc //; apply: (dicho_ext _ (1/two)) => //. + by move => j jc; rewrite (nth_map 0 0) // sl ltnS. + rewrite (eq_bigr (fun i : 'I_d.+1 => + dicho (R:=RealAlg.alg_of_rcfType R) + ((ratr b - (ratr a + ratr b) / (1 + 1)) / (ratr b - ratr a)) + (((ratr a + ratr b) / (1 + 1) - ratr a) / (ratr b - ratr a)) d + [eta nth 0 [seq ratr v | v <- l]] i *: + bernp (R:=RealAlg.alg_of_rcfType R) ((ratr a + ratr b) / (1 + 1)) + (ratr b) d i)); last by move => i _; apply bodyq. + by apply: (dicho_correct (c := fun i => [seq ratr v | v <- l]`_i) rabd rmbd qq). +move: zac1; set acc' := (if casteljau _ _ _ == 0 then _ else _). +move/negP/negP=> zac1 _ zac2 qq. + apply: (In _ q d _ _ a' b' acc' a2b2 qn0 sd' zac1 zac2). + have dlc := fun k => dicho_l_correct (RealAlg.alg_of_rcfType R) d l k sl'. + have bodyq : + forall i : 'I_d.+1, + [seq ratr i | i <- dicho_l d l]`_i *: + bernp (ratr a) (ratr ((a + b)/(1+1))) d i = + dicho' ((ratr b - (ratr a + ratr b)/(1+1)) / (ratr b - ratr a)) + (((ratr a + ratr b)/(1+1) - ratr a) / (ratr b - ratr a)) + [eta nth 0 [seq ratr v | v <- l]] i *: + bernp (R:=RealAlg.alg_of_rcfType R) (ratr a) ((ratr a + ratr b)/(1+1)) d i. + move=> [i id]; simpl nat_of_ord. (* TODO : same as above *) + move: (id); rewrite ltnS => id'. + rewrite -[X in X - _/_](mulfVK twon0) mulrDr mulr1 -mulrDl -mulrBl opprD. + rewrite (addrC (-ratr a)) addrA addrK (mulrC ((_ - _) / _)) mulrA mulVr //. + rewrite -[X in _/_ - X](mulfVK twon0) mulrDr mulr1 -mulrDl -mulrBl opprD. + rewrite !addrA (addrC (_ + _) (- ratr a)) !addrA addNr add0r. + rewrite -mulrA (mulrC (_^-1)) mulrA mulrV //. + rewrite rmorphM rmorphD rmorphV // rmorphD rmorph1. + congr (_ *: _); rewrite (nth_map 0 0); last by rewrite sd'. + rewrite dlc //; rewrite /dicho'; apply ext_dc. + by move => j j0 ji; rewrite (nth_map 0 0) // sl (leq_ltn_trans ji) //. +move: ramd; rewrite eq_sym => ramd. +rewrite (eq_bigr (fun i : 'I_d.+1 => + dicho' (R:=RealAlg.alg_of_rcfType R) + ((ratr b - (ratr a + ratr b) / (1 + 1)) / (ratr b - ratr a)) + (((ratr a + ratr b) / (1 + 1) - ratr a) / (ratr b - ratr a)) + [eta nth 0 [seq ratr v | v <- l]] i *: + bernp (R:=RealAlg.alg_of_rcfType R) (ratr a) ((ratr a + ratr b) / (1 + 1)) + d i)); last by move => i _ ; apply bodyq. +by apply: (dicho'_correct (c := fun i => [seq ratr v | v <- l]`_i) rabd ramd). +Qed. +*) + +End isol_rec_correct. + +Definition big_num := 500%nat. + +(* Returns the last element of the sequence of coefficients, i.e. + the lead coefficient if the sequence is normal. *) +(*NB(rei): it looks like this has to do with evaluation, rm? +Definition lead_coef p := last 0%bigQ p. +*) + +(* To be used with a monic divisor d, of degree dd *) + +(* +Fixpoint divp_r (p d : seq bigQ) (dd : nat) : seq bigQ * seq bigQ := + if NPeano.Nat.leb (size p) dd + then ([::], p) + else + match p with + [::] => ([::], p) + | a::p' => let (q, r) := divp_r p' d dd in + let y := nth a (a::r) dd in + (y::q, addp (a::r) (scal ((-1) * y) d)) + end. + +Definition divp p d := + let d' := normalize d in + let dd := (size d').-1 in + let lc := lead_coef d' in + match d' with + [::] => ([::], p) + | _::_ => let (q, r) := divp_r p (map (fun x => x/lc)%bigQ d') dd in + (map (fun x => x/lc)%bigQ q, normalize r) + end. +*) + +(* Correctness proof. *) + +(* Definition repr (l : list bigQ) : poly rat := *) + +(* + +Definition clean_divp p d := + let (a, b) := divp p d in (map red (normalize a), map red (normalize b)). + +Fixpoint gcd_r n (p q : seq bigQ) : seq bigQ := + match n with + O => p + | S n' => + let (_, r) := clean_divp p q in + match r with nil => q | _ => gcd_r n' q r end + end. + +Definition gcd (p q : seq bigQ) := + let r := gcd_r (maxn (size p) (size q)).+1 p q in + let lc := lead_coef r in + map (fun x => red (x/lc)) r. + +Compute (clean_divp [::3;1] [::4;1])%bigQ. +Compute (clean_divp [::3;2;1] [::1])%bigQ. +Compute (gcd_r 4 [::3;1] [::4;1])%bigQ. + +Fixpoint bigQ_of_nat (n : nat) := + match n with 0%nat => 0%bigQ | S p => (1 + bigQ_of_nat p)%bigQ end. + +Definition derive p := + match product (map bigQ_of_nat (iota 0 (size p))) p with + _::p' => p' | _ => nil + end. + +Definition no_square p := + fst (clean_divp p (gcd p (derive p))). + +Definition isolate a b p : seq (root_info bigQ) := + let l := no_square p in + let deg := (size l).-1 in + let coefs := b_coefs deg a b l in + let b_is_root := + if eq_bool (last 0%bigQ coefs) 0 then [:: Exact _ b] else [::] in + let result := isol_rec big_num deg a b coefs b_is_root in + if eq_bool (head 0%bigQ l) 0 then Exact _ a::result else result. + +Fixpoint horner x p := + match p with + nil => 0%bigQ + | a::p' => (a + x * horner x p')%bigQ + end. + +Fixpoint ref_rec n a b pol := + match n with + O => One_in _ (red a) (red b) + | S p => + let c := ((a + b)/2)%bigQ in + let v := horner c pol in + match (v ?= 0)%bigQ with + Lt => ref_rec p c b pol + | Gt => ref_rec p a c pol + | Eq => Exact _ (red c) + end + end. + +Fixpoint first_sign l := + match l with + nil => 1%bigQ + | a::tl => + match (a ?= 0) with Eq => first_sign tl | Lt => -1 | Gt => 1 end%bigQ + end. + +Definition refine n a b p := + let deg := (List.length p).-1 in + let coefs := b_coefs deg a b p in + ref_rec n a b (scal (-1 * first_sign coefs) p). + +(* This polynomial has 1,2, and 3 as roots. *) +Definition pol2 : list bigQ := ((-6)::11::(-6)::1::nil)%bigQ. + +(* This polynomial as 1 and 2 as roots, with respective multiplicities + 1 and 2. *) + +Definition pol3 : list bigQ := ((-4)::8::(-5)::1::nil)%bigQ. + +Fixpoint no_root (l : list (root_info bigQ)) : bool := + match l with + nil => true + | Zero_in a b::l' => no_root l' + | _ => false + end. + +(* this polynomial has only one root, but the curve comes close to + the x axis around 2.5: this forces the dichotomy process a few times. *) +Definition mypol : list bigQ := ((-28/5)::11::(-6)::1::nil)%bigQ. + +Compute mypol. +Compute clean_divp mypol [::1]%bigQ. +Compute no_square mypol. +Compute b_coefs 3 0 4 (no_square mypol). + +(* The following isolates the single root of mypol in (0,4) *) +Compute isolate 0 4 mypol. + +(* The following computation proves that mypol has no roots in (2,4) *) +Compute no_root (isolate 2 4 mypol). + +Compute b_coefs 3 2 4 mypol. +Compute map (fun p => p.1 ?= p.2)%bigQ + (zip (dicho_r 3 (b_coefs 3 2 4 mypol)) (b_coefs 3 3 4 mypol)). +Compute let l := b_coefs 3 3 4 mypol in (changes l, l). +Compute isol_rec big_num 3 2 3 (b_coefs 3 2 3 mypol) [::]. +Compute isol_rec big_num 3 0 4 (b_coefs 3 0 4 mypol) [::]. + +Compute isolate 2 4 mypol. + +Time Compute refine 20 0 2 mypol. + +Compute (horner (110139 # 131072) mypol). +Compute (horner (440557 # 524288) mypol). + +(* Polynomial pol2 actually has roots in 1, 2, and 3 *) +Compute isolate 0 4 pol2. + +Compute isolate 0 4 pol3. + +(* When the path of computation touches the roots, they are recognized + as such. *) +Compute isolate 1 3 pol2. + +Compute refine 10 (11#10) 3 pol2. + +Compute ((10000 * 20479 / 10240)%bigZ, (10000 * 10249 / 5120)%bigZ). + +(* Without type information, this gives an error message that looks like a + bug. *) + +Compute clean_divp ((-2)::1::1::nil)%bigQ (4::2::nil)%bigQ. + +Compute let p := ((-2)::1::1::nil)%bigQ in + let d := (2::1::nil)%bigQ in + let (q, r) := divp p d in + (q, r, normalize (addp p (scal (-1) (addp (mulp q d) r)))). + +Compute let p := ((-2)::1::1::nil)%bigQ in + let q := ((-1)::3::(-3)::1::nil)%bigQ in + gcd p q. + +Compute derive ((-1)::3::(-3)::1::nil)%bigQ. + +Compute gcd ((-1)::3::(-3)::1::nil)%bigQ (derive ((-1)::3::(-3)::1::nil)%bigQ). + +Compute clean_divp ((-1)::3::(-3)::1::nil)%bigQ + (1::(-2)::1::nil)%bigQ. + +Time Compute no_square ((-1)::3::(-3)::1::nil)%bigQ. + +(* This is a poor man's correctness proof for the decision procedure, + but it should actually be extended to be used in any real-closed field. *) + +*) diff --git a/theories/math_comp_complements.v b/theories/math_comp_complements.v new file mode 100644 index 0000000..0e11e80 --- /dev/null +++ b/theories/math_comp_complements.v @@ -0,0 +1,346 @@ +From mathcomp Require Import all_ssreflect all_algebra. +Require Export Field. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Require Import NArithRing. +Import Order.TTheory GRing.Theory Num.Theory Num.ExtraDef Num. + +Open Scope ring_scope. + +Definition seq_subst {A : eqType} (l : seq A) (b c : A) : seq A := + map [eta id with b |-> c] l. + +Lemma mem_seq_subst {A : eqType} (l : seq A) b c x : + x \in (seq_subst l b c) -> (x \in l) || (x == c). +Proof. +elim: l => [// | a l Ih]. +rewrite /=. +by case: ifP => [] ?; rewrite !inE=> /orP[ | /Ih /orP[] ] ->; rewrite ?orbT. +Qed. + +(* Using == [::] to express emptyness of a list is only for eqTypes *) +Lemma map_nilp {A B : Type} (f : A -> B) (l : seq A) : + nilp [seq f x | x <- l] = nilp l. +Proof. by case: l. Qed. + +Lemma map_eq0 {A B : eqType} (f : A -> B) (l : seq A) : + ([seq f x | x <- l] == [::]) = (l == [::]). +Proof. by case: l. Qed. + +Lemma seq_subst_eq0 {A : eqType} (l : seq A) b c : + (seq_subst l b c == [::]) = (l == [::]). +Proof. exact: map_eq0. Qed. + +Lemma seq_subst_cat {A : eqType} (l1 l2 : seq A) b c : + seq_subst (l1 ++ l2) b c = seq_subst l1 b c ++ seq_subst l2 b c. +Proof. exact: map_cat. Qed. + +Lemma last_in_not_nil (A : eqType) (e : A) (s : seq A) : +s != [::] -> last e s \in s. +Proof. +case : s => [//= | c q ] /= _. +by rewrite mem_last. +Qed. + +Lemma head_in_not_nil (A : eqType) (e : A) (s : seq A) : +s != [::] -> head e s \in s. +Proof. +case : s => [//= | c q ] /= _. +by rewrite inE eqxx. +Qed. + +Lemma middle_seq_not_nil (A : eqType) (a b c : seq A) : +b != [::] -> +a ++ b ++ c != [::]. +Proof. by rewrite -!nilpE !cat_nilp=> /negbTE ->; rewrite andbF. Qed. + +Lemma rcons_neq0 (A : Type) (z : A) (s : seq A) : (rcons s z) <> nil. +Proof. +by case : s. +Qed. + +Lemma head_rcons (A : Type) (d l : A) (s : seq A) : + head d (rcons s l) = head l s. +Proof. by case: s. Qed. + +Lemma allcons [T : predArgType] + (f : T -> bool) a q' : all f (a :: q') = f a && all f q'. +Proof. by []. Qed. + +Definition cutlast (T : Type) (s : seq T) := +match s with | a :: s => belast a s | [::] => [::] end. + +Lemma last_seq2 (T : Type) (def a : T) (s : seq T) : + s <> nil -> last def (a :: s) = last def s. +Proof. +by case: s => [// | b s] _ /=. +Qed. + +Lemma behead_cutlasteq (T : Type) a (s : seq T) : + (1 < size s)%N -> s = head a s :: rcons (cutlast (behead s)) (last a s). +Proof. +by case: s => [ | b [ | c s]] //= _; congr (_ :: _); rewrite -lastI. +Qed. + +Lemma cutlast_subset (T : eqType) (s : seq T) : {subset cutlast s <= s}. +Proof. +rewrite /cutlast; case: s => [// | a s]. +elim: s a => [ // | b s Ih /=] a e; rewrite inE=> /orP[/eqP -> | ein]. + by rewrite inE eqxx. +by rewrite inE Ih ?orbT. +Qed. + +Lemma behead_subset (T : eqType) (s : seq T) : {subset behead s <= s}. +Proof. by case: s => [ | a s] // e /=; rewrite inE orbC => ->. Qed. + +Lemma sorted_catW (T : Type) (r : rel T) s s' : + (sorted r (s ++ s')) -> sorted r s && sorted r s'. +Proof. +case: s => [// | a s] /=. +by rewrite cat_path => /andP[] ->; apply: path_sorted. +Qed. + +Lemma sorted_rconsE (T : Type) (leT : rel T) s y: + transitive leT -> sorted leT (rcons s y) -> all (leT^~ y) s. +Proof. +move=> tr; elim: s=> [ | init s Ih] //=. +by rewrite (path_sortedE tr) all_rcons => /andP[] /andP[] -> _. +Qed. + +Lemma sorted_last {T : eqType} (r : rel T) (x0 x : T) (s : seq T): + transitive r -> sorted r s -> + x \in s -> (x == last x0 s) || r x (last x0 s). +Proof. +move=> rtr. +case s => [ | a tl] //=. +elim: tl a x => [ | b tl Ih] a x; first by rewrite /= inE => _ ->. +rewrite /= => /andP [rab stl]. +rewrite inE => /orP[/eqP xa | xin]; last by apply: Ih. +apply/orP; right. +move: (Ih b b stl); rewrite inE eqxx => /(_ isT). +move=> /orP[/eqP <- | ]. + by rewrite xa. +apply: rtr; by rewrite xa. +Qed. + +Lemma uniq_map_injective (T T' : eqType) (f : T -> T') (s : seq T) : + uniq [seq f x | x <- s] -> {in s &, injective f}. +Proof. +elim: s => [ // | a s Ih] /= /andP[fan uns]. +move=> e1 e2; rewrite !inE => /orP[/eqP -> | e1s ] /orP[/eqP -> | e2s] feq //. + by move: fan; rewrite feq; case/negP; apply/mapP; exists e2. + by move: fan; rewrite -feq; case/negP; apply/mapP; exists e1. +by apply: Ih. +Qed. + +Lemma mem_seq_split (T : eqType) (x : T) (s : seq T) : + x \in s -> exists s1 s2, s = s1 ++ x :: s2. +Proof. +by move=> /splitPr [s1 s2]; exists s1, s2. +Qed. + +(* TODO : propose for inclusion in math-comp *) +Lemma uniq_index (T : eqType) (x : T) l1 l2 : + uniq (l1 ++ x :: l2) -> index x (l1 ++ x :: l2) = size l1. +Proof. +elim: l1 => [/= | a l1 Ih]; first by rewrite eqxx. +rewrite /= => /andP[]. +case: ifP => [/eqP -> | _ _ /Ih -> //]. +by rewrite mem_cat inE eqxx orbT. +Qed. + +Lemma index_map_in (T1 T2 : eqType) (f : T1 -> T2) (s : seq T1) : + {in s &, injective f} -> + {in s, forall x, index (f x) [seq f i | i <- s] = index x s}. +Proof. +elim: s => [ // | a s Ih] inj x xin /=. +case: ifP => [/eqP/inj| fanfx]. + rewrite inE eqxx; move=> /(_ isT xin) => ->. + by rewrite eqxx. +case: ifP=> [/eqP ax | xna ]; first by rewrite ax eqxx in fanfx. +congr (_.+1). +apply: Ih=> //. + by move=> x1 x2 x1in x2in; apply: inj; rewrite !inE ?x1in ?x2in ?orbT. +by move: xin; rewrite inE eq_sym xna. +Qed. + +Lemma pairwise_subst {T : Type} [leT : rel T] (os ns s1 s2 : seq T) : + pairwise leT (s1 ++ os ++ s2) -> + pairwise leT ns -> + allrel leT s1 ns -> + allrel leT ns s2 -> + pairwise leT (s1 ++ ns ++ s2). +Proof. +rewrite !pairwise_cat !allrel_catr => /andP[] /andP[] _ -> /andP[] ->. +by move=>/andP[] _ /andP[] _ -> -> -> ->. +Qed. + +Lemma pairwise_subst1 {T : eqType} [leT : rel T] (oc nc : T)(s1 s2 : seq T) : + leT nc =1 leT oc -> leT^~ nc =1 leT^~ oc -> + pairwise leT (s1 ++ oc :: s2) = pairwise leT (s1 ++ nc :: s2). +Proof. +move=> l r. +by rewrite !(pairwise_cat, pairwise_cons, allrel_consr) (eq_all l) (eq_all r). +Qed. + +Section transitivity_proof. + +Variables (T : eqType) (r : rel T) (s1 s2 : mem_pred T). + +Hypothesis s1tr : {in s1 & &, transitive r}. +Hypothesis s2tr : {in s2 & &, transitive r}. +Hypothesis s1s2 : {in s1 & s2, forall x y, r x y && ~~ r y x}. + +Lemma two_part_trans : {in predU s1 s2 & &, transitive r}. +Proof. +move=> x2 x1 x3 /orP[x2ins1 | x2ins2] /orP[x1ins1 | x1ins2] + /orP[x3ins1 | x3ins2]; + try solve[move=> ?; apply:s1tr=> // | + move=> ?; apply: s2tr => // | + move=> ? ?; apply: (proj1 (andP (s1s2 _ _))) => //]. +- by move=> r12 r23; move: (s1s2 x2ins1 x1ins2); rewrite r12 andbF. +- by move=> r12 r23; move: (s1s2 x2ins1 x1ins2); rewrite r12 andbF. +- by move=> r12 r23; move: (s1s2 x3ins1 x2ins2); rewrite r23 andbF. +- by move=> r12 r23; move: (s1s2 x3ins1 x2ins2); rewrite r23 andbF. +Qed. + +End transitivity_proof. + +Section abstract_subsets_and_partition. + +Variable cell : eqType. +Variable sub : cell -> cell -> Prop. +Variable exclude : cell -> cell -> Prop. + +Variable close : cell -> cell. + +Hypothesis excludeC : forall c1 c2, exclude c1 c2 -> exclude c2 c1. +Hypothesis exclude_sub : + forall c1 c2 c3, exclude c1 c2 -> sub c3 c1 -> exclude c3 c2. + +Lemma add_map (s1 : pred cell) (s2 : seq cell) : + all (predC s1) s2 -> + {in s2, forall c, sub (close c) c} -> + {in predU s1 (mem s2) &, forall c1 c2, c1 = c2 \/ exclude c1 c2} -> + {in predU s1 (mem [seq close c | c <- s2]) &, + forall c1 c2, c1 = c2 \/ exclude c1 c2}. +Proof. +have symcase : forall (s : pred cell) (s' : seq cell), + all (predC s) s' -> + {in s', forall c, sub (close c) c} -> + {in predU s (mem s') &, forall c1 c2, c1 = c2 \/ exclude c1 c2} -> + forall c1 c2, s c1 -> c2 \in s' -> exclude c1 (close c2). + move=> s s' dif clsub exc c1 c2 sc1 c2s'. + apply/excludeC/(exclude_sub _ (clsub _ _)); last by []. + have := exc c2 c1; rewrite 2!inE c2s' orbT inE sc1 => /(_ isT isT). + by move=> -[abs | //]; have := allP dif _ c2s'; rewrite inE abs sc1. +move=> s1nots2 clsub oldx g1 g2. +rewrite inE => /orP[g1old | /mapP[co1 co1in g1c]]; + rewrite inE => /orP[g2old |/mapP[co2 co2in g2c ]]. +- by apply: oldx; rewrite inE ?g1old ?g2old. +- by right; rewrite g2c; apply: (symcase _ _ s1nots2 clsub oldx). +- by right; rewrite g1c; apply excludeC; apply: (symcase _ _ s1nots2 clsub oldx). +have [/eqP co1co2 | co1nco2] := boolP(co1 == co2). + by left; rewrite g1c g2c co1co2. +right; rewrite g1c; apply/(exclude_sub _ (clsub _ _)); last by []. +rewrite g2c; apply/excludeC/(exclude_sub _ (clsub _ _)); last by []. +have := oldx co2 co1; rewrite !inE co2in co1in !orbT=> /(_ isT isT). +by case=> [abs | //]; case/negP: co1nco2; rewrite abs eqxx. +Qed. + +Lemma add_new (s s2 : pred cell) : + {in s &, forall c1 c2, c1 = c2 \/ exclude c1 c2} -> + {in s & s2, forall c1 c2, exclude c1 c2} -> + {in s2 &, forall c1 c2, c1 = c2 \/ exclude c1 c2} -> + {in predU s s2 &, forall c1 c2, c1 = c2 \/ exclude c1 c2}. +Proof. +move=> oldx bipart newx c1 c2. +rewrite inE=> /orP[c1old | c1new] /orP[c2old | c2new]. +- by apply: oldx. +- by right; apply: bipart. +- by right; apply/excludeC/bipart. +by apply: newx. +Qed. + +End abstract_subsets_and_partition. + +Section subset_tactic. + +Lemma all_sub [T : eqType] [p : pred T] [s1 s2 : seq T] : + {subset s1 <= s2} -> all p s2 -> all p s1. +Proof. by move=> subs as2; apply/allP=> x xin; apply/(allP as2)/subs. Qed. + +Lemma subset_consl [T : eqType] (x : T) (s s': seq T) : + x \in s' -> {subset s <= s'} -> {subset (x :: s) <= s'}. +Proof. +by move=> xin ssub g; rewrite inE=> /orP[/eqP -> // | ]; apply: ssub. +Qed. + +Lemma subset_catl [T : eqType] (s1 s2 s' : seq T) : + {subset s1 <= s'} -> {subset s2 <= s'} -> {subset s1 ++ s2 <= s'}. +Proof. +move=> s1sub s2sub g; rewrite mem_cat=>/orP[];[apply: s1sub | apply s2sub]. +Qed. + +Lemma subset_catrl [T : eqType] [s s1 s2 : seq T] : + {subset s <= s1} -> {subset s <= s1 ++ s2}. +Proof. by move=> ssub g gn; rewrite mem_cat ssub. Qed. + +Lemma subset_catrr [T : eqType] [s s1 s2 : seq T] : + {subset s <= s2} -> {subset s <= s1 ++ s2}. +Proof. by move=> ssub g gn; rewrite mem_cat ssub ?orbT. Qed. + +Lemma subset_id [T : eqType] [s : seq T] : {subset s <= s}. +Proof. by move=> x. Qed. + +Lemma subset_head [T : eqType] [s1 s2 : seq T] [x : T] : + {subset (x :: s1) <= s2} -> head x s1 \in s2. +Proof. +by move=> Sub; apply: Sub; case: s1=> [ | a ?] /=; rewrite !inE eqxx ?orbT. +Qed. + +End subset_tactic. + +Ltac subset_tac := + trivial; + match goal with + | |- {subset ?x <= ?x} => apply: subset_id + | |- {subset (_ :: _) <= _} => apply: subset_consl; subset_tac + | |- {subset (_ ++ _) <= _} => apply: subset_catl; subset_tac + | |- {subset _ <= _ ++ _} => + solve[(apply: subset_catrl; subset_tac)] || + (apply: subset_catrr; subset_tac) + | |- {subset _ <= _} => + let g := fresh "g" in let gin := fresh "gin" in + move=> g gin; rewrite !(mem_cat, inE, cat_rcons); + rewrite ?eqxx ?gin ?orbT //; subset_tac + | |- is_true (?x \in (?x :: _)) => rewrite inE eqxx; done + | |- is_true (head _ (rcons _ _) \in _) => rewrite head_rcons; subset_tac + | |- is_true (head _ _ \in _) => apply: subset_head; subset_tac + | |- is_true (_ \in (_ :: _)) => rewrite inE; apply/orP; right; subset_tac + | |- is_true (_ \in (_ ++ _)) => rewrite mem_cat; apply/orP; + (solve [left; subset_tac] || (right; subset_tac)) + end. + +Section mapi. + +(* TODO: This might be useful one day, because it is used intensively in the + trajectory computation, but not so much in cell decomposition. *) +Definition mapi [T U : Type] (f : T -> Datatypes.nat -> U) (s : seq T) := + map (fun p => f p.1 p.2) (zip s (iota 0 (size s))). + +Lemma nth_mapi [T U : Type] (f : T -> Datatypes.nat -> U) (s : seq T) n d d' : + (n < size s)%N -> + nth d' (mapi f s) n = f (nth d s n) n. +Proof. +rewrite /mapi. +rewrite -[X in f _ X]addn0. +elim: s n 0%N => [ | el s Ih] [ | n] m //=. + rewrite ltnS=> nlt. +by rewrite addSn -addnS; apply: Ih. +Qed. + +End mapi. diff --git a/theories/pol.v b/theories/pol.v new file mode 100644 index 0000000..38d585e --- /dev/null +++ b/theories/pol.v @@ -0,0 +1,1158 @@ +From HB Require Import structures. +From mathcomp Require Import all_ssreflect archimedean. +From mathcomp Require Import ssralg poly ssrnum ssrint rat archimedean polyrcf. +From mathcomp Require Import polyorder polydiv. + +(** * Descartes. + polynomials link with the ssr library *) +(* +Copyright INRIA (20112012) Marelle Team (Jose Grimm; Yves Bertot; Assia Mahboubi). +$Id: pol.v,v 1.35 2012/12/14 11:59:35 grimm Exp $ +*) + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +(* A technical binomial identity for the proof of de Casteljau *) + +Lemma binom_exchange j k q : + 'C(j + k + q, j + k) * 'C(j + k, j) = 'C(k + q, k) * 'C(j + k + q, j). +Proof. +have bin_fact1: forall n m, 'C(n+m,m) * (m`! * n`!) = (n+m)`!. + by move => n m; move: (bin_fact (leq_addl n m)); rewrite addnK. +move: (bin_fact1 (k+q) j) (bin_fact1 q (j+k)). +rewrite (mulnC j`!) (addnC k)(addnC j) - (bin_fact1 q k) - (bin_fact1 k j). +rewrite (mulnAC _ _ j`!) !mulnA - (addnA q) (addnC q) => <-. +move /eqP; rewrite !eqn_pmul2r ? fact_gt0 //;move /eqP ->; apply: mulnC. +Qed. + +Lemma util_C (n i j : nat) : (i <= j) -> (j <= n) -> + ('C(n-i, j-i) * 'C(n, i) = 'C(n, j) * 'C(j, i)). +Proof. +move => ij jn. +move: (binom_exchange i (j - i) (n - j)). +by rewrite (subnKC ij)(subnKC jn) (addnC (j-i)) (addnBA _ ij) (subnK jn). +Qed. + +Import Order.Theory. +Import GRing.Theory. +Import Num.Theory. + +Local Open Scope ring_scope. + +(** ** Properties of ordered fields *) + +Section MoreRealField. + +(** True on characteristic zero *) + +Lemma size_deriv (R:numDomainType) (p: {poly R}): size p^`() = (size p).-1. +Proof. +have [lep1|lt1p] := leqP (size p) 1. + by rewrite {1}[p]size1_polyC // derivC size_poly0 -subn1 (eqnP lep1). +rewrite size_poly_eq // mulrn_eq0 -subn2 -subSn // subn2. +by rewrite lead_coef_eq0 -size_poly_eq0 -(subnKC lt1p). +Qed. + +Variable R : realFieldType. +Implicit Types (x y : R). + +Definition half x := (x / 2%:R). + +Lemma two_unit: (2%:R \is a @GRing.unit R). +Proof. by rewrite unitfE// pnatr_eq0. Qed. + +Lemma half_gt0 x : 0 < x -> 0 < half x. +Proof. by move=> lta; rewrite mulr_gt0 // invr_gt0 ltr0n. Qed. + +Lemma half_ltx x: 0 < x -> half x < x. +Proof. +by move=>lta; rewrite ltr_pdivrMr ?ltr0n // mulr_natr mulr2n ltrDr. +Qed. + +Lemma double_half x : half x + half x = x. +Proof. +by rewrite /half -splitr. +Qed. + +Lemma half_inj (x y : R) : half x = half y -> x = y. +Proof. by move => eq; rewrite - (double_half x) - (double_half y) eq. Qed. + +Lemma half_lin (x y : R) : (half x) + (half y) = half (x + y). +Proof. by rewrite /half mulrDl. Qed. + +Lemma half_lin1 (x y : R) : (half x) - (half y) = half (x - y). +Proof. by rewrite /half mulrBl. Qed. + +Lemma mid_between (a b: R): a < b -> a < half (a + b) < b. +Proof. +move => h. rewrite - half_lin - {1} (double_half a) - {3} (double_half b). +by rewrite ltrD2l ltrD2r ltr_pM2r ?h //invr_gt0 ltr0n. +Qed. + +Lemma maxS (x y: R) (z := (Num.max x y) +1) : (x u < v + 1. + by move=> u v h; rewrite (le_lt_trans h) // ltrDl ltr01. +by rewrite !p1// ?le_max// lexx // orbT. +Qed. + +Lemma pmul2w1 (a b c d : R) : 0 <= a -> 0 <= d -> a <= b -> c <= d -> + a * c <= b * d. +Proof. +move => a0 d0 ab cd. +apply: (le_trans (ler_wpM2l a0 cd)). +by apply: (le_trans (ler_wpM2r d0 ab)). +Qed. + +Lemma inv_comp x y: 0 < x -> 0 < y -> (x < y^-1) = (y < x^-1). +Proof. +move=> xp yp. +rewrite -(ltr_pM2r yp) - [y < _](ltr_pM2l xp). +by rewrite mulVf ?(gt_eqF yp) // mulfV // (gt_eqF xp). +Qed. + +Lemma inv_compr x y: 0 < x -> 0 < y -> (y^-1 < x) = (x^-1 < y). +Proof. +move=> xp yp. +rewrite -(ltr_pM2r yp) - [_ < y](ltr_pM2l xp). +by rewrite mulVf ?(gt_eqF yp) // mulfV // (gt_eqF xp). +Qed. + +End MoreRealField. + +(** ** Big Max on ordered structures *) + +Notation "\max_ ( i <- r | P ) F" := + (\big[Num.max/0%R]_(i <- r | P%B) F%R) : ring_scope. + +Notation "\max_ ( i <- r ) F" := + (\big[Num.max/0%R]_(i <- r) F%R) : ring_scope. +Notation "\max_ ( i < n ) F" := + (\big[Num.max/0%R]_(i < n) F%R) : ring_scope. + +(* NB: ce n'est pas des choses qu'on a dans mathcomp-analysis? *) +Section BigMax. +Variable R : realDomainType. + +Implicit Types (F: R -> R) (s: seq R) (f g : nat -> R). + +Lemma bigmaxr_ge0 s F: 0 <= \max_(i <- s) F i. +Proof. +elim: s; first by rewrite big_nil. +by move=> s IHs Hri0; rewrite big_cons le_max Hri0 orbT. +Qed. + +Lemma bigmaxr_le s F j: + j \in s -> F j <= \max_(i <- s) F i. +Proof. +elim: s; first by rewrite in_nil. +move=> i s IHs Hri0; rewrite big_cons. +case Hi: (j == i); first by rewrite (eqP Hi) le_max lexx. +move: Hri0; rewrite in_cons Hi orFb => ins. +by apply: le_trans (IHs ins) _; rewrite le_max lexx orbT. +Qed. + +Lemma bigmaxr_le0 s F: + \max_(i <- s) F i <= 0 -> forall i, i \in s -> F i <= 0. +Proof. +elim: s; first by move=> _ i;rewrite in_nil. +move=> k s IHs; rewrite big_cons ge_max; case /andP => Fk Hr1 i. +rewrite in_cons; case /orP; [ move /eqP ->; apply: Fk | by apply: IHs]. +Qed. + + +Lemma bigmaxr_gt0 s F: + \max_(i <- s) F i > 0 -> { i | i \in s & F i > 0}. +Proof. +elim :s => [| a l Hrec]; first by rewrite big_nil ltxx. +rewrite big_cons lt_max. +case (ltrP 0 (F a)); first by exists a => //; rewrite in_cons eqxx. +rewrite leNgt => /negbTE ->; rewrite orFb => /Hrec [b bl fp0]. +by exists b => //;rewrite in_cons bl orbT. +Qed. + +Lemma bigmaxr_arg s F: + {j | j \in s & 0 <= F j} -> {j | j \in s & \max_(i <- s) F i = F j}. +Proof. +elim:s; first by case => w ;rewrite in_nil. +move => a l Hrec ew; rewrite big_cons. +case (lerP (\max_(i <- l) F i) (F a)) => cmpm. + by exists a; [ rewrite in_cons eqxx | apply /eqP; rewrite eq_maxl]. +move: (ltW cmpm); rewrite - eq_maxr; move /eqP => ->. +suff aux: { w : R | w \in l & 0 <= F w}. + move: (Hrec aux) => [j jl jm]; exists j =>//; rewrite in_cons jl orbT//. +move: ew => [w]; rewrite in_cons => h1 h2. +case e: (w == a); last first. + exists w => //; move: h1; case /orP => //; rewrite e //. +rewrite (eqP e) in h2; move: (le_lt_trans h2 cmpm) => aux. +by move: (bigmaxr_gt0 aux) =>[j ja jb]; exists j =>//; apply: ltW. +Qed. + +Lemma bigmaxr_lerP s F m: + m >= 0 -> reflect (forall i, i \in s -> F i <= m) (\max_(i <- s) F i <= m). +Proof. +move=> h; apply: (iffP idP) => leFm => [i ir | ]. + by apply: le_trans leFm; apply: bigmaxr_le. +rewrite big_seq_cond; elim /big_ind:_ => //. + by move=> x y xm ym; rewrite ge_max; apply /andP. +by move=> i; rewrite andbT; apply: leFm. +Qed. + +Lemma bigmaxr_arg1 s F j: + j \in s -> 0 <= F j -> (forall i, i \in s -> F i <= F j) -> + \max_(i <- s) F i = F j. +Proof. +move => js fjp; move / (bigmaxr_lerP s F fjp) => le1. +by apply /eqP; rewrite eq_le le1 (bigmaxr_le _ js). +Qed. + +Lemma bigmaxf_nil f: \max_(i< 0) (f i) = 0. +Proof. by rewrite big_ord0. Qed. + +Lemma bigmaxf_rec f n : + \max_(i < n.+1) f i = Num.max (f n) (\max_(i < n) f i). +Proof. +move: f. +elim: n => [ f /=|s Hrec f]; first by rewrite big_ord_recl big_ord0 big_ord0. +symmetry; rewrite big_ord_recl maxCA big_ord_recl. +pose g i := f i.+1. +have aux: forall k, \max_(i < k) f (lift ord0 i) = (\max_(i < k) g i). + move=> k; apply: eq_big => // i. +by rewrite aux aux Hrec. +Qed. + +Lemma bigmaxf_ge0 f n: 0 <= \max_(i < n) f i. +Proof. +elim: n => [| n IHn]; first by rewrite big_ord0. +by rewrite bigmaxf_rec le_max IHn orbT. +Qed. + +Lemma bigmaxf_le f n j: (j < n)%N -> f j <= \max_(i < n) f i. +Proof. +elim: n => [ //| n IHn]; rewrite bigmaxf_rec. +case Hi: (j == n); first by rewrite (eqP Hi) le_max lexx. +rewrite ltnS leq_eqVlt Hi orFb => aux;apply: (le_trans (IHn aux)). +by rewrite le_max lexx orbT. +Qed. + +Lemma bigmaxf_le0 f n: \max_(i < n) f i <= 0 -> + forall i, (i f i <= 0. +Proof. +elim: n => [_ i //| n Hr]; rewrite bigmaxf_rec ge_max; case /andP => Fk H i. +rewrite ltnS leq_eqVlt; case /orP; [ move /eqP ->; apply: Fk | by apply: Hr]. +Qed. + +Lemma bigmaxf_gt0 f n: \max_(i < n ) f i > 0 -> { i | (i 0}. +Proof. +elim :n => [| a IH]; first by rewrite big_ord0 ltxx. +case (ltrP 0 (f a)); first by exists a. +rewrite bigmaxf_rec lt_max leNgt; move /negbTE => ->; rewrite orFb => aux. +by move: (IH aux) => [b bl fp0]; exists b => //; apply:ltn_trans (ltnSn a). +Qed. + +Lemma bigmaxf_arg f n : + {j | (j {j | (j [ [j] // | n Hr Hf]; rewrite bigmaxf_rec. +case (lerP (\max_(i < n) f i) (f n)) => cmpm. + by exists n => //; apply /eqP; rewrite eqr_maxl. +move: (ltW cmpm); rewrite - eq_maxr/=; move /eqP => <-. +suff aux: { j | (j < n)%N & 0 <= f j}. + move: (Hr aux) => [j jl jm]; exists j. + by rewrite ltnS ltnW. + rewrite /Num.max/= jm; case: ifPn => //. + by rewrite -jm cmpm. +move: Hf => [j]; rewrite ltnS leq_eqVlt. +case e: (j == n); last by rewrite orFb; exists j => //. +rewrite (eqP e) => _ h2; move: (le_lt_trans h2 cmpm) => aux. +by move: (bigmaxf_gt0 aux) =>[k ja jb]; exists k =>//; apply: ltW. +Qed. + +Lemma bigmaxf_lerP f n m: + m >= 0 -> reflect (forall i, (i < n)%N -> f i <= m) (\max_(i h; apply: (iffP idP) => leFm => [i ir | ]. + by apply: le_trans leFm; apply: bigmaxf_le. +rewrite big_seq_cond; elim /big_ind:_ => //. + by move=> x y xm ym; rewrite ge_max; apply /andP. +by move=> [i hi] _; apply: leFm. +Qed. + +Lemma bigmaxf_arg1 f n j: + (j < n)%N -> 0 <= f j -> (forall i, (i < n)%N -> f i <= f j) -> + \max_(i < n) f i = f j. +Proof. +move => js fjp; move / (bigmaxf_lerP f n fjp) => le1. +by apply /eqP; rewrite eq_le le1 (bigmaxf_le _ js). +Qed. + +Lemma normr_sumprod f g n : + `| \sum_(i< n) (f i * g i) | + <= (\max_(i< n) `|f i|) * \sum_ (i: \sum_(i < n) `|f i * g i| = \sum_(i < n) `|f i| * `|g i|. + by apply: eq_big => // i; rewrite normrM. +rewrite mulr_sumr; apply: ler_sum => i _; apply: ler_wpM2r. + by rewrite normr_ge0. +by apply: (bigmaxf_le (fun i => `|f i|)). +Qed. + +Lemma normr_sumprod1 f g n b: + 0 <= b -> (forall i, (i `|f i| <= b) -> + `| \sum_(i< n) (f i * g i) | <= b * \sum_ (i b0 h; apply: (le_trans (normr_sumprod f g n)). +apply: ler_wpM2r; first by rewrite sumr_ge0 // => i _; rewrite absr_ge0. +exact /(bigmaxf_lerP (fun z => `|f z|) n b0). +Qed. + +End BigMax. + +(** ** bigops *) + +Section BigOps. +Variables (R : comRingType) (idx : R) (op : Monoid.com_law idx). + +Lemma big_ord_rev (n : nat) (P : nat -> bool) (F : nat -> R): + \big[op/idx]_(i < n | P i) F i = + \big[op/idx]_(i < n | P (n - i.+1)%N) F ( n - i.+1)%N. +Proof. by rewrite -big_mkord big_rev_mkord subn0. Qed. + +Lemma bigop_simpl1 (n m : nat) (F : nat -> R): + (forall j, (m <= j)%N -> F j = idx) -> + \big[op/idx]_(j < n) F j = \big[op/idx]_(j < m | (j < n)%N) F j. +Proof. +set s := (n + m)%N => h. +rewrite (big_ord_widen s F (leq_addr m n)). +rewrite (big_ord_widen_cond s (fun j => (j < n)%N) F (leq_addl n m)). +rewrite (bigID (fun i0:ordinal s => (i0 < m)%N) _ F) /=. +rewrite [X in op _ X] big1 ? Monoid.mulm1 //. +by move => j; rewrite -leqNgt; case/andP => _; by apply: h. +Qed. + +Lemma shorten_sum (f: nat -> R) (n m : nat): + (n <= m)%N -> (forall i, (n <= i < m)%N -> f i = idx) -> + \big[op/idx]_(i < m) f i = \big[op/idx]_(i < n) f i. +Proof. +move => nm fz. +rewrite - (big_mkord xpredT) (big_cat_nat _ _ _ (leq0n n) nm) /= big_mkord. +rewrite [X in (op _ X)]big1_seq ? Monoid.mulm1 // => i; case /andP => _. +by rewrite mem_index_iota; apply: fz. +Qed. + +Lemma big_ord1 (F: 'I_1 -> R) : \big[op/idx]_(i < 1) (F i) = F ord0. +Proof. by rewrite big_ord_recl big_ord0 Monoid.mulm1. Qed. + +End BigOps. + +Section RingPoly. +Variable R : ringType. + +Lemma polyd0 (F: nat -> R): \poly_(i < 0) (F i) = 0. +Proof. +apply /eqP;rewrite - size_poly_eq0; rewrite - leqn0; exact: (size_poly 0 F). +Qed. + +Lemma sum_powers_of_x (n: nat) (x:R): + (x-1) * (\sum_(i < n) x^+ i) = x ^+ n - 1. +Proof. +elim: n => [| n Ihn]. + by rewrite big_ord0 expr0 mulr0 subrr. +rewrite (big_ord_recr n) /= mulrDr Ihn mulrBl mul1r - exprS. +by rewrite addrAC addrCA subrr addr0. +Qed. + +Lemma power_monom (c:R) n : + ('X + c%:P) ^+ n = \poly_(i< n.+1) (c^+(n - i)%N *+ 'C(n, i)). +Proof. +rewrite addrC exprDn_comm; last by apply: commr_polyX. +rewrite poly_def; apply: eq_big => // [[i lin]] _ /=. +by rewrite - mul_polyC - polyC_exp polyCMn mulrnAl. +Qed. + +End RingPoly. + +(** ** Shift and scale *) + +Definition shift_poly (R:ringType) (c:R)(p: {poly R}) := p \Po ('X + c%:P). +Definition scaleX_poly (R:ringType) (c:R)(p: {poly R}) := p \Po ('X * c%:P). + +Notation "p \shift c" := (shift_poly c p) (at level 50) : ring_scope. +Notation "p \scale c" := (scaleX_poly c p) (at level 50) : ring_scope. + +Section ComPoly. +Variable R : comRingType. +Implicit Types (p : {poly R}) (c : R). + +Lemma poly_comp_exp (p r: {poly R}) i: + (p ^+i) \Po r = (p \Po r) ^+ i. +Proof. +elim: i => [| i ihi]; first by rewrite !expr0 comp_polyC. +by rewrite !exprS comp_polyM ihi. +Qed. + +Lemma shift_polyD1 (c1 c2 : R): + ('X + c1%:P) \shift c2 = ('X + (c2 + c1)%:P). +Proof. +by rewrite /shift_poly comp_polyD comp_polyX comp_polyC polyCD addrA. +Qed. + +Lemma shift_polyB1 (c1 c2 : R): + (c1%:P - 'X) \shift c2 = (c1 - c2)%:P -'X. +Proof. +rewrite /shift_poly comp_polyB comp_polyC comp_polyX opprD. +by rewrite - addrCA addrC polyCB. +Qed. + +Lemma shift_polyE c p: + p \shift c = + \poly_(i < size p) \sum_(k < size p) p`_k * c ^+ (k - i) *+ 'C(k, i). +Proof. +rewrite /shift_poly comp_polyE poly_def; symmetry. +transitivity (\sum_(i < size p) + \sum_(k < size p) ((p`_k)%:P * (c ^+ (k - i) *+ 'C(k, i) *: 'X^i))). + apply: eq_big => // [[i ip]] _ /=; rewrite - mul_polyC. + rewrite rmorph_sum big_distrl; apply: eq_big => // [[k kp]] _ /=. + rewrite - mulrnAr polyCM -mul_polyC mulrA //. +rewrite exchange_big; apply: eq_big => // [[i ip]] _ /=. +rewrite -big_distrr - mul_polyC; congr (_ * _). +rewrite power_monom poly_def /=. +have aux: forall j, (i < j < size p)%N ->(c ^+ (i - j) *+ 'C(i, j)) *: 'X^j = 0. + move=> j; case /andP => ij js; rewrite bin_small ?mulr0n ? scale0r//. +by rewrite (shorten_sum _ ip aux). +Qed. + +Lemma horner_shift_poly c p x: (p \shift c).[x] = p.[x + c]. +Proof. by rewrite horner_comp !hornerE. Qed. + +Lemma horner_shift_poly1 c p x : p.[x] = (p \shift c).[x - c]. +Proof. by rewrite horner_shift_poly addrNK. Qed. + +Lemma shift_polyC c a: a%:P \shift c = a%:P. +Proof. by rewrite /shift_poly comp_polyC. Qed. + +Lemma shift_poly_is_linear c: linear (shift_poly c). +Proof. by move=> a u v; rewrite /shift_poly comp_polyD comp_polyZ. Qed. + +Lemma shift_poly_multiplicative c: multiplicative (shift_poly c). +Proof. +split. move=> x y; exact: comp_polyM. by rewrite /shift_poly comp_polyC. +Qed. + +HB.instance Definition _ (c : R) := GRing.isLinear.Build _ _ _ _ _ (shift_poly_is_linear c). + +HB.instance Definition _ c := GRing.isMultiplicative.Build _ _ _ (shift_poly_multiplicative c). + +(*HB.instance Definition _ c := GRing.isLinear.Build _ _ _ _ _ (shift_poly_is_linear c). + +Canonical shift_poly_additive c := Additive (shift_poly_is_linear c). +Canonical shift_poly_linear c := Linear (shift_poly_is_linear c). +Canonical shift_poly_rmorphism c := AddRMorphism (shift_poly_multiplicative c).*) + +Lemma shift_polyD c1 c2 p: + p \shift (c2 + c1) = (p\shift c1) \shift c2. +Proof. by rewrite /shift_poly - comp_polyA - shift_polyD1. Qed. + +Lemma shift_poly_scal a b p : + (a%:P * p) \shift b = a%:P * (p \shift b). +Proof. by rewrite shift_poly_multiplicative shift_polyC. Qed. + +Lemma shift_polyDK c p: + p \shift c \shift -c = p. +Proof. +by rewrite - shift_polyD addrC subrr /shift_poly addr0 comp_polyXr. +Qed. + +Lemma shift_polyX c p i: + ((p^+i) \shift c) = (p \shift c) ^+i. +Proof. by rewrite /shift_poly - poly_comp_exp. Qed. + +Lemma shift_polyXn c i: + ('X^i \shift c) = ('X + c%:P)^+i. +Proof. by rewrite (shift_polyX c 'X i) /shift_poly comp_polyX. Qed. + + +Lemma shift_poly_nth p i c: (i < size p)%N -> + (shift_poly c p)`_i = + \sum_(k < size p) p`_k * c^+(k - i) *+ 'C(k, i). +Proof. by move=> ltis; rewrite shift_polyE coef_poly ltis. Qed. + +Lemma shift_poly_nth1 c p i m: (size p <= m)%N -> + (shift_poly c p)`_i = + \sum_(k < m) p`_k * c^+(k - i) *+ 'C(k, i). +Proof. +move=> ltpm; rewrite shift_polyE coef_poly. +case sip: (i < size p)%N; last first. + rewrite big1 => // [[j jm]] _ /=; case (leqP i j) => ij. + move: sip; case (ltnP i (size p)) => // sip1 _. + by move: (leq_trans sip1 ij) => /(nth_default 0) ->; rewrite mul0r mul0rn. + rewrite bin_small //. +have aux: forall k, (size p <= k < m)%N ->p`_k * c ^+ (k - i) *+ 'C(k, i) = 0. + move=> k; case /andP => ij js; move: ij => /(nth_default 0) ->. + by rewrite mul0r mul0rn. +symmetry;apply: (shorten_sum _ ltpm aux). +Qed. + +(* We give here the coefficients of scale and shift *) +Lemma scaleX_polyE c p: + p \scale c = \poly_(i < size p)(p`_i * c ^+i). +Proof. +rewrite /scaleX_poly comp_polyE poly_def; apply: eq_bigr => i _. +by rewrite -scalerA - exprZn - (mul_polyC c) commr_polyX. +Qed. + +Lemma horner_scaleX_poly c p x : (p \scale c).[x] = p.[c * x]. +Proof. by rewrite horner_comp ! hornerE mulrC. Qed. + +End ComPoly. + +(** ** Reciprocal *) + +Definition reciprocal_pol (R:ringType) (p: {poly R}):= + \poly_(i < size p) p`_(size p - i.+1). + +(* The Bernstein coefficients of polynomial l for the interval (a, b) *) + +Definition recip (R : ringType) (deg : nat) (q : {poly R}) : {poly R} := + 'X ^+ (deg.+1 - size q) * reciprocal_pol q. + +Definition Mobius (R:ringType) (deg : nat) (a b : R) (p: {poly R}) : {poly R} := + recip deg ((p \shift a) \scale (b - a)) \shift 1. + +Lemma reciprocal_Xn (R : idomainType) n : reciprocal_pol ('X^n) = (GRing.one R)%:P. +Proof. +rewrite /reciprocal_pol size_polyXn poly_def big_ord_recl. +rewrite subSS subn0 coefXn expr0 eqxx scale1r big1 ?addr0 // => i _. +rewrite lift0 subSS coefXn /=. +have /negbTE -> : (n - i.+1)%N != n. + by rewrite neq_ltn -(ltn_add2r i.+1) subnK// -addSnnS ltn_addr. +by rewrite -mul_polyC mul0r. +Qed. + +Section ReciprocalPoly. + +Variable (R : idomainType). +Implicit Type p : {poly R}. + +Lemma size_scaleX c p : c != 0 -> size (p \scale c) = size p. +Proof. by move=> cu; rewrite size_comp_poly2 // size_XmulC. Qed. + +Lemma reciprocal_size p: p`_0 != 0 -> size (reciprocal_pol p) = size p. +Proof. +rewrite /reciprocal_pol => td0. +apply: size_poly_eq; rewrite prednK ?subnn // size_poly_gt0. +by apply /eqP => pz; case /eqP:td0; rewrite pz coefC. +Qed. + +Lemma reciprocal_idempotent p: p`_0 != 0 -> + reciprocal_pol (reciprocal_pol p) = p. +Proof. +move=> h;rewrite - polyP {1}/reciprocal_pol (reciprocal_size h) => i. +rewrite coef_poly /reciprocal_pol coef_poly. +case: (ltnP i (size p)); last by move => /(nth_default 0). +move => isp; rewrite - (subnKC isp). +by rewrite -subn_gt0 addSn addnC -addnS addnK addKn addnS addnC -addnS addnK. +Qed. + +Lemma size_poly_coef_eq0 : + forall p q : {poly R}, (forall i, (p`_i == 0) = (q`_i == 0)) -> + size p = size q. +Proof. +by move=> p q c; apply/eqP; rewrite eqn_leq;apply/andP; split; + apply/leq_sizeP => j cj; apply/eqP; (rewrite c || rewrite -c); + apply/eqP; move: j cj; apply/leq_sizeP. +Qed. + +(* +Lemma reciprocal_pol_scale_swap : + forall p (c : R), c!= 0 -> p`_0 != 0 -> + reciprocal_pol (p \scale c) = (c ^ (size p).-1)%:P + * (reciprocal_pol p \scale c^-1). +Proof. +(* Without the condition on the first coefficient. +move=> p c cu (* p0 *); rewrite [_ \scale c^-1]/scaleX_poly comp_polyE. +rewrite [_ (_ \scale _)]/reciprocal_pol poly_def size_scaleX //. +have t : (size (reciprocal_pol p) <= size p)%N by apply: size_poly. +rewrite (big_ord_widen _ + (fun i : nat => (reciprocal_pol p)`_i *: ('X * (c^-1)%:P) ^+ i) t). +rewrite (big_mkcond (fun i : 'I_(size p) => (i < _)%N)) big_distrr /=. +apply: eq_bigr; move => [i ci] _ /=. +Search _ nth (_ \scale _). +rewrite scaleX_polyE coef_poly. +have -> : (size p - i.+1 < size p)%N. + move: ci; case h : (size p) => [ | n]; first by rewrite ltn0. + by move=> _; rewrite subSS (leq_ltn_trans _ (ltnSn _)) // leq_subr. +case t' : (i < size (reciprocal_pol p))%N; last first. +*) +rewrite reciprocal_size /reciprocal_pol // size_scaleX // poly_def. +rewrite big_distrr; apply eq_bigr => i _. +rewrite exprMn_comm; last by apply: mulrC. +rewrite coef_poly ltn_ord scaleX_polyE coef_poly /=. +have -> : (size p - i.+1 < size p)%N. + case h' : (size p) i => [ | n] i' //; first by case i'. + by rewrite (leq_ltn_trans _ (ltnSn n)) // subSS // leq_subr. +rewrite -polyC_exp (mulrC 'X^i) !mul_polyC !scalerA; congr (_ *: _). +rewrite mulrAC exprVn -exprnP mulrC; congr (_ * _). +case: i => i ci /=. +case h : (size p == i.+1). + by rewrite (eqP h) subnn expr0 /= mulfV // expf_eq0 (negbTE cu) andbF. +case: (size p) ci h => //= n in1 dif; rewrite subSS expfB //. +by move: in1; rewrite leq_eqVlt eq_sym dif orFb ltnS. +Qed. +*) + +Lemma horner_reciprocal p x : + x \is a GRing.unit -> (reciprocal_pol p).[x] = x ^+ (size p - 1) * p.[x^-1]. +Proof. +move=> xn0; rewrite /reciprocal_pol horner_poly. +case sp : (size p) => [| n]. + rewrite sub0n expr0 mul1r big_ord0; move/eqP: sp; rewrite size_poly_eq0. + by move/eqP->; rewrite horner0. +rewrite horner_coef subn1 /= big_distrr /=. +pose f (j : 'I_n.+1) := Ordinal (leq_subr j n:n - j < n.+1)%N. +have finv: forall j:'I_n.+1, xpredT j -> f (f j) = j. + by move => j _; apply: val_inj => /=; rewrite subKn //; have : (j < n.+1)%N. +rewrite (reindex_onto f f finv) /=. +have tmp :(fun j => f (f j) == j) =1 xpredT. + by move=> j /=; apply/eqP; apply finv. +rewrite (eq_bigl _ _ tmp) {tmp} sp; apply: eq_bigr => [[j hj]] _ /=. +rewrite subSS subKn // -mulrCA; congr (_ * _). +rewrite ltnS in hj; rewrite - {2}(subnK hj) exprD -mulrA exprVn. +by rewrite divrr ? mulr1 // unitrX. +Qed. + +Lemma horner_reciprocal1 p x : + x \is a GRing.unit -> p.[x] = x ^+ (size p - 1) * (reciprocal_pol p).[x^-1]. +Proof. +move=> xz; rewrite horner_reciprocal ?unitrV //. +by rewrite mulrA invrK - exprMn divrr // expr1n mul1r. +Qed. + +Lemma reciprocal_monom (a b: R): a != 0 -> + reciprocal_pol ('X * a%:P + b%:P) = ('X * b%:P + a%:P). +Proof. +move=> /negbTE h; rewrite /reciprocal_pol. +have ->: size ('X * a%:P + b%:P) = 2%N. + by rewrite - commr_polyX size_MXaddC size_polyC polyC_eq0 h. +apply/polyP=> i. +rewrite coef_poly !coefD !coefMC !coefC !coefX. +case :i; first by rewrite mul1r mul0r add0r addr0. +case; first by rewrite mul1r mul0r add0r addr0. +by move=> n /=; rewrite mul0r add0r. +Qed. + +Lemma reciprocalC (c : R) : reciprocal_pol c%:P = c%:P. +Proof. +rewrite /reciprocal_pol - polyP => i; rewrite coef_poly. +case cz: (c==0); first by move /eqP in cz; rewrite cz !coef0 if_same. +rewrite size_polyC cz !coefC; case:i => [| i]//. +Qed. + +Lemma reciprocalM p q : + reciprocal_pol (p * q) = reciprocal_pol p * reciprocal_pol q. +Proof. +move: (reciprocalC 0) => aux. +case (poly0Vpos p); first by move => ->; rewrite mul0r aux mul0r. +case (poly0Vpos q); first by move => -> _; rewrite mulr0 aux mulr0. +set m:= (size p + size q).-1; move=> pa pb. +have mp: (size p + size q)%N = m .+1. + by symmetry;rewrite /m prednK // addn_gt0 pa pb. +have qa: (size p <= m)%N by rewrite /m - (prednK pa) addnS leq_addr. +have qb: (size q <= m)%N by rewrite /m addnC - (prednK pb) addnS leq_addr. +have pnz: p != 0 by rewrite - size_poly_eq0 - lt0n. +have qnz: q != 0 by rewrite - size_poly_eq0 - lt0n. +rewrite /reciprocal_pol size_mul //. +rewrite - polyP => i; rewrite coef_poly coefM coefM. +case: (ltnP i (size p + size q).-1) => ipq; last first. + rewrite big1 // => [] [] j ij _ /=; rewrite ! coef_poly. + case lt1: (j < size p)%N; last by rewrite mul0r. + case lt2: (i - j < size q)%N; last by rewrite mulr0. + move: (leq_add lt1 lt2). + by rewrite addnS addSn mp ltnS subnKC ? ltnS // ltnNge ipq. +set mi:= ((size p + size q).-1 - i.+1)%N. +pose f j := (p`_j * q`_(mi - j)). +have aux1: forall j, (size p <=j) %N -> f j = 0. + by move=> j; rewrite /f; move => /(nth_default 0) => ->; rewrite mul0r. +rewrite (bigop_simpl1 _ mi.+1 aux1). +pose g1 j := (\poly_(i0 < size p) p`_(size p - i0.+1))`_j. +pose g2 j := (\poly_(i0 < size q) q`_(size q - i0.+1))`_j. +pose g j := g1 j * g2 (i - j)%N. +have aux2: forall j : nat, (size p <= j)%N -> g j = 0. + by move => j; rewrite /g/g1 coef_poly ltnNge; move => ->; rewrite mul0r. +rewrite (bigop_simpl1 _ i.+1 aux2). +transitivity (\sum_(j < size p | (j < i.+1)%N) + p`_(size p - j.+1) * g2 (i - j)%N); last first. + by apply: eq_big => // [[j ji]] _ /=; rewrite /g/g1 coef_poly ji. +symmetry; rewrite (big_ord_rev _ (size p) (fun j => (j < i.+1)%N) + (fun j => p`_(size p - j.+1) * g2 (i - j)%N)) /=. +rewrite big_mkcond [X in _ = X] big_mkcond; apply: eq_bigr => [[k kp]] _ /=. +case Ha: ((size p - k.+1) < i.+1)%N; last first. + case Hb: (k < mi.+1)%N => //; rewrite /f. + suff:(size q <= (mi - k))%N by move => /(nth_default 0) => ->; rewrite mulr0. + rewrite ltnS in Hb; rewrite -(leq_add2l k) (subnKC Hb) -(leq_add2l i.+1). + rewrite (subnKC ipq) addSn addnA -ltnS mp /= -mp -addSn -addSn leq_add2r. + by rewrite -addnS -(subnK kp) -addSn leq_add2r ltnNge -ltnS Ha. +rewrite (subnSK kp) (subKn (ltnW kp)) (subnBA _ kp) - addSnnS. +move: Ha; rewrite ltnS leq_subLR addSnnS addnC => Ha. +have ->: (k < mi.+1)%N = (i.+1 + k <= m)%N. + by rewrite /mi ltnS - (leq_add2l (i.+1)) (subnKC ipq) mp. +rewrite /g2 coef_poly; case Hb: (i.+1 + k <= m)%N; last first. + suff: ~~(i.+1 + k - size p < size q)%N by move /negbTE => ->;rewrite mulr0. + by rewrite -ltnNge ltnS - (leq_add2l (size p)) (subnKC Ha) mp ltnNge Hb. +rewrite /f - (ltn_add2l (size p)) (subnKC Ha) mp ltnS Hb; congr (_ * (q`_ _)). +apply /eqP; rewrite - (eqn_add2r (i.+1 + k)%N)- subnDA (subnK Hb). +have m1: m = (size p + (size q).-1)%N by rewrite /m -(ltn_predK pa) addnS. +rewrite addnC -(ltn_predK pa) subSS - {1} (subnK Ha) (addnC _ (size p)). +by rewrite - addnA m1 subnKC // leq_subLR - m1. +Qed. + +Lemma reciprocal_Xn_root0 (p : {poly R}) : + reciprocal_pol p = reciprocal_pol (p %/ 'X^(\mu_0 p)). +Proof. +rewrite -(addr0 'X) -oppr0. +have Hmu0 := root_mu p 0. +rewrite Pdiv.IdomainMonic.dvdp_eq in Hmu0; last first. + by rewrite monic_exp// monicXsubC. +by rewrite {1}(eqP Hmu0) reciprocalM {2}oppr0 addr0 reciprocal_Xn + polyC1 mulr1 polyC0. +Qed. + +Lemma reciprocalX p n : reciprocal_pol (p ^+ n) = (reciprocal_pol p) ^+ n. +Proof. +elim: n=> [| n Hrec]; first rewrite !expr0 reciprocalC //. +by rewrite ! exprS reciprocalM Hrec. +Qed. + +Lemma pdivmu0_0th_neq0 (p : {poly R}) : p != 0 -> (p %/ 'X^(\mu_0 p))`_0 != 0. +Proof. +move=> Hp. +have H0noroot : ~~(root (p %/ 'X^(\mu_0 p)) 0). + rewrite -mu_gt0. + rewrite -eqn0Ngt -(addr0 'X) -(@oppr0 {poly R}) -polyC0 mu_div + ?subn_eq0; by rewrite leqnn. + rewrite Pdiv.CommonIdomain.divp_eq0 negb_or Hp /= negb_or. + rewrite -size_poly_gt0 {1}size_polyXn /= -leqNgt dvdp_leq //. + by rewrite -(addr0 'X) -oppr0 -polyC0 root_mu. +rewrite -horner_coef0. apply: negbT. +by move/rootPf : H0noroot. +Qed. + +Lemma reciprocal_reciprocal (p : {poly R}) : + reciprocal_pol (reciprocal_pol p) = p %/ ('X^(\mu_0 p)). +Proof. +case Hp0 : (p == 0). + move/eqP : Hp0 => ->. + by rewrite !reciprocalC div0p polyC0. +rewrite (@reciprocal_Xn_root0 p) reciprocal_idempotent //. +apply: pdivmu0_0th_neq0. +by apply: negbT. +Qed. + +Lemma reciprocal0 (p : {poly R}) : (reciprocal_pol p == 0) = (p == 0). +Proof. +apply/idP/idP => Hp. + have H : (p %/ ('X^(\mu_0 p)) == 0). + by rewrite -reciprocal_reciprocal -polyC0 -reciprocalC (eqP Hp). + rewrite Pdiv.CommonIdomain.divp_eq0 in H. + move/orP : H; case => [| /orP [] H] //. + by rewrite -size_poly_eq0 size_polyXn -(Bool.negb_involutive (_.+1 == 0%N)) + -lt0n /= in H. + have H2 := (root_mu p 0). + case Hp0 : (p == 0) => //. + rewrite gtNdvdp // in H2. + by apply: negbT. + by rewrite oppr0 addr0. +by rewrite (eqP Hp) -polyC0 reciprocalC. +Qed. + +(* +Lemma reciprocal_nth : forall (p : {poly R}) k, (k < size p)%N -> + (reciprocal_pol p)`_k = p`_((size p) - k.+1). +Proof. +move=> p k Hk. +by rewrite /reciprocal_pol coef_poly Hk. +Qed. +*) + +Lemma reciprocal_nth_2 (p : {poly R}) k : (k < size p)%N -> + (reciprocal_pol p)`_(size p - k.+1) = p`_k. +Proof. +move=> Hk. +rewrite /reciprocal_pol coef_poly. +have Hk2 : (size p - k.+1 < size p)%N. + by rewrite -(ltn_add2r k.+1) subnK // -addSnnS ltn_addr. +rewrite Hk2 !subnS -!subn1 !subnBA; last by rewrite subn_gt0. + by rewrite addn1 -subnDA addn1 addnC addnK. +exact: ltnW. +Qed. + +Lemma reciprocal_eq (p q : {poly R}) : p`_0 != 0 -> q`_0 != 0 -> + (p == q) = (reciprocal_pol p == reciprocal_pol q). +Proof. +move=> p0 q0; apply/idP/idP => [/eqP ->//|/eqP pq]. +apply/eqP/poly_inj. +have Hsize : size p = size q. + by rewrite -reciprocal_size // -(@reciprocal_size q) // pq. +apply: (@eq_from_nth _ 0) => // i ip. +rewrite -reciprocal_nth_2// -(@reciprocal_nth_2 q) //. + by rewrite pq Hsize. +by rewrite -Hsize. +Qed. + +End ReciprocalPoly. + +(** ** Cauchy bound *) + +Section CauchyBound. + +Variable F : realFieldType. + +Variables (n : nat) (E : nat -> F) (x : F). +Hypothesis pnz : E n != 0. +Hypothesis xr: root (\poly_(i < n.+1) E i) x. + +Lemma CauchyBound_aux : x^+n = - \sum_(i < n) ((E i / E n) * x^+ i). +Proof. +move: xr; move /rootP => xr1. +have ->: \sum_(i < n) E i / E n * x ^+ i = \sum_(i < n) (E i * x ^+ i / E n). + by apply: eq_bigr => i _ ; rewrite mulrAC. +rewrite -(mulfK pnz (x ^+ n)); apply /eqP; rewrite -addr_eq0 - mulr_suml. +rewrite - mulrDl mulf_eq0 -{2} xr1; apply /orP; left. +by rewrite horner_poly (big_ord_recr n) //= addrC mulrC. +Qed. + + +Lemma CauchyBound1 : `| x | <= 1 + \max_(i < n) (`|E i / E n|). +Proof. +move: (bigmaxf_ge0 (fun i => `|E i / E n|) n) => cp. +case: (lerP `|x| 1)=> cx1; first by rewrite ler_wpDr //. +rewrite addrC -lerBlDr. +move: (normr_sumprod (fun i => E i / E n) (fun i => x ^+ i) n). +move: CauchyBound_aux => eq; move: (f_equal (fun z => `| z |) eq). +rewrite normrN; move => <-; +have ->: \sum_(i < n) `|x ^+ i| = (\sum_(i < n) `|x| ^+ i). + by apply: eq_big => // i _; rewrite normrX. +move: cp. +case:n => [| m]; first by rewrite big_ord0 mulr0 expr0 normr1 ler10. +move: (sum_powers_of_x (m.+1) `|x|); set aux:= (\sum_(i < m.+1) _) => pa. +set c := \max_(i < m.+1) `|E i / E m.+1| => cp r1. +have a1p: 0 < `|x| - 1 by rewrite subr_gt0. +have r2 : c* aux <= c* ( (`|x| ^+ m.+1) /(`|x| - 1)). + by rewrite (ler_wpM2l cp) // ler_pdivlMr // mulrC pa gerDl lerN10. +move: (le_trans r1 r2); rewrite mulrA ler_pdivlMr // mulrC. +rewrite normrX ler_pM2r //. +by apply:(lt_trans ltr01); rewrite exprn_egt1. +Qed. + +Lemma CauchyBound2 : `| x | <= \sum_(i < n.+1) `|E i / E n|. +Proof. +case: (lerP `|x| 1)=> cx1. + apply: (le_trans cx1). + rewrite big_ord_recr /= divff // normr1 lerDr. + rewrite sumr_ge0 // => i _; rewrite absr_ge0 //. +move: (CauchyBound_aux). +case e: n=> [| m]. + by rewrite expr0 big_ord0 oppr0; move /eqP; rewrite oner_eq0. +case x0 : (x == 0). + by move: cx1; rewrite (eqP x0) normr0 ltr10. +have xmn0 : (x^+m != 0) by rewrite expf_eq0 x0 andbF. +move => h1; have h2 : x = - \sum_(i < m.+1) ( x^-(m - i) *(E i / E m.+1)). + apply: (mulIf xmn0); rewrite mulNr big_distrl /= -exprS h1; congr (- _). + apply: congr_big; [by [] | by [] |] => [[i hi]] _ /=. + have mi : m = (m - i + i)%N by rewrite subnK //. + by rewrite (mulrC (x ^-(m -i)) _) {4} mi exprD -!mulrA mulKf // + expf_eq0 x0 andbF. +rewrite (f_equal (fun z => `| z |) h2) normrN. +apply: le_trans (_: (\sum_(i < m.+1) `|E i / E m.+1|) <= _); last first. + by rewrite (big_ord_recr m.+1) /= lerDl normr_ge0. +have pa: (forall i, (i `| x ^- (m - i) | <= 1). + move => i lin. + have pa: 0 < `|x ^+ (m - i)| by rewrite normr_gt0 expf_eq0 x0 andbF. + rewrite normrV. + rewrite invr_le1 //; last by apply: unitf_gt0. + rewrite normrX; apply:exprn_ege1; exact (ltW cx1). + by apply: unitrX; rewrite unitfE x0. +rewrite - [\sum_(i < m.+1) `|E i / E m.+1| ] mul1r. +exact :(normr_sumprod1 (fun i => E i / E m.+1) ler01 pa). +Qed. + +Lemma CauchyBound : `| x | <= `|E n|^-1 * \sum_(i < n.+1) `|E i|. +Proof. +move: (CauchyBound2). rewrite big_distrr /=. +have -> //: \sum_(i < n.+1) `|E i / E n| = \sum_(i < n.+1) (`|E n|^-1 * `|E i|). +by apply: eq_bigr => i _ ; rewrite normrM normrV ? unitfE // mulrC. +Qed. + +End CauchyBound. + +(** ** Continuity *) + + +Section PolsOnOrderedField. + +Variable R : realFieldType. + +Definition norm_pol (p : {poly R}) := map_poly (fun x => `|x|) p. + +Lemma pow_monotone n (x y : R) : 0 <= x <= y -> 0 <= x ^+ n <= y ^+ n. +Proof. +move => /andP [xp xy]. +by rewrite lerXn2r// ?andbT ?exprn_ge0// nnegrE (le_trans _ xy). +Qed. + +Lemma diff_xn_ub n (z x y: R): -z <= x -> x <= y -> y <= z -> + `| y ^+ n - x ^+ n| <= (z^+(n.-1) *+ n) * (y - x). +Proof. +move => zx xy yz. +rewrite subrXX mulrC normrM [`|_ - _|]ger0_norm ?ler_wpM2r // ?subr_ge0 //. +apply: (le_trans (ler_norm_sum _ _ _)). +rewrite - [n in _*+ n] card_ord - sumr_const ler_sum // => [][i lin] _. +rewrite normrM !normrX. +have l1: 0<=`|x| <=z by rewrite normr_ge0 /= ler_norml zx /= (le_trans xy yz). +have l2: 0<=`|y| <=z by rewrite normr_ge0 /= ler_norml yz /= (le_trans zx xy). +have /andP [pa pb] := pow_monotone i l1. +have /andP [pc pd] := pow_monotone (n.-1 - i)%N l2. +by move: (ler_pM pc pa pd pb); rewrite - exprD subnK //; move: lin; case n. +Qed. + +Lemma pol_lip p (z x y: R): -z <= x -> x <= y -> y <= z -> + `|(p.[y] - p.[x])| <= (norm_pol p^`()).[z] * (y - x). +Proof. +move => zx xy yz. +rewrite horner_poly !horner_coef - sumrB. +apply: (@le_trans _ _ (\sum_(i: aux = ((\sum_(i ->; rewrite deriv0 size_poly0 !big_ord0. + move => s1; rewrite - (prednK s1) size_deriv big_ord_recl mulr0n mulr0 add0r. + apply: eq_bigr => i _; rewrite coef_deriv normrMn mulrnAl mulrnAr //. +rewrite big_distrl /= ler_sum // => i _;rewrite - mulrBr normrM -mulrA. +apply: (ler_wpM2l (normr_ge0 p`_i)); exact: (diff_xn_ub i zx xy yz). +Qed. + +Lemma pol_ucont (p : {poly R}) a b (c := (norm_pol p^`()).[(Num.max (- a) b)]) : + forall x y, a <= x -> x <= y -> y <= b -> `|p.[y] - p.[x]| <= c * (y - x). +Proof. +move => x y ax xy yb. +apply: pol_lip => //. +apply: (le_trans _ ax); by rewrite lerNl le_max lexx. +apply: (le_trans yb); by rewrite le_max lexx orbT. +Qed. + +Lemma pol_cont (p : {poly R}) (x eps :R): 0 < eps -> + { delta | 0 < delta & forall y, `|(y - x)| < delta -> + `|p.[y] - p.[x]| < eps }. +Proof. +move => ep. +move: (pol_ucont p (a:= x-1)(b:=x+1)); set c := _ .[_ ] => /= hc. +have pa: x-1 <= x by move: (lerD2l x (-1) 0); rewrite addr0 lerN10. +have pb: x <= x+1 by move: (lerD2l x 0 1); rewrite ler01 addr0. +have cp: 0<=c. + move: (hc _ _ pa pb (lexx (x+1))). + by rewrite addrAC addrN add0r mulr1; apply: le_trans; rewrite normr_ge0. +exists (Num.min 1 (eps /(c+1))). + rewrite lt_min ltr01 /= divr_gt0 // ? ep //. + by apply: (lt_le_trans ltr01); move: (lerD2r 1 0 c); rewrite add0r cp. +move => y. +rewrite lt_min; case /andP => xy1 xy2. +apply: (@le_lt_trans _ _ (c * `|(y - x)|)); last first. + move: cp; rewrite le0r; case /orP; first by move /eqP => ->; rewrite mul0r. + move => cp. + rewrite -(ltr_pM2l cp) in xy2; apply: (lt_le_trans xy2). + rewrite mulrCA ger_pMr //. + have c1: c <= c + 1 by move: (lerD2l c 0 1); rewrite ler01 addr0. + have c1p := (lt_le_trans cp c1). + by rewrite -(ler_pM2r c1p) mulfVK ? (gt_eqF c1p) // mul1r. +move: (ltW xy1); rewrite ler_distl;case /andP => le1 le2. +case /orP: (le_total x y) => xy. + move: (xy); rewrite - subr_ge0 => xy'. + move: (hc _ _ pa xy le2). + rewrite subr_ge0. + rewrite -subr_ge0 in xy'. + by rewrite (ger0_norm xy'). +move: (xy); rewrite - subr_ge0 => xy'. +move: (hc _ _ le1 xy pb); rewrite distrC (distrC y x). +rewrite subr_ge0. +rewrite -subr_ge0 in xy'. +by rewrite (ger0_norm xy'). +Qed. + +End PolsOnOrderedField. + +Section PolsOnArchiField. + +(** ** Constructive Intermediate value Theorem *) + +Variable R : archiFieldType. +(** We want to prove a simple and contructive approximation of the + middle value theorem: if a polynomial is negative in a and positive in b, + and a < b, then for any positive epsilon, there exists c and d, so that + a <= c < d <= b, the polynomial is negative in c and positive in d, + and the variation between c and d is less than epsilon. + Note: we also add: the distance between c and d is small. +*) + +Definition pol_next_approx (p : {poly R}) (ab : R * R) := + let: (a,b) := ab in let c :=half(a+b) in + if (p.[a] * p.[c] <= 0) then (a,c) else (c,b). + +Fixpoint pol_approx (p : {poly R}) (ab : R * R) (n:nat) := + if n is m.+1 then pol_next_approx p (pol_approx p ab m) else ab. + +Definition pair_in_interval (a x y b : R) := [&& a <= x, x < y & y <= b]. + +Lemma pol_approx_prop (p : {poly R}) (a b: R) n: + p.[a] < 0 -> 0 <= p.[b] -> a < b -> + let:(u,v) := (pol_approx p (a,b) n) in + [&& (v-u) == (b-a) / (2%:R ^+ n), pair_in_interval a u v b, + p.[u] < 0 & 0 <= p.[v] ]. +Proof. +move => pan pbp lab. +elim:n;first by rewrite /= expr0 divr1 eqxx /pair_in_interval pan pbp lab !lexx. +move => n /=; case (pol_approx p (a,b) n) => u v /and4P [/eqP d1 pi pun pvp]. +have aux: half ((b - a) / 2%:R ^+ n) == (b - a) / 2%:R ^+ n.+1. + by rewrite /half exprS -mulrA - invrM // ? unitrX ? two_unit. +rewrite /pol_next_approx /pair_in_interval;case /and3P: pi => [au uv vb]. +case cp:(p.[u] * p.[half (u + v)] <= 0). + case /andP: (mid_between uv) => [h1 h2]. + rewrite -{2}(double_half u) half_lin half_lin1 opprD. + rewrite addrA {1} (addrC u) addrK d1 aux pun - (nmulr_rle0 _ pun) cp. + by rewrite au h1 (ltW (lt_le_trans h2 vb)). +case /andP: (mid_between uv) => [h1 h2]. +rewrite -{1}(double_half v) half_lin half_lin1 opprD - addrA (addrA _ (-u)). +rewrite (addrC _ (-u)) addrK d1 aux pvp h2 vb (ltW (le_lt_trans au h1)). +by rewrite -(nmulr_rgt0 _ pun) ltNge cp. +Qed. + +Lemma constructive_ivt (p : {poly R}) (a b : R) (eps : R) : + a < b -> p.[a] < 0 -> 0 <= p.[b] -> 0 < eps -> + { xy | let:(u,v):= xy in + [&& pair_in_interval (- eps) (p.[u]) (p.[v]) eps, + (pair_in_interval a u v b), + (p.[u] < 0), (0 <= p.[v]) & (v - u) <= eps] }. +Proof. +move=> ab nla plb ep. +move: (pol_ucont p (a:=a) (b:= b)); set c1 := _ .[_ ] => /= pc. +set c := Num.max 1 c1. +have lc1: 1 <= c by rewrite le_max lexx. +have cpos:= (lt_le_trans ltr01 lc1). +set k := Num.bound ((b - a) * c / eps). +move: (upper_nthrootP(leqnn k)) => hh. +exists (pol_approx p (a, b) k); move: (pol_approx_prop k nla plb ab). +case:(pol_approx p (a, b) k) => u v /and4P [/eqP pa eq1 pun pvp]. +case/and3P: (eq1) => [ha hb hc]. +have c2p: 0 < v-u by rewrite subr_gt0. +have hh1: (v-u) * c < eps. + rewrite pa;set x := (X in _ / X). + have xp: 0 < x by rewrite exprn_gt0 // ltr0n. + rewrite mulrAC -(ltr_pM2r xp) (mulrVK (unitf_gt0 xp)). + move: hh. + rewrite -/x. + by rewrite ltr_pdivrMr// (mulrC _ x). +have hh2 : v-u < eps. + by apply: le_lt_trans hh1; rewrite - {1} (mulr1 (v-u)) (ler_pM2l c2p). +have dvp: p.[u] < p.[v] by apply (lt_le_trans pun pvp). +have hh5: p.[v] - p.[u] <= eps. + move: (pc _ _ ha (ltW hb) hc);rewrite gtr0_norm ? subr_gt0 // mulrC => hh4. + apply:(le_trans _ (ltW hh1)); apply: (le_trans hh4). + rewrite (ler_pM2l c2p) le_max lexx orbT //. +rewrite eq1 /pair_in_interval pun pvp dvp (ltW hh2) lerNl. +rewrite (le_trans _ hh5) ?(le_trans _ hh5) //. + by rewrite -{1} (addr0 p.[v]) lerD2l oppr_ge0 ltW. +by rewrite -{1} (add0r (- p.[u])) lerD2r. +Qed. + +Lemma constructive_ivt_bis (p : {poly R})(a b : R) (eps: R): + a < b -> p.[a] < 0 -> 0 <= p.[b] -> 0 < eps -> + { xy | + (- eps <= p.[xy.1]) && (p.[xy.1] < 0) && (0 <= p.[xy.2]) && + (p.[xy.2] <= eps) && (a <= xy.1) && (xy.1 < xy.2) && (xy.2 <= b) }. +Proof. +move=> ab nla plb ep. +move:(constructive_ivt ab nla plb ep) => [xy etc]. +exists xy. +set u := xy.1; set v := xy.2; move: etc. +have ->: xy = (u,v) by rewrite /u /v; case xy. +by case/and5P => [/and3P[-> _ ->] /and3P[-> -> ->] -> -> _]. +Qed. + +Lemma constructive_ivt_ter (p : {poly R})(a b : R) (eps: R): + a < b -> p.[a] < 0 -> 0 <= p.[b] -> 0 < eps -> + { xy | + (- eps <= p.[xy.1]) && (p.[xy.1] < 0) && (0 <= p.[xy.2]) && + (p.[xy.2] <= eps) && (a <= xy.1) && (xy.1 < xy.2) && (xy.2 <= b) }. +Proof. +move=> ab nla plb ep. +have ba' : 0 < b - a by rewrite -(addrN a) ltrD2r. +have evalba : 0 < p.[b] - p.[a] by rewrite subr_gt0; exact: lt_le_trans plb. +move: (pol_ucont p (a:=a) (b:= b)). +set c := _ .[_ ] => /= pc. +have cpos : 0 < c. + rewrite - (ltr_pM2r ba') mul0r. + by apply: lt_le_trans (pc a b _ _ _) => //; rewrite ? ger0_norm // ltW. +have pdiv : (0 < (b - a) * c / eps) by rewrite ltr_pdivlMr // mul0r mulr_gt0. +move: (archi_boundP (ltW pdiv)); set n := Num.bound _ => qn. +have fact1 : (0 : R) < n%:R by exact: lt_trans qn => /=. +case: n qn fact1 => [|n]; rewrite ?ltxx // => qn _. +pose sl := map (fun x => a + (b - a) * (x%:R / (n.+1%:R))) (iota 0 n.+2). +pose a'_index := find (fun x => p.[x] >= 0) sl. +have has_sl : has (fun x => p.[x] >= 0) sl. + rewrite has_map; apply/hasP; exists n.+1. + by rewrite mem_iota add0n ltnSn ltnW. + by rewrite /= divff ? pnatr_eq0 // mulr1 addrCA subrr addr0. +case: {2}a'_index (refl_equal a'_index) => [|ia']. + rewrite /a'_index => ha'; have:= (nth_find 1 has_sl); rewrite ha' /=. + by rewrite mul0r mulr0 addr0 leNgt nla. +set b':= sl`_ia'.+1; set a' := sl`_ia'. +move=> ha'; exists (a', b'); simpl. +have ia's : (ia' < size sl)%N by rewrite -ha' /a'_index find_size. +have ia'iota : (ia' < size (iota 0 n.+2))%N by move: ia's; rewrite size_map. +have:= (nth_find 0 has_sl); rewrite -/a'_index ha' => pb'p. +have:= (ltnSn ia'); rewrite -{2}ha'. +move/(@before_find _ 0 (fun x : R => 0 <= p.[x]) sl); move/negbT. +rewrite -ltNge => pa'n. +move:(ltW ba') => ba'w. +have aa' : a <= a'. + rewrite /a'/sl (nth_map 0%N) // lerDl mulr_ge0 //. + by rewrite mulr_ge0 // ?invr_ge0 ?ler0n. +have ia'_sharp : (ia' < n.+1)%N. + move: ia'iota; rewrite leq_eqVlt; rewrite size_iota; case/orP=> //. + move/eqP; case=> abs. + move: pa'n; rewrite abs (nth_map 0%N) ?size_iota // nth_iota //. + rewrite add0n divff ?mulr1 ?pnatr_eq0 // addrCA subrr addr0 => {} abs. + by move: plb; rewrite leNgt abs. +have b'b : b' <= b. + rewrite /b'/sl (nth_map 0%N) ?size_iota ?ltnS // nth_iota // add0n. + have e : b = a + (b - a) by rewrite addrCA subrr addr0. + rewrite {2}e {e} lerD2l //= -{2}(mulr1 (b -a)) ler_wpM2l //. + rewrite ler_pdivrMr ?ltr0Sn // mul1r -subr_gte0 /=. + have -> : (n.+1 = ia'.+1 + (n.+1 - ia'.+1))%N by rewrite subnKC. + by rewrite mulrnDr addrAC subrr add0r subSS ler0n. +have b'a'_sub : b' - a' = (b - a) / (n.+1)%:R. + have side : (ia' < n.+2)%N by apply: ltn_trans (ltnSn _). + rewrite /b' /a' /sl (nth_map 0%N) ?size_iota // nth_iota // add0n. + rewrite (nth_map 0%N) ?size_iota // nth_iota // add0n. + rewrite opprD addrAC addrA subrr add0r addrC -mulrBr. + by congr (_ * _); rewrite -mulrBl mulrSr addrAC subrr add0r div1r. +have a'b' : a' < b'. + move/eqP: b'a'_sub; rewrite subr_eq; move/eqP->; rewrite ltrDr. + by rewrite mulr_gt0 // invr_gt0 ltr0Sn. +rewrite pa'n a'b' b'b aa' pb'p. +have : `|p.[b'] - p.[a']| <= eps. + have := (pc sl`_ia' sl`_ia'.+1 aa' (ltW a'b') b'b). + rewrite b'a'_sub => hpc; apply: le_trans hpc _ => /=. + rewrite mulrA ler_pdivrMr ?ltr0Sn // mulrC [eps * _]mulrC. + rewrite -ler_pdivrMr //; apply: (ltW qn). +case/ler_normlP => h1 h2. +rewrite lerNl/= !andbT. +rewrite -[in X in X && _](lerD2l p.[b']) (le_trans h2) ? lerDr //. +by rewrite -(lerD2r (- p.[a'])) (le_trans h2) // lerDl oppr_gte0 ltW. +Qed. + +End PolsOnArchiField. diff --git a/theories/poly_normal.v b/theories/poly_normal.v new file mode 100644 index 0000000..92eb380 --- /dev/null +++ b/theories/poly_normal.v @@ -0,0 +1,1832 @@ +From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path choice fintype order. +From mathcomp Require Import prime div bigop ssralg poly polydiv polyorder ssrnum zmodp. +From mathcomp Require Import polyrcf qe_rcf_th complex. + +(******************************************************************************) +(* +This file consists of 3 sections: +- introduction of normal polynomials, some lemmas on normal polynomials +- constructions on sequences, such as all_neq0, all_pos, increasing, mid, seqmul, seqn0 +- proof of Proposition 2.44 of [bpr], normal_changes +*) +(******************************************************************************) + +Set Implicit Arguments. +Unset Strict Implicit. + +Import Order.TTheory GRing.Theory Num.Def Num.Theory. +Import Pdiv.Idomain. +Import ComplexField. + +Local Open Scope ring_scope. + +Section normal_sec_def. +Variable (R : numFieldType). + +Definition all_pos := fun (s : seq R) => all (fun x => 0 < x) s. + +Lemma all_posP (s : seq R) : + reflect (forall k, (k < size s)%N -> 0 < s`_k) (all_pos s). +Proof. exact/all_nthP. Qed. + +Fixpoint normal_seq (s : seq R) := + if s is a :: l1 then + if l1 is b :: l2 then + if l2 is c :: l3 then + (normal_seq l1) + && ((0 == a) || ((a * c <= b^+2) && (0 < a) && (0 < b))) + else (0 <= a) && (0 < b) + else 0 < a + else false. + +Definition normal := [qualify p : {poly R} | normal_seq p]. + +Lemma normalE p : p \is normal = normal_seq p. +Proof. by []. Qed. + +Lemma polyseq_deg1 (a b : R) : a != 0 -> (a *: 'X + b%:P) = [::b; a] :> seq R. +Proof. +move=> H. +by rewrite -mul_polyC -cons_poly_def polyseq_cons nil_poly polyC_eq0 polyseqC H. +Qed. + +Lemma polyseq_deg2 (a b c : R) : a != 0 -> + (a *: 'X^2 + b *: 'X + c%:P) = [:: c; b; a] :> seq R. +Proof. +move=> Ha. +rewrite -(mul_polyC a) -(mul_polyC b) expr2 mulrA -mulrDl. +by rewrite -cons_poly_def polyseq_cons mul_polyC polyseq_deg1. +Qed. + +Lemma normal_coef_geq0 (p : {poly R}) : p \is normal -> forall k, 0 <= p`_k. +Proof. +rewrite normalE; case: p=> s /= _. +case: s=> // a []=> [Ha | b l]. + by case=> [ | []] //; rewrite ltW. +elim: l a b=> [a b /andP [Ha Hb] | c l IHl a b]. + by case=> // [][]=> [ | []] //; rewrite ltW. +case/andP=> H1 /orP H2 [] /=. +rewrite le0r eq_sym. +case: H2=> [-> | /andP [/andP [_ ->]]] //. + by rewrite orbT. +exact: (IHl b c H1). +Qed. + +Lemma normal_lead_coef_gt0 (p : {poly R}) : p \is normal -> 0 < lead_coef p. +Proof. +rewrite normalE lead_coefE; case: p=> s /= _. +case: s=> // a [] => [Ha | b l] //. +elim: l a b=> [a b /andP [Ha Hb]| c l IHl a b ] //. +case/andP=> H1 /orP H2. +exact: (IHl b c H1). +Qed. + +End normal_sec_def. + +Section normal_polynomial. +Variable R : rcfType. + +Local Notation C := (complex R). + +Local Notation normal := (normal R). + +Lemma normal_squares (p : {poly R}) : + p \is normal -> (forall k, (1 <= k)%N -> p`_(k.-1) * p`_(k.+1) <= p`_k ^+2). +Proof. +rewrite normalE; case: p=> s /= _. +case: s=> // a [] => [Ha [] // n Hn | b l] //. + by rewrite mulr0; apply: sqr_ge0. +elim: l a b => [a b /andP [Ha Hb] | c l IHl a b]. + by case=> // [][] => [_ | n _]; rewrite mulr0; apply: sqr_ge0. +case/andP=> H1 /orP H2 [] // [] => [_ | n Hn]. + case: H2=> [/eqP <-|/andP [] /andP [] H2 _ _] //. + by rewrite mul0r; apply: sqr_ge0. +exact: (IHl b c H1 n.+1). +Qed. + +Lemma normal_some_coef_gt0 (p : {poly R}) : + p \is normal -> forall i, 0 < p`_i -> + forall j, (i < j)%N -> (j < (size p).-1)%N -> 0 < p`_j. +Proof. +rewrite normalE; case: p=> s /= _. +case: s=> // a []=> [Ha [] // | b l] //. +elim: l a b => [a b /andP [Ha Hb] | c l IHl a b]. + by case=> // [_ |] [] // => [_|] [] // => [_|n _][]. +case/andP =>H1 H2 [] (*i*) => [Ha | i Hi] [] (*j*)// => [|j Hj1 Hj2]. + rewrite (lt_eqF Ha) /= in H2. + have/andP [_ Hb] := H2. + case=> // j _ Hj; first exact: (IHl b c H1 0%N Hb j.+1). +exact: (IHl b c H1 i Hi). +Qed. + +Lemma prop_normal (p : {poly R}) : + [/\ (forall k, 0 <= p`_k), + (0 < lead_coef p), + (forall k, (1 <= k)%N -> p`_(k.-1) * p`_(k.+1) <= (p`_k) ^+2) & + (forall i, 0 < p`_i -> + forall j, (i < j)%N -> (j < (size p).-1)%N -> 0 < p`_j)] -> + p \is normal. +Proof. +case; rewrite normalE lead_coefE; case: p=> s /= _. +case: s => [ | a [] // b l]; first by rewrite ltxx. +elim: l a b=> [a b /(_ 0%N) /= -> -> //| c l IHl a b Hge0 Hlc H2 Hgt0]. +apply/andP; split. + apply: IHl=>[k||[] // k _|k Hk j Hj1 Hj2] //. + + exact: (Hge0 k.+1). + - exact: (H2 k.+2). + + exact: (Hgt0 k.+1 Hk j.+1). +have:= (Hge0 0%N); rewrite le_eqVlt /=. +case/orP=> [-> //| Ha]. +by rewrite (Hgt0 0%N Ha 1%N) // (H2 1%N) // Ha orbT. +Qed. + +Inductive normal_spec (p : {poly R}) := + Normal_spec (_ : forall k, 0 <= p`_k) (_ : 0 < lead_coef p) + (_ : forall k, (1 <= k)%N -> p`_(k.-1) * p`_(k.+1) <= (p`_k) ^+2) + (_ : forall i, 0 < p`_i -> + forall j, (i < j)%N -> (j < (size p).-1)%N -> 0 < p`_j). + +Lemma normalP (p : {poly R}) : reflect (normal_spec p) (p \is normal). +Proof. +apply/(iffP idP) => [H | [] *]. + split. + + exact: normal_coef_geq0. + - exact: normal_lead_coef_gt0. + + exact: normal_squares. + - exact: normal_some_coef_gt0. +exact: prop_normal. +Qed. + +(* Lemma 2.41 *) +Lemma monicXsubC_normal (a : R) : ('X - a%:P) \is normal = (a <= 0). +Proof. +rewrite normalE polyseqXsubC /=. +by case Ha: (a <= 0); rewrite oppr_ge0 Ha // ltr01. +Qed. + +Import complex. + +Definition inB (z : C) := (Re z <= 0) && (Im z ^+2 <= 3%:R * Re z ^+2). + +(* Lemma 2.42 *) + +Lemma quad_monic_normal (z : C) : + (('X^2 + (- 2%:R * Re z) *: 'X + (Re z ^+2 + Im z ^+2)%:P) \is normal) = + inB z. +Proof. +rewrite normalE -(mulr1 'X^2) mulrC mul_polyC polyseq_deg2 ?oner_neq0 //=. +rewrite /inB -(@nmulr_rge0 _ (- 2%:R)) -?oppr_gt0 ?opprK ?ltr0Sn // ltr01 andbT. +apply: andb_id2l => Hrez. +rewrite mulr1. +rewrite exprMn_comm; last first. + rewrite /GRing.comm. + by rewrite -mulNrn mulrC. +rewrite sqrrN. +rewrite -natrX. +rewrite (mulr_natl _ (2 ^ 2)). +rewrite [_ ^+2 *+ _]mulrS lerD2l -mulr_natl -andbA /=. +apply/idP/idP => [/orP [] | H]. + rewrite eq_sym paddr_eq0 ?sqr_ge0 //. + case/andP => /eqP -> /eqP ->. + by rewrite mulr0. + by case/andP. +rewrite le_eqVlt in Hrez. +case/orP : Hrez => [ | Hrez]. + rewrite eq_sym mulf_eq0 oppr_eq0 pnatr_eq0 orFb =>/eqP Hrez. + rewrite Hrez expr0n mulr0 exprn_even_le0 //= in H. + by rewrite Hrez (eqP H) expr0n add0r eqxx. +rewrite Hrez H ltr_pwDl ?orbT // ?lt_def sqr_ge0 // sqrf_eq0. +rewrite lt_def mulf_eq0 oppr_eq0 pnatr_eq0 orFb in Hrez. +by case/andP : Hrez => ->. +Qed. + +Lemma normal_neq0 (p : {poly R}) : p \is normal -> p != 0. +Proof. +move=> /normalP [_ H _ _]; rewrite -lead_coef_eq0. +by case: ltrgtP H. +Qed. + +Lemma normal_MX (p : {poly R}) : p \is normal -> p * 'X \is normal. +Proof. +move=> Hpnormal. +have Hpneq0 := (normal_neq0 Hpnormal). +case : p Hpneq0 Hpnormal => s Hs. +rewrite !normalE /= => Hp Hsnormal. +rewrite polyseqMX //=. +case : s Hs Hp Hsnormal => // a. +case => [Hs Hp Ha | b l]. + by apply/andP. +elim: l a b => [b c Hs Hp Hab | c l Hcl a b Hs Hp Habcl]; +apply/andP; split => //; +apply/orP; by left. +Qed. + +Lemma normal_MXn (p : {poly R}) (n : nat) : p \is normal -> p * 'X^n \is normal. +Proof. +move=> Hpnormal. +elim : n => [ | n Hn]. + by rewrite expr0 mulr1. +by rewrite exprSr mulrA normal_MX. +Qed. + +Lemma normal_MX_2 (p : {poly R}) : p * 'X \is normal -> p \is normal. +Proof. +move=> HpXnormal. +have HpXneq0 := normal_neq0 HpXnormal. +have Hpneq0 : p != 0 by rewrite -lead_coef_eq0 -lead_coefMX lead_coef_eq0. +(* one coef *) +case : p Hpneq0 HpXneq0 HpXnormal => s Hs. +rewrite !normalE /= => Hp HpX Hsnormal. +rewrite polyseqMX // in Hsnormal. +case : s Hs Hp HpX Hsnormal => [Hs Hp HpX H /= | a]. + by rewrite /= ltxx in H. +(* two coeffs *) +case => [Hs Hp HpX Ha /=| b l]. + by rewrite /= lexx /= in Ha. +(* at least 3 coeffs *) +elim: l a b => [b c Hs Hp HpX /andP Hab /= | c l Hcl a b Hs Hp HpX /andP Habcl]. + exact: proj1 Hab. +exact: proj1 Habcl. +Qed. + +Lemma normal_MXn_2 (p : {poly R}) (n : nat) : p * 'X^n \is normal -> p \is normal. +Proof. +elim : n => [| n Hn H]. + by rewrite expr0 mulr1. +rewrite exprSr mulrA in H. +by rewrite Hn // normal_MX_2. +Qed. + +Lemma normal_size_le1 (p : {poly R}) : p \is normal -> + (size p <= 1%N)%N = (size p == 1%N)%N. +Proof. +move=> Hpnormal. +rewrite eqn_leq. +apply/idP/idP => [Hpsize | /andP Hpsize]. + apply/andP; split => //. + by rewrite ltnNge leqn0 size_poly_eq0 normal_neq0. +exact: (proj1 Hpsize). +Qed. + +(* 0 is a root with multiplicity k iff the first k coefs are = 0 *) +Lemma normal_root0 (p : {poly R}) : + root p 0 -> forall k, (k < (\mu_0 p))%N -> p`_k = 0. +Proof. +move=> Hproot k Hkmu. +have H := root_mu p 0. +rewrite subr0 Pdiv.IdomainMonic.dvdp_eq in H. + by rewrite (eqP H) coefMXn Hkmu. +exact: monicXn. +Qed. + +(* for p normal : 0 is not a root iff all coefs are > 0 *) +Lemma normal_0notroot_b (p : {poly R}) : p \is normal -> + (~~(root p 0) = [forall k : 'I_((size p).-1), 0 < p`_k]). +Proof. +move=> Hpnormal. +have/normalP [H1 _ _ H4] := Hpnormal. +have Hp := (normal_neq0 Hpnormal). +apply/idP/idP. +(* => *) + move/rootPf=> H. + rewrite horner_coef0 in H. + have Hp0 : 0 < p`_0 by rewrite lt_def H (H1 0%N). + apply/forallP; case; case=> [ | n Hn] //. + by apply: (H4 0%N Hp0 n.+1 (ltn0Sn n) Hn). +(* <= *) +apply: contraL => /rootPt Hproot0. +rewrite negb_forall; apply/existsP. +have H0 : (0 < (size p).-1)%N. + rewrite -subn1 -(ltn_add2r 1) !addn1 subn1 prednK. + rewrite (root_size_gt1 (a:=0)) //. + rewrite (ltn_trans (n:= 1)) //. + rewrite (root_size_gt1 (a:=0)) //. +exists (Ordinal H0). +rewrite -leNgt le_eqVlt. +apply/orP; left. +by rewrite horner_coef0 in Hproot0. +Qed. + +(* useful version of the previous lemma *) +Lemma normal_0notroot (p : {poly R}) : p \is normal -> + ~~(root p 0) -> (forall k, (k < (size p).-1)%N -> 0 < p`_k). +Proof. +move=> Hpnormal H. +rewrite normal_0notroot_b // in H. +move/forallP : H => H k Hk. +apply: (H (Ordinal Hk)). +Qed. + +(* this is true because of previous lemma and lead_coef > 0 *) +Lemma normal_0notroot_2 (p : {poly R}) : p \is normal -> + ~~ root p 0 -> forall k, (k < (size p))%N -> 0 < p`_k. +Proof. +move=> Hpnormal H k Hk. +have/normalP [_ H2 _ _] := Hpnormal. +case Hk2 : (k < (size p).-1)%N. + by apply: normal_0notroot. +have Hk3 : (k == (size p).-1). + rewrite eqn_leq. + apply/andP; split. + rewrite -ltnS prednK // size_poly_gt0. + by apply: normal_neq0. + by rewrite leqNgt Hk2. +by rewrite (eqP Hk3) -lead_coefE. +Qed. + +(* product of 2 polynomials with coefs >0 has coefs >0 *) +Lemma prod_all_ge0 (p : {poly R}) (q : {poly R}) : + p != 0 -> q != 0 -> + (forall i, (i <= (size p).-1)%N -> 0 < p`_i) -> + (forall j, (j <= (size q).-1)%N -> 0 < q`_j) -> + forall k, (k <= (size (p * q)%R).-1)%N -> 0 < (p * q)`_k. +Proof. +wlog: p q / ((size p).-1 <= (size q).-1)%N => H Hp Hq Hpcoef Hqcoef k Hk. + case/orP : (leq_total (size p).-1 (size q).-1) => H2. + by apply: H. + rewrite mulrC; rewrite mulrC in Hk. + by apply: (H q p H2). +case : (leqP k (size p).-1) => Hk2. + rewrite coefM (bigD1 ord0) //= subn0 (lt_le_trans (y := (p`_0 * q`_k))) //. + rewrite pmulr_lgt0; first by rewrite Hpcoef. + by rewrite Hqcoef // (@leq_trans ((size p).-1)). + rewrite lerDl sumr_ge0 //. + case => /= i Hi Hi2. + rewrite pmulr_rge0. + case Hki : (k - i <= (size q).-1)%N. + by rewrite ltW // Hqcoef. + rewrite le0r -{1}(coefK q) coef_poly /=. + have Hki2 : ((k - i < (size q))%N = false). + by rewrite -[(size q)]prednK ?ltnS // size_poly_gt0. + by rewrite Hki2 eq_refl. + by rewrite Hpcoef // (leq_trans (n:=k)). +rewrite coefM. +have Hk3 : ((size p).-1 < k.+1)%N by apply: (ltn_trans (n:=k)). +rewrite (bigD1 (Ordinal Hk3)) //= + (lt_le_trans (y := (p`_(size p).-1 * q`_(k - (size p).-1)))) //. + have Hk4: (k - (size p).-1 <= (size q).-1)%N. + rewrite leq_subLR. + by rewrite size_mul // -[size p]prednK ?size_poly_gt0 // + -[size q]prednK ?size_poly_gt0 // addSn addnS -!pred_Sn in Hk. + rewrite pmulr_rgt0; first by rewrite Hqcoef. + by apply: Hpcoef. +rewrite lerDl sumr_ge0 //. +case => /= i Hi Hi2. +apply: mulr_ge0. + case Hi3 : (i <= (size p).-1)%N. + by rewrite ltW // Hpcoef. + rewrite le0r -{1}(coefK p) coef_poly /=. + rewrite ifF ?eqxx//. + by rewrite -[(size p)]prednK ?ltnS // size_poly_gt0. +case Hki : (k - i <= (size q).-1)%N. + by rewrite ltW // Hqcoef. +rewrite le0r -{1}(coefK q) coef_poly /=. +rewrite ifF ?eqxx//. +by rewrite -[(size q)]prednK ?ltnS // size_poly_gt0. +Qed. + +(* exchange two sums *) +Lemma xchange : forall (T : Type) (idx : T) (op : Monoid.com_law idx) + (m n : nat) (F : nat -> nat -> T), + \big[op/idx]_(m <= i < n) (\big[op/idx]_(m <= j < i.+1) F i j) = + \big[op/idx]_(m <= h < n) \big[op/idx]_(h <= j < n) (F j h). +Proof. +move=> T idx op m n F. +elim : n => [ | n Hn ]. + case : (leqP 0 m)=> Hm0 //. + by rewrite !big_geq. +case : (ltnP n m) => Hmn. + by rewrite !big_geq. +rewrite (big_cat_nat op (n:=n)) // big_nat1 Hn + [x in (op _ x = _)](big_cat_nat op (n:=n)) // big_nat1 + [x in (op _ _ = x)](big_cat_nat op (n:=n)) // big_nat1 big_nat1 + (Monoid.mulmA op). +congr (op _ _). +rewrite -[LHS]big_split big_nat [x in (_ = x)]big_nat. +apply: eq_bigr => i Hi. +rewrite [x in (_ = x)](big_cat_nat op (n:=n)) // ?big_nat1 // ltnW//. +by case/andP: Hi=> _ ->. +Qed. + +Lemma normal_coef_chain_1 (p : {poly R}) : ~~ root p 0 -> + p \is normal -> forall k, (0 < k)%N -> forall i, + p`_k.-1 * p`_(k.+1 +i) <= p`_(k + i) * p`_k . +Proof. +move=> Hp0notroot Hpnormal k Hk. +have/normalP [H1 _ H3 _] := Hpnormal. +elim => [ |i Hi ] //. + rewrite !addn0 -expr2 H3 //. +rewrite -subr_ge0. +case Hik : (k + i.+1 < size p)%N. + rewrite -(pmulr_lge0 (x:= p`_(k + i.+1))) //. + rewrite mulrDl mulNr subr_ge0. + apply: (le_trans (y:= p`_(k + i) * p`_k * p`_(k.+2 + i))). + rewrite -[x in (x <= _)]mulrA [x in (_ * x)]mulrC !mulrA -!addSnnS + -subr_ge0 -mulNr -mulrDl. + case H : (p`_(k.+2 + i) == 0). + by rewrite (eqP H) mulr0. + by rewrite pmulr_lge0 ?subr_ge0 // lt_def H H1. + have H := (H3 (k + i).+1 (ltn0Sn (k + i))). + rewrite !addnS !addSn [x in (x * _)]mulrC [x in (_ <= x * _)]mulrC + -subr_ge0 -!(mulrA p`_k) -mulrN -mulrDr mulrC pmulr_lge0. + by rewrite subr_ge0 -expr2 //. + apply: normal_0notroot => //. + apply: (leq_ltn_trans (n:=(k + i))). + by apply: leq_addr. + by rewrite -subn1 ltn_subRL addnC addn1 -addnS. + by apply normal_0notroot_2. +have Hik2 : (k + i.+2 < size p)%N = false. + apply: negbTE. + rewrite -leqNgt. + apply: (leq_trans (n := (k + i.+1))). + by rewrite leqNgt Hik. + by rewrite !addnS leqnSn. +by rewrite addSnnS -{4}(coefK p) coef_poly //= Hik2 mulr0 oppr0 + addr0 -{1}(coefK p) coef_poly Hik mul0r. +Qed. + +Lemma normal_coef_chain_2 (p : {poly R}) : ~~ root p 0 -> + p \is normal -> forall k, (0 < k)%N -> forall i, (k <= i)%N -> + p`_k.-1 * p`_(i.+1) <= p`_i * p`_k . +Proof. +move=> Hp0notroot Hpnormal k Hk i Hi. +have H := (normal_coef_chain_1 Hp0notroot Hpnormal Hk (i - k)). +by rewrite !addnBA // addnC (addnC k i) -addnBA // subSnn addn1 addnK in H. +Qed. + +(* Lemma 2.43, restricted version *) +Lemma normal_mulr_r (p q : {poly R}) : ~~ root p 0 -> ~~ root q 0 -> + p \is normal -> q \is normal -> (p * q) \is normal. +Proof. +move=> Hpzero Hqzero Hpnormal Hqnormal. +apply/normalP; split=> [k | |k Hk |i Hpqi j Hij Hj]. +(* first property *) + have/normalP [Hp _ _ _] := Hpnormal. + have/normalP [Hq _ _ _] := Hqnormal. + rewrite coefM sumr_ge0 // => [i _] /=. + by apply: mulr_ge0. +(* second property *) + have/normalP [_ Hp _ _] := Hpnormal. + have/normalP [_ Hq _ _] := Hqnormal. + by rewrite lead_coefM pmulr_lgt0. +(* third property *) + rewrite -subr_ge0 !coefM prednK // expr2 !big_distrlr /=. + (* separate first double sum in 3 parts *) + rewrite -(big_mkord (fun i : nat => true) + (fun i : nat => \sum_(j < k.+1) (p`_i * q`_(k - i) * (p`_j * q`_(k - j))))). + rewrite -(big_mkord (fun i : nat => true) + (fun i : nat => \sum_(j < k.+2) (p`_i * q`_(k.-1 - i) * + (p`_j * q`_(k.+1 - j))))). + rewrite (eq_bigr + (fun i => \sum_(0 <= j < k.+1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)))); + last by move => ? _ ; rewrite big_mkord. + rewrite [x in _ - x](eq_bigr + (fun i => \sum_(0 <= j < k.+2) p`_i * q`_(k.-1 - i) * + (p`_j * q`_(k.+1 - j)))); + last by move => ? _ ; rewrite big_mkord. + have H : \sum_(0 <= i < k.+1) + \sum_(0 <= j < k.+1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)) = + \sum_(2 <= h < k.+1) + \sum_(0 <= j < h.-1) p`_h * q`_(k - h) * (p`_j * q`_(k - j)) + + \sum_(1 <= h < k.+1) + p`_h * q`_(k - h) * (p`_(h.-1) * q`_(k - h.-1)) + + \sum_(0 <= h < k.+1) + \sum_(h <= j < k.+1) p`_h * q`_(k - h) * (p`_j * q`_(k - j)). + have H2: \sum_(0 <= i < k.+1) + \sum_(0 <= j < k.+1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)) = + \sum_(0 <= i < k.+1) + \sum_(0 <= j < i.-1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)) + + \sum_(0 <= i < k.+1) + \sum_(i.-1 <= j < i) p`_i * q`_(k - i) * (p`_j * q`_(k - j)) + + \sum_(0 <= i < k.+1) + \sum_(i <= j < k.+1) p`_i * q`_(k - i) * (p`_j * q`_(k - j)). + rewrite -big_split -big_split. + rewrite big_nat [x in (_ = x)]big_nat; apply: eq_bigr => i Hi. + rewrite -big_cat_nat //. + rewrite -big_cat_nat //. + apply: ltnW; by move/andP : Hi; case=> _ ->. + by apply: leq_pred. + rewrite H2 {H2}. + congr (_ + _). + rewrite big_nat_recl// big_geq ?add0r; last by apply: leq_pred. + rewrite big_nat_recl// (big_geq (m:=0.-1) (n:=0)) // ?add0r. + have H2 : \sum_(0 <= i < k) \sum_(i.+1.-1 <= j < i.+1) + p`_i.+1 * q`_(k - i.+1) * (p`_j * q`_(k - j)) = + \sum_(1 <= h < k.+1) p`_h * q`_(k - h) * (p`_h.-1 * q`_(k - h.-1)). + rewrite big_add1 -pred_Sn big_nat [x in (_ = x)]big_nat. + apply: eq_bigr=> i Hi. + by rewrite -pred_Sn big_nat1. + rewrite H2 {H2}. + congr (_ + _). + by rewrite -{1}(prednK Hk) big_nat_recl// big_geq // add0r + big_add1 big_add1 -pred_Sn. + rewrite H {H}. + (* separate second double sum in 3 parts *) + have H : \sum_(0 <= i < k) + \sum_(0 <= j < k.+2) p`_i * q`_(k.-1 - i) * (p`_j * q`_(k.+1 - j)) = + \sum_(0 <= h < k) + \sum_(0 <= j < h.+1) p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j)) + + \sum_(1 <= i < k.+1) p`_(i.-1) * q`_(k - i) * (p`_i * q`_(k.+1 - i)) + + \sum_(0 <= h < k) + \sum_(h.+2 <= j < k.+2) p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j)). + rewrite big_add1 -pred_Sn -!big_split big_nat [x in (_ = x)]big_nat. + apply: eq_bigr => h Hh. + rewrite (big_cat_nat (n:= h.+1) GRing.add (fun j => true) + (fun j => p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j))) ) //. + rewrite (big_cat_nat (n:= h.+2) (m:=h.+1) GRing.add + (fun j => true) + (fun j => p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j))) ). + rewrite big_nat1 -pred_Sn /= -/(nth 0 _ (h.+1)) !addrA. + congr (_ + _); congr (_ + _). + by rewrite -(addn1 h) (addnC h 1%N) (subnDA 1 k h) subn1. + by rewrite (ltn_trans (n:=h.+1)) // ltnSn. + case/andP: Hh => Hh1 Hh2. + by rewrite (ltn_trans (n:=h.+2)) // ltnSn. + by apply: (ltn_trans (n:=k)). + (* canceling one of the three terms *) + rewrite H {H} + [x in ((x + _) - _)]addrC -[x in (_ - x)]addrA [x in (_ - (_ + x))]addrC + !opprD !addrA addrC -sumrN !addrA -big_split. + have H : \big[GRing.add/0]_(1 <= i < k.+1) + GRing.add + (- (p`_i.-1 * q`_(k - i) * (p`_i * q`_(k.+1 - i)))) + (p`_i * q`_(k - i) * (p`_i.-1 * q`_(k - i.-1))) = 0. + rewrite big_split sumrN /= addrC. + apply/eqP. rewrite subr_eq0. apply/eqP. + rewrite big_nat [x in (_ = x)]big_nat. + apply: eq_bigr => i Hi. + rewrite mulrC -[x in (x = _)]mulrA [x in (_ * x = _)]mulrC + [x in (_ * (x * _) = _)]mulrC !mulrA. + congr (_ * _). + rewrite -subn1 subnBA ?addn1 //. + by case/andP : Hi. + (* rotating sums around and splitting off bits of them *) + rewrite H {H} add0r big_add1 -pred_Sn. + rewrite (eq_big + (F1 := fun i => \sum_(0 <= j < i.+1.-1) p`_i.+1 * q`_(k - i.+1) + * (p`_j * q`_(k - j))) + (P1 := fun i => true) + (fun i => true) + (fun i => \sum_(1 <= l < i.+1) p`_i.+1 * q`_(k - i.+1) + * (p`_(l.-1) * q`_(k - (l.-1))))) // =>[ | i _]. + have H : \sum_(0 <= h < k) + \sum_(h.+2 <= j < k.+2) p`_h * q`_(k.-1 - h) * (p`_j * q`_(k.+1 - j)) = + \sum_(1 <= i < k.+1) + \sum_(i <= l < k.+1) p`_i.-1 * q`_(k - i) * (p`_l.+1 * q`_(k - l)). + rewrite big_add1 -pred_Sn. + apply: eq_big_nat => i Hi. + rewrite big_add1 -pred_Sn. + apply: eq_big_nat => l Hl. + by rewrite -pred_Sn subSS -(addn1 i) (addnC i 1%N) subnDA -subn1. + rewrite H {H} xchange big_nat_recl//. + have H : \sum_(0 <= i < k) + \sum_(i.+1 <= j < k.+1) p`_i.+1 * q`_(k - i.+1) * (p`_j * q`_(k - j)) = + \sum_(1 <= h < k.+1) + \sum_(h <= j < k.+1) p`_h * q`_(k - h) * (p`_j * q`_(k - j)). + by rewrite big_add1 -pred_Sn. + rewrite H {H} [x in (_ + (_ + _) - x - _)]xchange + -{12}(prednK Hk) [x in (_ + (_ + _) - x - _)]big_nat_recl//. + have H :(\big[GRing.add/0]_(0 <= i < k.-1) + \big[GRing.add/0]_(i.+1 <= j < k) + (p`_j * q`_(k.-1 - j) * (p`_i.+1 * q`_(k.+1 - i.+1))) = + \sum_(1 <= h < k) + \sum_(h <= j < k) p`_h * q`_(k.+1 - h) * (p`_j * q`_(k.-1 - j))). + rewrite big_add1 big_nat [x in (_ = x)]big_nat. + apply: eq_bigr => i Hi. + rewrite big_nat [x in (_ = x)]big_nat. + apply: eq_bigr => j Hj. + by rewrite mulrC. + rewrite H {H}. + have H : \sum_(1 <= i < k.+1) + \sum_(i <= l < k.+1) p`_i.-1 * q`_(k - i) * (p`_l.+1 * q`_(k - l)) = + \sum_(1 <= h < k) + \sum_(h <= j < k) p`_h.-1 * q`_(k - h) * (p`_j.+1 * q`_(k - j)) + + \sum_(1 <= i < k.+1) p`_i.-1 * q`_(k - i) * (p`_k.+1 * q`_0). + rewrite (big_cat_nat GRing.add (n:= k)) // + big_nat1 big_nat1 + [x in (_ = _ + x)](big_cat_nat GRing.add (n:= k)) // + big_nat1 (addnK k 0%N) Monoid.addmA. + congr (_ + _). + rewrite -big_split big_nat [x in (_ = x)]big_nat. + apply: eq_bigr => i Hi. + rewrite (big_cat_nat GRing.add (n:= k)) //. + rewrite big_nat1. + by rewrite (addnK k 0%N). + apply: ltnW. + by case/andP : Hi. + rewrite H {H}. + have H : \sum_(1 <= h < k.+1) + \sum_(h <= j < k.+1) p`_h * q`_(k - h) * (p`_j * q`_(k - j)) = + \sum_(1 <= h < k) + \sum_(h <= j < k) p`_h * q`_(k - h) * (p`_j * q`_(k - j)) + + \sum_(1 <= i < k.+1) p`_i * q`_(k - i) * (p`_k * q`_0). + rewrite (big_cat_nat GRing.add (n:= k)) // + big_nat1 big_nat1 + [x in (_ = _ + x)](big_cat_nat GRing.add (n:= k)) // + big_nat1 (addnK k 0%N) Monoid.addmA. + congr (_ + _). + rewrite -big_split big_nat [x in (_ = x)]big_nat. + apply: eq_bigr => i Hi. + rewrite (big_cat_nat GRing.add (n:= k)) //. + by rewrite big_nat1 (addnK k 0%N). + apply: ltnW. + by case/andP : Hi. + rewrite H {H} !opprD -!sumrN !addrA + -[x in (x + _)]addrA -big_split + -[x in ((((x + _) + _) + _) + _)]addrA + [x in (((((_ + x) + _) + _) + _) + _)]addrC + !addrA -big_split + -addrA [x in (_ + x)]addrC !addrA addrC !addrA -big_split. + have H : \big[GRing.add/0]_(1 <= i < k) + GRing.add + (GRing.add + (- + (\sum_(i <= j < k) p`_i * q`_(k.+1 - i) * (p`_j * q`_(k.-1 - j)))) + (- + (\sum_(i <= j < k) p`_i.-1 * q`_(k - i) * (p`_j.+1 * q`_(k - j))))) + (GRing.add + (\big[GRing.add/0]_(i <= j < k) + (p`_j.+1 * q`_(k - j.+1) * (p`_i.-1 * q`_(k - i.-1)))) + (\sum_(i <= j < k) p`_i * q`_(k - i) * (p`_j * q`_(k - j)))) = + \sum_(1 <= h < k) \sum_(h <= j < k) (p`_h * p`_j - p`_h.-1 * p`_j.+1) * + (q`_(k - h) * q`_(k - j) - q`_(k.+1 - h) * q`_(k.-1 - j)). + rewrite big_nat [x in (_ = x)]big_nat. + apply: eq_bigr => i Hi. + case/andP: Hi => Hi1 Hi2. + rewrite -!sumrN -!big_split big_nat [x in (_ = x)]big_nat. + apply: eq_bigr => j Hj. + case/andP: Hj => Hj1 Hj2. + rewrite /= -/(nth 0 _ j.+1) !addrA addrC. + by rewrite -mulrN -!mulrA !addrA -(mulrDr p`_i) + -mulrN !mulrA (mulrC _ p`_j) (mulrC _ p`_j) -!mulrA + -(mulrDr p`_j) mulrN mulrA + -[x in ((_ * _) + x + _ = _)]mulNr [x in (_ + (_ * x) + _ = _)]mulrA + [x in (_ + (_ * (x * _)) + _ = _)]mulrC !mulrA + [x in (_ + ((x * _) * _) + _ = _)]mulNr + -[x in (_ + _ + (x * _) = _)]mulrA + [x in (_ + _ + (_ * x * _) = _)]mulrC !mulrA + [x in (_ + _ + (x * _ * _) = _)]mulrC + -{2}(opprK (p`_i.-1 * p`_j.+1)) + -[x in (_ + _ + x = _)]mulrA + (mulNr (-(p`_i.-1 * p`_j.+1))) + -[x in (_ + _ + x = _)]mulrN -addrA + -[x in (_ + (x + _) = _)]mulrA + -(mulrDr (- (p`_i.-1 * p`_j.+1))) + [x in (_ + _ * (_ - x) = _)]mulrC + -{2}(subn1 i) subnBA // addn1 -{2}(addn1 j) (addnC j 1%N) + subnDA subn1 -mulrDl. + rewrite H {H} -!addrA. + apply: addr_ge0. + rewrite big_nat; apply: sumr_ge0 => i Hi. + rewrite big_nat; apply: sumr_ge0 => j Hj. + apply: mulr_ge0. + rewrite subr_ge0 [x in (_ <= x)]mulrC. + apply: (normal_coef_chain_2 Hpzero Hpnormal). + by case/andP : Hi. + by case/andP : Hj. + rewrite subr_ge0 [x in (x <= _)]mulrC -subn1 -subnDA addnC addn1 subnS + subSn; last by rewrite ltnW; case/andP : Hi. + apply: (normal_coef_chain_2 Hqzero Hqnormal). + rewrite subn_gt0. + by case/andP : Hj. + rewrite leq_sub //. + by case/andP : Hj. + rewrite addrA [x in (0 <= _ + x)]addrC -!addrA [x in (0 <= _ + x)]addrA + -big_split addrC -!addrA addr_ge0 //. + rewrite big_nat; apply: sumr_ge0 => i Hi. + rewrite /= -/(nth 0 _ (k.+1)) -/(nth 0 _ 0) + [x in (0 <= x * _ - _)]mulrC + [x in (0 <= _ - x * _)]mulrC -!mulrA -mulrBr. + apply: mulr_ge0. + by have/normalP [H _ _ _] := Hqnormal. + rewrite !mulrA -mulrBl. + apply: mulr_ge0. + rewrite subr_ge0 [x in (_ <= x)]mulrC + (normal_coef_chain_2 Hpzero Hpnormal) //. + by case/andP : Hi. + rewrite -ltnS; by case/andP : Hi. + by have/normalP [H _ _ _] := Hqnormal. + rewrite big_nat_recr// addrA -big_split addr_ge0 //. + rewrite big_nat; apply: sumr_ge0 => i Hi. + rewrite /= -/(nth 0 _ (k.+1)) -/(nth 0 _ (i.+1)) -/(nth 0 _ 0) + mulrC addrC -!mulrA -mulrBr mulr_ge0 //. + by have/normalP [H _ _ _] := Hpnormal. + rewrite mulrC mulrA [x in (0 <= x * _ - _)]mulrC -!mulrA -mulrBr + mulr_ge0 //. + by have/normalP [H _ _ _] := Hpnormal. + rewrite subn0 subr_ge0 -subn1 -subnDA addnC subnDA subn1. + apply: (normal_coef_chain_2 Hqzero Hqnormal). + rewrite subn_gt0; by case/andP : Hi. + by rewrite -{2}(subn0 k) leq_sub. + rewrite subn0 (addnK k 0%N). + have/normalP [Hp _ _ _] := Hpnormal. + have/normalP [Hq _ _ _] := Hqnormal. + by apply: mulr_ge0; apply: mulr_ge0; by rewrite ?Hp ?Hq. + rewrite big_add1 -pred_Sn. + apply: eq_bigr => j _. + by rewrite -pred_Sn. +(* fourth property *) +rewrite prod_all_ge0 // ?normal_neq0 // ?normal_neq0// => [k Hk| k Hk| ]. + rewrite normal_0notroot_2 //. + rewrite -ltnS prednK // in Hk. + by rewrite size_poly_gt0 normal_neq0. + rewrite normal_0notroot_2 //. + rewrite -ltnS prednK // in Hk. + by rewrite size_poly_gt0 normal_neq0. +by apply: ltnW. +Qed. + +(* Lemma 2.43 *) +Lemma normal_mulr : forall p q : {poly R}, + p \is normal -> q \is normal -> (p * q) \is normal. +Proof. +move=> p q Hpnormal Hqnormal. +have Hp0 := (root_mu p 0). +have Hq0 := (root_mu q 0). +rewrite Pdiv.Field.dvdp_eq in Hp0. +rewrite Pdiv.Field.dvdp_eq in Hq0. +have Hp0notroot1 : (~~(root (p %/ ('X - 0%:P) ^+ \mu_0 p) 0) ). + rewrite -mu_gt0 ?mu_div //. + by rewrite (addnK (\mu_0 p) 0%N) ltnn. + by rewrite dvdp_div_eq0 ?normal_neq0 // root_mu. +have Hq0notroot1 : (~~(root (q %/ ('X - 0%:P) ^+ \mu_0 q) 0) ). + rewrite -mu_gt0 ?mu_div //. + by rewrite (addnK (\mu_0 q) 0%N) ltnn. + by rewrite dvdp_div_eq0 ?normal_neq0 // root_mu. +rewrite (eqP Hp0) (eqP Hq0) [x in (x * _)]mulrC !mulrA + (mulrC _ (('X - 0%:P) ^+ \mu_0 q)) !mulrA -exprD + {1}oppr0 addr0 -mulrA mulrC normal_MXn //. +apply: normal_mulr_r => //. + rewrite (eqP Hp0) {2}oppr0 addr0 in Hpnormal. + by apply: (normal_MXn_2 (n:=\mu_0 p)). +rewrite (eqP Hq0) {2}oppr0 addr0 in Hqnormal. +by apply: (normal_MXn_2 (n:=\mu_0 q)). +Qed. + +(* begin move + move to complex.v ? *) + +Lemma normc_re_im : forall z : C, + (Normc.normc z) ^+2 = (Re z)^+2 + (Im z)^+2. +Proof. +case=> a b. +rewrite -[x in (_ = x)]sqr_sqrtr // addr_ge0 //; by apply: sqr_ge0. +Qed. + +Local Open Scope complex_scope. +Lemma normC_re_im : forall z : C, + (normr z) ^+2 = ((Re z)^+2 + (Im z)^+2)%:C. +Proof. +case=> a b. +rewrite sqr_normc /=. simpc. +by rewrite -!expr2 mulrC -(addr0 (- (b * a) + b * a)) -addrA (@addKr R _ 0). +Qed. + +Lemma re_conj (z : C) : + 2%:R * (Re z)%:C = z + z^*. +Proof. +by rewrite ReJ_add mulrC mulfVK // pnatr_eq0. +Qed. + +Lemma im_conj (z : C) : + z - z^* = 2%:R * (Im z)%:C * 'i. +Proof. +by rewrite ImJ_sub -!mulrA -expr2 sqr_i (mulrC _ (-1)) (mulrA _ (-1) _) + mulrN1 opprB mulrC mulfVK // pnatr_eq0. +Qed. +(* end move *) +Local Close Scope complex_scope. + +Local Notation toC := (fun (p : {poly R}) => + @map_poly R _ (real_complex R) p). + +Lemma real_complex_conjc : forall p : {poly R}, + map_poly ((@conjc R) \o (real_complex R)) p = + map_poly (real_complex R) p. +Proof. +elim/poly_ind => [ | p c H]. + by rewrite !rmorph0. +by rewrite !rmorphD !rmorphM /= H !map_polyC !map_polyX /= -conjc_real. +Qed. + +Lemma complex_root_conj_polyR (p : {poly R}) (z : C) : + root (toC p) z = root (toC p) z^*. +Proof. +by rewrite -complex_root_conj /= -map_poly_comp_id0 ?real_complex_conjc ?conjc0. +Qed. + +Local Open Scope complex_scope. +Lemma factor_complex_roots (z : C) : + toC ('X^2 + (1 *- 2 * Re z) *: 'X + (Re z ^+ 2 + Im z ^+ 2)%:P) = + ('X - z%:P) * ('X - (z^*)%:P). +Proof. +rewrite mulrBr !mulrBl opprB (addrC (z%:P * (z^*)%:P) _) addrA. +rewrite (mulrC _ (z^*)%:P) -[in RHS](addrA ('X * 'X) _) -expr2. +rewrite -(opprD (z%:P * 'X) ((z^*)%:P * 'X)). +rewrite -(mulrDl z%:P _ 'X) -(polyCD z z^*) -(polyCM z z^*) + -sqr_normc -re_conj normC_re_im mul_polyC + -(opprK (Re z ^+ 2 + Im z ^+ 2)%:P) map_poly_is_additive + -polyCN -mul_polyC map_polyC. +rewrite -(opprK ((1 *- 2 * Re z)%:P * 'X)) map_poly_is_additive map_polyXn + -(opprK (Re z ^+ 2 + Im z ^+ 2)%:C%:P) + -(polyCN (Re z ^+ 2 + Im z ^+ 2)%:C). +have H : (- (Re z ^+ 2 + Im z ^+ 2)%:C) = (- (Re z ^+ 2 + Im z ^+ 2))%:C. + by rewrite -!complexr0 -{2}oppr0. +rewrite H {H} -mulNr -(@polyCN _ (1 *- 2 * Re z)) mul_polyC map_polyZ + map_polyX mulNr opprK. +have H : 2%:R * (Re z)%:C = (2%:R * (Re z))%:C. + rewrite -!complexr0. + by simpc. +by rewrite H. +Qed. +Local Close Scope complex_scope. + +Lemma complex_root_div_poly_deg2 : forall (p : {poly R}) (z : C), + ((Im z) != 0) -> root (toC p) z -> + ('X^2 + (- 2%:R * (Re z)) *: 'X + ((Re z) ^+2 + (Im z)^+2)%:P) %| p. +Proof. +move=> p z Hz Hrootz. +have Hrootzbar : root (toC p) z^*. + by rewrite -complex_root_conj_polyR. +have /= Hp := (factor_complex_roots z). +rewrite -(dvdp_map (real_complex R)) /= Hp. +rewrite Gauss_dvdp. + apply/andP; split; by rewrite -root_factor_theorem. +apply: Pdiv.ClosedField.root_coprimep => x. +rewrite root_XsubC =>/eqP ->. clear x. +rewrite hornerXsubC im_conj eq_complex ReiNIm ImiRe /= !addr0 !mulr0 + subr0 add0r mul0r oppr0. +rewrite eqxx mulrI_eq0 ?negb_and. + apply/orP; by right. +apply/lregP. +by rewrite paddr_eq0 ?ler01 // negb_and oner_neq0. +Qed. + +Local Open Scope complex_scope. +Lemma real_root_div_poly_deg1 (p : {poly R}) (z : C) : + Im z = 0 -> root (toC p) z -> ('X - (Re z)%:P) %| p. +Proof. +move=>Himz Hroot. +rewrite root_factor_theorem (@complexE _ z) Himz mulr0 addr0 in Hroot. +rewrite -(dvdp_map (real_complex R)) /=. +have H : toC ('X - (Re z)%:P) = 'X - ((Re z)%:C)%:P. + by rewrite map_poly_is_additive map_polyC map_polyX. +by rewrite H. +Qed. +Local Close Scope complex_scope. + +(* Proposition 2.40 *) +Lemma normal_root_inB : forall (p : {poly R}), + p \is monic -> + (forall z : C, root (toC p) z -> inB z) -> p \is normal. +Proof. +move=> p Hpmonic. +move: {2}(size p) (leqnn (size p))=> n. +elim: n p Hpmonic=> [p Hpmonic Hpsize Hproot | n IH p Hpmonic Hpsize Hproots]. +(* size p <= 0 *) + rewrite size_poly_leq0 in Hpsize. + rewrite (eqP Hpsize) monicE lead_coef0 in Hpmonic. + by rewrite (eqP Hpsize) normalE polyseq0 /= -(oner_eq0 R) eq_sym. +(* size p <= n.+1 *) +case: (altP (size (toC p) =P 1%N)) => Hpsize2. + (* size p == 1 *) + rewrite monicE in Hpmonic. + rewrite /= size_map_poly_id0 in Hpsize2; + last by rewrite eq_sym negbT // lt_eqF // ltcR (eqP Hpmonic) ltr01. + have Hp := (size1_polyC (eq_leq (Hpsize2))). + rewrite Hp in Hpsize2. + rewrite Hp lead_coefE Hpsize2 -pred_Sn polyseqC in Hpmonic. + rewrite size_polyC in Hpsize2. + rewrite Hpsize2 /= in Hpmonic. + by rewrite Hp /= (eqP Hpmonic) normalE polyseqC oner_neq0 /= ltr01. +(* size p != 1 *) +move/closed_rootP : Hpsize2. +case=> x Hrootx. +case: (altP (Im x =P 0)) => Himx. +(* real root *) + have H := monicXsubC (Re x). + have Hp := real_root_div_poly_deg1 Himx Hrootx. + rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp. + rewrite (eqP Hp) normal_mulr //. + apply: IH => [ | | z Hz]. + + by rewrite monicE -(@lead_coef_Mmonic _ _ ('X - (Re x)%:P)) // + -(eqP Hp) -monicE. + - rewrite size_divp; last by apply: monic_neq0. + by rewrite size_XsubC leq_subLR addnC addn1. + + rewrite Hproots // (eqP Hp) rmorphM rootM. + apply/orP; by left. + rewrite monicXsubC_normal. + rewrite /inB in Hproots. + by have/andP := (Hproots x Hrootx); case => -> _. +(* pair of complex roots *) +have H : 'X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P \is monic. + by rewrite -(mul1r 'X^2) mul_polyC monicE lead_coefE polyseq_deg2 // oner_neq0. +have H2 : size ('X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P) = 3%N. + by rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 // oner_neq0. +have Hp := complex_root_div_poly_deg2 Himx Hrootx. +rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp. +rewrite (eqP Hp) normal_mulr //. + apply: IH => [ | | z Hz]. + + by rewrite monicE -(@lead_coef_Mmonic _ _ ('X^2 + (1 *- 2 * Re x) *: 'X + + (Re x ^+ 2 + Im x ^+ 2)%:P)) // -(eqP Hp) -monicE. + - rewrite size_divp; last by apply: monic_neq0. + by rewrite H2 leq_subLR addnC addn2 (@leq_trans n.+1). + + rewrite Hproots // (eqP Hp) rmorphM rootM. + apply/orP; by left. +by rewrite quad_monic_normal Hproots. +Qed. + +(* not sure if this lemma is really necessary *) +Lemma normal_red_0noroot : forall (p : {poly R}), p \is normal -> + root p 0 -> ~~(root (p %/ 'X^(\mu_0 p)) 0) && ((p %/ 'X^(\mu_0 p)) \is normal). +Proof. +move=> p Hpnormal Hproot0. +have Hpneq0 := (normal_neq0 Hpnormal). +apply/andP; split. +(* 0 is not root of p%/ 'X^(mu_0) *) + rewrite -(@addr0 _ 'X) -oppr0 -mu_gt0. + by rewrite -eqn0Ngt (@mu_div _ _ _ (\mu_0 p)) //= subnn. + rewrite divpN0. + by rewrite dvdp_leq // ?root_mu. + by rewrite -size_poly_gt0 size_exp_XsubC. +(* p %/ 'X^mu_0 is normal *) +have Hcoefs : forall k, ((p %/ 'X^(\mu_0 p))`_k = p`_(k + (\mu_0 p))). + have H := (root_mu p 0). + rewrite oppr0 addr0 Pdiv.IdomainMonic.dvdp_eq in H. + rewrite {3}(eqP H) => k {H}; rewrite coefMXn /=. + have H : ((k + \mu_0 p < \mu_0 p)%N = false). + by rewrite -{2}(add0n (\mu_0 p)) (@ltn_add2r). + by rewrite H addnK. + by apply: monicXn. +have Hsize : ((size (p %/ ('X^(\mu_0 p)))) = ((size p) - (\mu_0 p))%N). + rewrite size_divp. + by rewrite size_polyXn -pred_Sn. + by rewrite -size_poly_gt0 size_polyXn ltn0Sn. +have/normalP [Hp1 Hp2 Hp3 Hp4] := Hpnormal. +apply/normalP; split => [k | |k Hk |i ]. + + by rewrite Hcoefs Hp1. + + rewrite lead_coefE Hcoefs Hsize -subnS addnC addnBA. + by rewrite addnC subnS addnK Hp2. + by rewrite -(size_polyXn R (\mu_0 p)) dvdp_leq // -(addr0 'X) -oppr0 root_mu. + + by rewrite !Hcoefs (@addnC k.+1) addnS (@addnC k.-1) (@addnC k) -subn1 + addnBA // subn1 Hp3 // (ltn_trans Hk) // -{1}(add0n k) ltn_add2r mu_gt0. +rewrite Hcoefs => Hi j Hj1; rewrite Hsize => Hj2; +rewrite Hcoefs (@Hp4 (i + (\mu_0 p))%N) // ?ltn_add2r //. +by rewrite addnC -ltn_subRL -subn1 -subnDA addnC addn1 subnS. +Qed. + +End normal_polynomial. + +Arguments normal_seq {R}. +Arguments normal {R}. + +Section seqn0_and_properties. + +Variable R : ringType. + +(* sequence without 0's : filter (fun x => x != 0) s) *) +Definition seqn0 (s : seq R) := [seq x <- s | x != 0]. + +Lemma seqn0_as_mask (s : seq R) : + seqn0 s = mask (map (fun x => x != 0) s) s. +Proof. by rewrite /seqn0 filter_mask. Qed. + +Lemma seqn0_cons (s : seq R) (a : R) : (a != 0) -> + seqn0 (a :: s) = a :: (seqn0 s). +Proof. move=> Ha; by rewrite /= Ha. Qed. + +Lemma seqn0_size (s: seq R) : (s`_(size s).-1 != 0) -> + (0 < size (seqn0 s))%N. +Proof. +move=> Hs. +have Hssize : (0 < size s)%N. + case: s Hs => [ | ] //=. + by rewrite eqxx. +elim: s Hs Hssize => [|a] //=. +case=> [_ Ha _ | b l IHbl Hln Hablsize ] //=. + by rewrite Ha. +case Ha : (a != 0) => //. +by apply: IHbl. +Qed. + + +Definition all_neq0 := fun (s : seq R) => all (fun x => x != 0) s. + +Lemma all_neq0P (s : seq R) : + reflect (forall k, (k < size s)%N -> s`_k != 0) (all_neq0 s). +Proof. by apply/all_nthP. Qed. + +Lemma seqn0_all_neq0 (s : seq R) : all_neq0 (seqn0 s). +Proof. by apply: filter_all. Qed. + +Lemma seqn0_0 : forall (s : seq R), s`_0 != 0 -> (seqn0 s)`_0 = s`_0. +Proof. +case => [ | a l IHl] //. +by rewrite seqn0_as_mask /= IHl. +Qed. + +Lemma seqn0_n : forall (s : seq R), s`_(size s).-1 != 0 -> + (seqn0 s)`_(size (seqn0 s)).-1 = s`_(size s).-1. +Proof. +move=> s Hs. +have Hssize : (0 < size s)%N. + case: s Hs => //=. + by rewrite eqxx. +elim : s Hs Hssize => [| a] //. +case => [_ Ha _ | b l IHbl Hln Hablsize] //. + by rewrite /= Ha. +have H2 : (size [::a, b & l]).-1 = (size (b ::l)).-1.+1. + by rewrite prednK. +rewrite H2 /= -IHbl //. +case Ha : (a != 0) => //. +have H3 : ((size (a :: (if b != 0 then b :: seqn0 l else seqn0 l))).-1 + = (size (seqn0 (b :: l))).-1.+1). + by rewrite prednK // seqn0_size. +by rewrite H3. +Qed. + +End seqn0_and_properties. + +Section more_on_sequences. + +Variable R : rcfType. + +Lemma seqn0_size_2 (s : seq R) : + (s`_0 < 0) -> (0 < s`_(size s).-1) -> (1 < size (seqn0 s))%N. +Proof. +move=> Hs1 Hs2. +have Hssize : (0 < size s)%N. + case: s Hs1 Hs2 => [ | ] //=. + by rewrite ltxx. +case: s Hs1 Hs2 Hssize => [|a ] //. +case=> [Ha1 Ha2 _ | b l Ha Hln Hablsize] //. + have: false => //. + rewrite -(lt_asym 0 a). + by apply/andP. +rewrite seqn0_cons /=. + rewrite -(addn1 0) -(addn1 (size (seqn0 (b ::l)))) ltn_add2r seqn0_size //. + have H : (size [:: a, b & l]).-1 = (size (b :: l)).-1.+1. + by rewrite /=. + rewrite H lt_def in Hln. + by move/andP : Hln; case => -> _. +rewrite lt_def eq_sym in Ha. +by move/andP : Ha; case => ->. +Qed. + +Lemma normal_all_pos : forall (p : {poly R}), p \is normal -> + ~~(root p 0) -> all_pos p. +Proof. +move=> p Hpnormal H0noroot; apply/all_posP. +by apply: normal_0notroot_2. +Qed. + +Lemma all_pos_subseq : forall (s1 s2 : seq R), (all_pos s2) -> (subseq s1 s2) -> + (all_pos s1). +Proof. +move=> s1 s2 /allP Hs2 /mem_subseq Hsubseq; +by apply/allP=> y /Hsubseq /Hs2 Hy. +Qed. + +Definition increasing := fun (s : seq R) => + sorted (fun x y => x <= y) s. + +Lemma increasingP (s : seq R) : + reflect (forall k, (k < (size s).-1)%N -> s`_k <= s`_k.+1) + (increasing s). +Proof. +apply/(iffP idP) => [H k Hk | H]. + case: s H k Hk => [ | a ] // => l. + elim : l a => [ | b tl IHl a /andP Habtl] //. + case => [_ | n Hn] //=. + exact: (proj1 Habtl). + apply: (IHl b (proj2 Habtl)). + by rewrite -(ltn_add2r 1%N) !addn1 prednK. +case: s H => [ | a] => // => l. +elim : l a => [ | b l IHs a Hk] //. +apply/andP; split. + apply: (Hk 0%N) => //. +apply: (IHs b) => k Hkk. +by rewrite (Hk k.+1) // -(addn1 k) addnC -ltn_subRL subn1. +Qed. + +Lemma increasing_is_increasing3 : forall (s : seq R), (increasing s) -> + (forall k l, (k < (size s))%N -> + (l < (size s))%N -> (k <= l)%N -> s`_k <= s`_l). +Proof. +case=> [ | a ] // => l. +elim : l a => [a Hs k | b tl IHl a /andP Habtl k] [_ _ Hk | l] //. + + rewrite leqn0 in Hk; by rewrite (eqP Hk). + - rewrite leqn0 in Hk; by rewrite (eqP Hk). + + case : k => [Hk Hl Hkl| k Hk Hl Hkl]. + case : l Hl Hkl => [Hl Hkl |l Hl Hkl]. + exact: (proj1 Habtl). + apply: (@le_trans _ _ b). + exact: (proj1 Habtl). + apply: (IHl b (proj2 Habtl) 0%N l.+1) => //. + by apply: (IHl b (proj2 Habtl)). +Qed. + +Lemma subseq_incr (s1 s2 : seq R) : subseq s1 s2 -> + increasing s2 -> increasing s1. +Proof. +rewrite /increasing. +apply: subseq_sorted => //. +exact: le_trans. +Qed. + +Lemma changes_seq_incr_0 : forall (s : seq R), (0 < size s)%N -> + (increasing s) -> (all_neq0 s) -> + ((changes s == 0%N) = (0 < s`_0 * s`_((size s).-1))). +Proof. +elim => [ | a] //. +case => [_ _ _ /= Ha | b l IH Hsize Hincr Hneq0]. + by rewrite /= mulr0 addn0 -expr2 ltxx /= lt_def sqrf_eq0 sqr_ge0 Ha. +have/andP [] := Hneq0 => Ha Hblneq0. +have/andP [] := Hblneq0 => Hb Hlneq0. +have/andP [] := Hincr => Hab Hblincr. +rewrite /= addn_eq0 IH //=. +apply/idP/idP => [/andP [] H1 H2 | H]; case : (ltrgtP a 0) => Ha2. ++ by rewrite nmulr_lgt0 // -(@nmulr_rgt0 _ b) // lt_def eq_sym Hb /= + -(@nmulr_rge0 _ a) // leNgt -eqb0. +- by rewrite pmulr_lgt0 // -(@pmulr_rgt0 _ b) // lt_def Hb /= + -(@pmulr_rge0 _ a) // leNgt -eqb0. ++ by have/eqP := Ha. +- have Hbl : ((b :: l)`_(size l) < 0). + by rewrite -(nmulr_rgt0 _ Ha2). + rewrite eqb0 -leNgt nmulr_rge0 // nmulr_lgt0 //. + rewrite le_eqVlt (negbTE Hb) /= andbb (le_lt_trans _ Hbl) //. + by apply: (@increasing_is_increasing3 _ Hincr 1%N (size [::a, b & l]).-1). +- have Hbl : (0 < (b :: l)`_(size l)). + by rewrite -(pmulr_rgt0 _ Ha2). + rewrite eqb0 -leNgt pmulr_rge0 // pmulr_lgt0 //. + by rewrite le_eqVlt eq_sym (negbTE Hb) /= andbb (lt_le_trans Ha2 Hab). ++ by have/eqP := Ha. +Qed. + +Lemma changes_seq_incr_1 : forall (s : seq R), (1%N < size s)%N -> + (increasing s) -> (all_neq0 s) -> + ((changes s) == 1%N) = (s`_0 < 0) && (0 < s`_((size s).-1)). +Proof. +elim=> [ |a ] //. +case=> [_ _ _ _ | b] //. +case=> [_ _ /andP [] Hab _ /and3P [] Ha Hb _ |c l IH Hsize Hincr Hneq0] //=. + rewrite mulr0 addn0 ltxx /= addn0 eqb1. + case: (ltrP a 0) => Ha2 /=; first by rewrite nmulr_rlt0. + by rewrite ltNge mulr_ge0 // (le_trans Ha2). +have/andP [] := Hneq0 => Ha Hbclneq0. +have/andP [] := Hbclneq0 => Hb Hclneq0. +have/andP [] := Hclneq0 => Hc Hlneq0. +have/andP [] := Hincr => Hab Hbclincr. +have/andP [] := Hbclincr => Hbc Hclincr. +apply/idP/idP; case : (ltrP (a * b) 0) => Hab2 /=. ++case : (ltrgtP a 0) => Ha2 H /=. + have Hb2 : (0 < b). + rewrite -(nmulr_rlt0 _ Ha2) //. + rewrite (lt_le_trans Hb2) //. + by apply: (@increasing_is_increasing3 _ Hincr 1%N (size [::a, b, c & l]).-1). + rewrite -(lt_asym 0 b); apply/andP; split. + by rewrite (lt_le_trans _ Hab). + by rewrite -(pmulr_rlt0 _ Ha2). + by have/eqP := Ha. +-rewrite add0n IH //. + case/andP => /= Hb2 Hbl; apply/andP; split => //. + by rewrite (le_lt_trans _ Hb2). ++case/andP => H1 H2. + rewrite addnC addn1. + apply/eqP; apply: eq_S; apply/eqP. + by rewrite (changes_seq_incr_0 (s:=[::b, c & l])) //= pmulr_rgt0 // + -(nmulr_rlt0 _ H1). +-case/andP => H1 H2. + rewrite add0n IH //. + apply/andP; split => //=. + rewrite -(nmulr_rgt0 _ H1) lt_def. + apply/andP; split => //. + by apply: mulf_neq0. +Qed. + +Lemma changes_seq_incr : forall (s : seq R), (increasing s) -> (all_neq0 s) -> + (changes s == 1%N) || (changes s == 0%N). +Proof. +case=> [ |a ] //. +case => [_ Ha |b l Hincr Hneq0] //. + apply/orP; right. + rewrite changes_seq_incr_0 //= -expr2 lt_def. + move/andP : Ha; case => Ha _. + by rewrite sqrf_eq0 Ha /= sqr_ge0. +have/andP [] := Hneq0 => Ha Hblneq0. +have/andP [] := Hincr => Hab Hblincr. +have Hlast := ((all_neq0P [::a, b & l] Hneq0) ((size [::a, b & l]).-1) (leqnn _)). +case : (ltrgtP 0 (a * ([::a, b & l]`_(size [::a, b & l]).-1))) => H. ++apply/orP; right. + by rewrite changes_seq_incr_0. +-apply/orP; left. + rewrite changes_seq_incr_1 //=. + have H2 := (@increasing_is_increasing3 _ Hincr 0%N (size [:: a, b & l]).-1). + case: (ltrgtP a 0) => Ha2 /=. + by rewrite -(nmulr_rlt0 _ Ha2). + rewrite -(lt_asym 0 [:: a, b & l]`_(size [::a, b & l]).-1). + apply/andP; split. + by rewrite (lt_le_trans Ha2) // H2. + by rewrite -(pmulr_rlt0 _ Ha2). + by have/eqP := Ha. ++move/eqP : H; rewrite eq_sym => /eqP H. + by have/eqP := (mulf_neq0 Ha Hlast). +Qed. + +Lemma changes_size3 : forall (s : seq R), (all_neq0 s) -> (size s = 3)%N -> + (s`_0 < 0) -> (0 < s`_2) -> changes s = 1%N. +Proof. +case => [ | a [| b [| c]]] //. +case => [Hallneq Hsize Ha Hc | ] //=. +rewrite mulr0 ltxx !addn0. +case : (ltrP (a * b) 0) => Hab. + rewrite addnC addn1; apply: eq_S. + apply/eqP. + by rewrite eqb0 -leNgt pmulr_lge0 // -(@nmulr_lle0 _ a b) // ltW // mulrC. +apply/eqP. +rewrite add0n eqb1 pmulr_llt0 // -(@nmulr_rgt0 _ a) // lt_def Hab andbT. +move/and3P : Hallneq => [] Ha2 Hb2 Hc2. +by rewrite mulf_neq0. +Qed. + +(* sequence without first and last element *) +Definition mid := fun (s : seq R) => (drop 1 (take (size s).-1 s)). + +Lemma mid_2 : forall (s : seq R), mid s = (take (size s).-2 (drop 1 s)). +Proof. +elim=> [ |a l IHl ] //=. +case: l IHl => [ |b l IHbl ] //. +rewrite drop0 /mid. +have Hsize : ((size [::a, b & l]).-1 = (size (b :: l)).-1.+1). + by rewrite prednK. +by rewrite Hsize /= drop0. +Qed. + +Lemma mid_size : forall (s : seq R), size (mid s) = (size s).-2. +Proof. +elim => [|a l IHl] => //=. +by rewrite /mid size_drop size_takel //= subn1. +Qed. + +Lemma mid_nil : forall (s : seq R), (mid s == [::]) = + ((s == [:: s`_0 ; s`_1]) || (s == [:: s`_0]) || (s == [::])). +Proof. +case=> [| a [| b]] //=. + by rewrite /mid /= orbF !eqxx orbT. +case=> [ |c l] //=. + by rewrite /mid /= orbF !eqxx orTb. +by rewrite /mid /= orbF -eqseqE /= !andbF orbF. +Qed. + +Lemma mid_cons (s : seq R) (a : R) : + mid (a :: s) = take (size s).-1 s. +Proof. by rewrite mid_2 /= drop0. Qed. + +Lemma mid_coef_1 (s : seq R) k : (k < size (mid s))%N -> + (mid s)`_k = s`_k.+1. +Proof. +move=> Hk. +rewrite /mid nth_drop addnC addn1 nth_take //. +by rewrite -(@addn1 k) addnC -ltn_subRL subn1 -mid_size. +Qed. + +Lemma mid_coef_2 (s : seq R) k: (0%N < k)%N -> (k < (size s).-1)%N -> + (mid s)`_k.-1 = s`_k. +Proof. +move=> Hk1 Hk2. +by rewrite mid_coef_1 prednK // mid_size -(@prednK k) // -(@ltn_add2r 1%N) + !addn1 !prednK // (@ltn_trans k). +Qed. + +Lemma drop1_seqn0_C : forall (s : seq R), (s`_0 != 0) -> + drop 1 (seqn0 s) = seqn0 (drop 1 s). +Proof. +case=> [ | a l Ha] //=. +by rewrite Ha /= !drop0. +Qed. + +Lemma take1_seqn0_C : forall (s : seq R), (s`_(size s).-1 != 0) -> + take (size (seqn0 s)).-1 (seqn0 s) = seqn0 (take (size s).-1 s). +Proof. +elim=> [ | a] //. +case=> [_ Ha | b l IHbl Hln] //. + by rewrite /= Ha. +have H : (size [::a, b & l]).-1 = (size (b :: l)).-1.+1. + by rewrite prednK. +rewrite H take_cons. +case Ha : (a != 0). + rewrite /= Ha -IHbl => //. + have H2 : (size (a :: (if b != 0 then b :: seqn0 l else seqn0 l))).-1 = + (size (seqn0 (b ::l))).-1.+1. + rewrite prednK // (@seqn0_size _ (b :: l)) //. + by rewrite H2 take_cons. +by rewrite /= Ha -IHbl. +Qed. + +Lemma mid_seqn0_C : forall (s : seq R), (s`_0 != 0) -> (s`_(size s).-1 != 0) -> + mid (seqn0 s) = seqn0 (mid s). +Proof. +elim => [ |a] //. +case => [_ Ha _ |b l Hbl Ha Hln] //=. + by rewrite Ha /mid /=. +rewrite Ha /mid -drop1_seqn0_C // -take1_seqn0_C //. +have H : ((size (a :: (if b != 0 then b :: seqn0 l else seqn0 l))).-1 = + (size (seqn0 (b :: l))).-1.+1). + by rewrite prednK // seqn0_size. +by rewrite H take_cons /= drop0 Ha H take_cons /= drop0. +Qed. + +Lemma changes_take : forall (s : seq R) (a b : R), (s != [::]) -> + (all_neq0 [::a, b & s]) -> + (changes (take (size (b :: s)) ([::a, b & s])) = + ((a * b < 0)%R + changes (take (size s) (b :: s)))%N). +Proof. by case. Qed. + +Lemma changes_decomp_sizegt2 : forall (s : seq R), (all_neq0 s) -> + (2 < size s)%N -> + changes s = + ((s`_0 * s`_1 < 0)%R + + (changes (mid s))%R + + (s`_((size s).-2) * s`_((size s).-1) < 0)%R)%N. +Proof. +case=> [|a [| b l]] //. +elim: l a b => [ |c l] //. +case: l c => [c _ a b Habcneq0 _| d l c IHdl a b /andP [] Ha Hneq0 Hsize ]. + by rewrite /= !mulr0 !ltxx !addn0. +have H1 : (changes [:: a, b, c, d & l] = ((a * b < 0)%R + + changes [:: b, c, d & l])%N). + by done. +rewrite H1 (IHdl b c) // -addnA -addnA addnC (@addnC (a * b < 0)%R). +apply/eqP. +rewrite eqn_add2r addnA eqn_add2r (@mid_cons _ a). +have H2 : (size [:: b, c, d & l]).-1 = size [::c, d & l]. + by done. +by rewrite H2 (@changes_take _ b c). +Qed. + +Lemma changes_decomp_size2 : forall (s : seq R), (all_neq0 s) -> + (size s == 2)%N -> + changes s = (s`_0 * s`_1 < 0)%R. +Proof. +case => [ |a [| b [_ _ |]]] //. +by rewrite /= mulr0 ltxx !addn0. +Qed. + +(* pointwise multiplication of two lists *) +Definition seqmul := + (fun s1 s2 : seq R => map (fun x : R * R => x.1 * x.2) (zip s1 s2)). + +Lemma seqmul_size (s1 s2 : seq R) : + size (seqmul s1 s2) = minn (size s1) (size s2). +Proof. +by rewrite /seqmul size_map size_zip. +Qed. + +Lemma seqmul_coef (s1 s2 : seq R) k : (k < minn (size s1) (size s2))%N -> + (seqmul s1 s2)`_k = s1`_k * s2`_k. +Proof. +move=> Hk. +rewrite (nth_map 0); last by rewrite size_zip. +by rewrite nth_zip_cond size_zip Hk /=. +Qed. + +Lemma zip_nil_1 : forall (s : seq R), + zip (@nil R) s = [::]. +Proof. by case. Qed. + +Lemma zip_nil_2 : forall (s : seq R), + zip s (@nil R) = [::]. +Proof. by case. Qed. + +Lemma mask_zip : forall (b : bitseq) (s1 s2 : seq R), + mask b (zip s1 s2) = zip (mask b s1) (mask b s2). +Proof. +elim => [ | a l IHl] //. +case => [s2 |x s1 ] //. + by rewrite /= !zip_nil_1. +case=> [ |y s2 /=] //. + by rewrite zip_nil_2 !mask0 zip_nil_2. +case Ha : a => //. +by rewrite IHl. +Qed. + +Lemma mask_seqmul (b : bitseq) (s1 s2 : seq R) : + mask b (seqmul s1 s2) = seqmul (mask b s1) (mask b s2). +Proof. by rewrite -map_mask mask_zip. Qed. + +Lemma seqmul0 (s : seq R) : seqmul [::] s = [::]. +Proof. by rewrite /seqmul zip_nil_1. Qed. + +Lemma seqmul_cons (s1 s2 : seq R) (a b : R) : + seqmul (a::s1) (b::s2) = (a * b) :: (seqmul s1 s2). +Proof. by rewrite /seqmul. Qed. + +Lemma changes_mult : forall (s c : seq R), all_pos c -> (size s = size c) -> + changes (seqmul s c) = changes s. +Proof. +elim=> [c Hc Hsize |a1 s IHs]. + by rewrite seqmul0. +case=> [ |b1 l Hblpos Hsize] //. +rewrite seqmul_cons /=. +case: s IHs Hsize => [IH Hsize|a2 s IHa2s Hsize]. + by rewrite seqmul0 /= !addn0 !mulr0. +case : l Hblpos Hsize => [ | b2 l /andP [] Hb1 Hb2lpos Hsize] //. +have/andP [Hb2 Hlpos] := Hb2lpos. +rewrite !seqmul_cons -(@IHa2s (b2::l)) //. + by rewrite seqmul_cons -(@pmulr_llt0 _ b1 (a1 * head 0 (a2 :: s ))) // + -(@mulrA _ a1 _ b1) (@mulrC _ (head 0 (a2::s)) b1) (@mulrA _ a1 b1 _) + -(@pmulr_llt0 _ b2 (a1 * b1 * head 0 (a2 :: s ))) // + -!mulrA (@mulrC _ _ b2). +by apply: eq_add_S. +Qed. + +Lemma map_seqmul : forall (s c : seq R), all_pos c -> (size s = size c) -> + map (fun x => x != 0) (seqmul s c) = map (fun x => x != 0) s. +Proof. +elim=> [c Hc Hsize |a s IHs]. + by rewrite seqmul0. +case=> [ | b l Hblpos Hsize] //. +have/andP [Hb Hlpos] := Hblpos. +rewrite seqmul_cons !map_cons mulIr_eq0. + rewrite IHs //. + by apply: eq_add_S. +apply/rregP. +rewrite lt0r in Hb. +by case/andP : Hb. +Qed. + +End more_on_sequences. + +Arguments all_pos {R}. +Arguments mid {R}. +Arguments seqn0 {R}. +Arguments all_neq0 {R}. +Arguments increasing {R}. + +(*****************************) + +Section Proof_Prop_2_44. + +Variables (R : rcfType) (a : R) (p : {poly R}). + +Variables (Ha : 0 < a) (Hpnormal : p \is normal) (Hp0noroot : ~~(root p 0)). + +Local Notation q := (p * ('X - a%:P)). + +Local Notation d := (size q). + +Lemma q_0 : q`_0 = -a * p`_0. +Proof. +rewrite mulrDr coefD -polyCN (mulrC p ((-a)%:P)) mul_polyC coefZ polyseqMX. + by rewrite add0r. +by apply: normal_neq0. +Qed. + +Lemma q_0_lt0 : q`_0 < 0. +Proof. +rewrite q_0 // mulNr oppr_lt0 pmulr_rgt0 //. +case : (ltnP 1%N (size p)) => Hpsize. + apply: (@normal_0notroot _ _ Hpnormal Hp0noroot). + rewrite -(ltn_add2r 1) !addn1 prednK ?Hpsize //. + by apply: (@ltn_trans 1%N). +rewrite normal_size_le1 // in Hpsize. +rewrite (pred_Sn 0) -(eqP Hpsize) -lead_coefE. +by have/normalP [_ H _ _] := Hpnormal. +Qed. + +Lemma q_0_neq0 : q`_0 != 0. +Proof. +by rewrite negbT // lt_eqF // q_0_lt0. +Qed. + +Lemma q_size : d = (size p).+1 . +Proof. +have Hpneq0 := (normal_neq0 Hpnormal). +rewrite mulrDr size_addl. + by rewrite size_mulX. +rewrite mulrC -polyCN mul_polyC size_mulX //. +by rewrite (@leq_ltn_trans (size p)) // size_scale_leq. +Qed. + +Lemma p_size : size p = d.-1. +Proof. +by rewrite (@pred_Sn (size p)) q_size. +Qed. + +Lemma q_n : q`_d.-1 = p`_(d.-2). +Proof. +rewrite -p_size mulrDr coefD -polyCN (mulrC p ((-a)%:P)) mul_polyC coefZ. +rewrite coefMX. +have H : (((size p) == 0%N) = false). + rewrite size_poly_eq0. + apply/eqP/eqP. + by apply: normal_neq0. +by rewrite H /= {H} -{3}(coefK p) coef_poly ltnn mulr0 addr0. +Qed. + +Lemma q_n_gt0 : (0 < q`_d.-1). +Proof. +rewrite q_n -p_size // -lead_coefE. +by have/normalP [_ H _ _] := Hpnormal. +Qed. + +Lemma q_n_neq0 : q`_d.-1 != 0. +Proof. +by rewrite negbT // gt_eqF // q_n_gt0. +Qed. + +Lemma q_k k : (0%N < k)%N -> (k < d.-1)%N -> + q`_k = (p`_k.-1/p`_k - a) * p`_k. +Proof. +move=> Hk1 Hk2. +rewrite mulrDr coefD -polyCN (mulrC p ((-a)%:P)) mul_polyC coefZ coefMX. +have H : ((k==0%N) = false). + apply/eqP/eqP. + by rewrite -lt0n. +by rewrite H /= mulrDl divrK // unitf_gt0 // normal_0notroot_2 // p_size. +Qed. + +Lemma seqn0q_size : (1 < size (seqn0 q))%N. +Proof. +by rewrite seqn0_size_2 // ?q_0_lt0 // ?q_n_gt0. +Qed. + +Definition spseq := map (fun x : R * R => x.1 / x.2 - a) (zip p (drop 1 p)). + +Lemma spseq_size : size spseq = d.-2. +Proof. +by rewrite /spseq size_map size_zip size_drop subn1 -p_size minnE subKn + // leq_pred. +Qed. + +Lemma spseq_coef k : (k < d.-2)%N -> spseq`_k = p`_k / p`_k.+1 - a. +Proof. +move=> Hk. +have H : minn (size p) ((size p) - 1%N) = ((size p) - 1%N)%N. + rewrite minnE subKn // subn1 -{2}(@prednK (size p)). + by rewrite leqnSn. + by rewrite ltnNge leqn0 size_poly_eq0 normal_neq0. +rewrite /spseq (@nth_map _ 0). + rewrite nth_zip_cond /= size_zip !size_drop H subn1 p_size Hk /=. + by rewrite !nth_drop (addnC 1%N) addn1. +by rewrite size_zip !size_drop H subn1 p_size. +Qed. + +Lemma spseq_increasing : increasing spseq. +Proof. +have/normalP [_ _ H3 _] := Hpnormal. +apply/increasingP => k Hk. +rewrite spseq_size in Hk. +rewrite (@spseq_coef k) //. + rewrite (@spseq_coef k.+1) //. + rewrite lerB // ler_pdivrMr. + rewrite mulrC mulrA ler_pdivlMr. + by rewrite -expr2 (H3 k.+1). + rewrite (normal_0notroot_2 Hpnormal Hp0noroot) //. + by rewrite -(@addn2 k) addnC -ltn_subRL p_size subn2. + rewrite (normal_0notroot Hpnormal Hp0noroot) //. + by rewrite -(@addn1 k) addnC -ltn_subRL p_size -subn2 + -subnDA addnC subnDA subn2 subn1. + by rewrite -(@addn1 k) addnC -ltn_subRL -subn2 + -subnDA addnC subnDA subn2 subn1. +by rewrite (leq_trans Hk) // -(@subn2 (size q)) -subn1 leq_subLR addnC addn1. +Qed. + +(* the middle coefficients of q as a product *) +Lemma seqmul_spseq_dropp : mid q = seqmul spseq (drop 1 p). +Proof. +apply: (@eq_from_nth _ 0) => [ | k Hk]. + by rewrite mid_size seqmul_size spseq_size size_drop p_size subn1 minnE subKn. +rewrite mid_coef_1 // q_k //. + rewrite seqmul_coef. + by rewrite nth_drop addnC addn1 spseq_coef // -mid_size. + by rewrite spseq_size size_drop p_size subn1 minnE subKn // -mid_size. +by rewrite -(@addn1 k) addnC -ltn_subRL subn1 -mid_size. +Qed. + +Lemma all_pos_dropp : all_pos (drop 1 p). +Proof. +apply/all_posP => k Hk. +rewrite nth_drop addnC addn1. +apply/all_posP. + by apply: normal_all_pos. +rewrite size_drop in Hk. +by rewrite -(@addn1 k) addnC -ltn_subRL. +Qed. + +(* (mid q)`_k = 0 iff spseq`_k = 0 *) +Lemma map_midq_spseq : +(map (fun x => x != 0) (mid q)) = map (fun x => x != 0) spseq. +Proof. +rewrite seqmul_spseq_dropp map_seqmul // ?all_pos_dropp //. +by rewrite spseq_size size_drop p_size subn1. +Qed. + +Lemma spseq_seqn0 : + (mask (map (fun x => x != 0) (mid q)) spseq) = seqn0 spseq. +Proof. +by rewrite seqn0_as_mask map_midq_spseq. +Qed. + +(* the middle coefficients of q without the 0's are as well a product *) +Lemma mid_seqn0q_decomp : + mid (seqn0 q) = + seqmul (seqn0 spseq) + (mask (map (fun x => x != 0) (mid q)) (drop 1 p)). +Proof. +by rewrite mid_seqn0_C ?q_0_neq0 // ?q_n_neq0 // + {1}seqmul_spseq_dropp {1}seqn0_as_mask mask_seqmul -spseq_seqn0 + seqmul_spseq_dropp. +Qed. + +Lemma mid_seqn0q_size : + size (mid (seqn0 q)) = size (seqn0 spseq). +Proof. +by rewrite mid_seqn0_C ?q_0_neq0 // ?q_n_neq0 // !seqn0_as_mask + !size_mask ?size_map // map_midq_spseq. +Qed. + +Lemma size_seqn0spseq_maskdropp : size (seqn0 spseq) = + size (mask [seq x != 0 | x <- mid q] (drop 1 p)). +Proof. +rewrite -mid_seqn0q_size mid_seqn0_C ?q_0_neq0 // ?q_n_neq0 // + seqn0_as_mask !size_mask //. + by rewrite size_map. +by rewrite size_map size_drop mid_size p_size subn1. +Qed. + +Lemma minn_seqn0spseq_maskdropp : (minn (size (seqn0 spseq)) + (size (mask [seq x != 0 | x <- mid (R:=R) q] (drop 1 p)))) = + (size (seqn0 spseq)). +Proof. +by rewrite -size_seqn0spseq_maskdropp minnE subKn. +Qed. + +(* this is increasing since spseq is increasing *) +Lemma subspseq_increasing : increasing (seqn0 spseq). +Proof. +by rewrite (@subseq_incr R _ spseq) // ?filter_subseq // ?spseq_increasing. +Qed. + +(* this is all positive because p is all positive *) +Lemma subp_all_pos : all_pos (mask (map (fun x => x != 0) (mid q)) (drop 1 p)). +Proof. +rewrite (@all_pos_subseq R _ (drop 1 p)) // ?all_pos_dropp//. +apply/subseqP. +exists [seq x != 0 | x <- mid (R:=R) q] => //. +by rewrite size_map mid_size size_drop p_size subn1. +Qed. + +Lemma seqn0q_1 : (1 < (size (seqn0 q)).-1)%N -> + (seqn0 q)`_1 = (mid (seqn0 q))`_0. +Proof. +by move=> Hk; rewrite -{1}[(seqn0 q)`_1]mid_coef_2. +Qed. + +Lemma seqn0q_n : (0 < (size (seqn0 q)).-2)%N -> + (seqn0 q)`_(size (seqn0 q)).-2 = + (mid (seqn0 q))`_((size (mid (seqn0 q))).-1)%N. +Proof. +move=> Hsize_2. +have Hsize_1 : (0 < (size (seqn0 q)).-1)%N. + rewrite -subn1 ltn_subRL addn0 in Hsize_2. + by rewrite (ltn_trans _ Hsize_2). +have Hsize : (0 < size (seqn0 q))%N. + rewrite -subn1 ltn_subRL addn0 in Hsize_1. + by rewrite (ltn_trans _ Hsize_1). +rewrite mid_coef_2 mid_size //. +by rewrite -(subn1 (size (seqn0 q))) ltn_subRL addnC addn1 subn1 prednK // + {2}(pred_Sn (size (seqn0 q))) -(subn1 (size (seqn0 q)).+1) ltn_subRL + addnC addn1 prednK. +Qed. + +(* Proposition 2.44 *) +Lemma normal_changes : changes (seqn0 q) = 1%N. +Proof. +case : (ltngtP 3 (size (seqn0 q))) => Hsizeseqn0q. +(* 3 < size (seqn0 q) *) + have Hincreasing1 := spseq_increasing; + have Hincreasing2 := subspseq_increasing; + have Hallpos := (subp_all_pos); + have Hseqn0q := (seqn0_all_neq0 q); + have Hseqn0spseq := (seqn0_all_neq0 spseq); + have Hqsize := q_size; + have Hqsize2 := p_size; + have Hsizemidq := mid_seqn0q_size; + have Hsizespseq := size_seqn0spseq_maskdropp; + have Hqn1 := q_n_gt0; + have Hqn2 := q_n_neq0; + have Hq01 := q_0_lt0; + have Hq02 := q_0_neq0. + have H_1 : (0%N < (size (seqn0 q)).-1)%N. + by rewrite -(ltn_add2r 1%N) !addn1 prednK (ltn_trans _ Hsizeseqn0q). + have H_2 : (0%N < (size (seqn0 q)).-2)%N. + by rewrite -(ltn_add2r 2) !addn2 prednK // prednK (ltn_trans _ Hsizeseqn0q). + rewrite changes_decomp_sizegt2 //; last by rewrite (ltn_trans _ Hsizeseqn0q). + rewrite mid_seqn0q_decomp changes_mult // seqn0_0 // seqn0q_1 //. + rewrite {1}mid_seqn0q_decomp seqmul_coef. + rewrite seqn0_n // seqn0q_n // {1}mid_seqn0q_decomp seqmul_coef. + have H_3 : (0 < size (seqn0 spseq))%N. + by rewrite -mid_seqn0q_size mid_size. + have H_4 : (1 < size (seqn0 spseq))%N. + by rewrite -mid_seqn0q_size mid_size -subn2 ltn_subRL addn1. + case/orP : (changes_seq_incr Hincreasing2 Hseqn0spseq) => Hchanges. + (* one change in mid q *) + rewrite (eqP Hchanges). + rewrite changes_seq_incr_1 // in Hchanges. + move/andP : Hchanges => [] H0 H1. + have H2: (q`_0 * + ((seqn0 spseq)`_0 * + (mask [seq x != 0 | x <- mid q] (drop 1 p))`_0) < 0) = false. + apply: negbTE. + rewrite -leNgt nmulr_rge0 // nmulr_rle0 // ltW //. + apply/all_posP => //. + by rewrite -Hsizespseq -Hsizemidq mid_size. + rewrite H2 mid_seqn0q_size. + have H3 : ((seqn0 spseq)`_(size (seqn0 spseq)).-1 * + (mask [seq x != 0 | x <- mid q] (drop 1 p))`_ + (size (seqn0 spseq)).-1 * q`_(size q).-1 < 0) = false. + apply: negbTE. + rewrite -leNgt mulrC pmulr_lge0 ?ltW // pmulr_lgt0 //. + apply/all_posP => //. + rewrite -Hsizespseq -Hsizemidq mid_size + -{2}(subn2 (size (seqn0 q))) ltn_subRL + addnC addn2 prednK // prednK //. + by rewrite {2}(pred_Sn (size (seqn0 q))) + -(subn1 (size (seqn0 q)).+1) ltn_subRL + addnC addn1 prednK // (ltn_trans _ Hsizeseqn0q). + by rewrite H3. + (* no change in mid q *) + rewrite (eqP Hchanges). + rewrite changes_seq_incr_0 // in Hchanges. + case : (ltrgtP 0 (seqn0 spseq)`_0) => Hspseqn0_0. + (* first of spseq pos *) + have H1 : ((q`_0 * + ((seqn0 spseq)`_0 * + (mask [seq x != 0 | x <- mid q] (drop 1 p))`_0) < 0) = true). + apply/eqP; rewrite eqb_id. + rewrite nmulr_rlt0 // mulrC pmulr_lgt0 //. + apply/all_posP => //. + by rewrite -Hsizespseq -Hsizemidq mid_size. + rewrite H1 mid_seqn0q_size. + have H2 : (0 < (seqn0 spseq)`_(size (seqn0 spseq)).-1). + by rewrite -(@pmulr_lgt0 _ (seqn0 spseq)`_0) // mulrC. + have H3 : ((seqn0 spseq)`_(size (seqn0 spseq)).-1 * + (mask [seq x != 0 | x <- mid q] (drop 1 p))`_ + (size (seqn0 spseq)).-1 * q`_(size q).-1 < 0) = false. + apply: negbTE. + rewrite -leNgt mulrC pmulr_lge0 ?ltW // pmulr_lgt0 //. + apply/all_posP => //. + rewrite -Hsizespseq -Hsizemidq mid_size + -{2}(subn2 (size (seqn0 q))) ltn_subRL + addnC addn2 prednK // prednK //. + by rewrite {2}(pred_Sn (size (seqn0 q))) + -(subn1 (size (seqn0 q)).+1) ltn_subRL + addnC addn1 prednK // (ltn_trans _ Hsizeseqn0q). + by rewrite H3. + (* first of spseq neg *) + have H1 : ((q`_0 * + ((seqn0 spseq)`_0 * + (mask [seq x != 0 | x <- mid q] (drop 1 p))`_0) < 0) = false). + apply: negbTE. + rewrite -leNgt nmulr_lge0 ?ltW // nmulr_rlt0 //. + apply/all_posP => //. + by rewrite -Hsizespseq -Hsizemidq mid_size. + rewrite H1. + have H2 : ((seqn0 spseq)`_(size (mid (seqn0 q))).-1 < 0). + by rewrite Hsizemidq -(@nmulr_rgt0 _ (seqn0 spseq)`_0). + have H3 : (((seqn0 spseq)`_(size (mid (seqn0 q))).-1 * + (mask [seq x != 0 | x <- mid q] (drop 1 p))`_ + (size (mid (seqn0 q))).-1 * q`_(size q).-1 < 0) = true). + apply/eqP; rewrite eqb_id nmulr_rlt0 // nmulr_rlt0 //. + apply/all_posP => //. + rewrite -Hsizespseq -Hsizemidq mid_size + -{2}(subn2 (size (seqn0 q))) ltn_subRL + addnC addn2 prednK // prednK //. + by rewrite {2}(pred_Sn (size (seqn0 q))) + -(subn1 (size (seqn0 q)).+1) ltn_subRL + addnC addn1 prednK // (ltn_trans _ Hsizeseqn0q). + by rewrite H3. + (* impossible *) + have := ((all_neq0P _ Hseqn0spseq) 0%N H_3). + rewrite eq_sym => H_5. + by have/eqP := H_5. + by rewrite -Hsizespseq -Hsizemidq mid_size minnE subKn // + -(ltn_add2r 3) !addn3 prednK. + by rewrite -Hsizespseq -Hsizemidq minnE subKn // mid_size //. + by rewrite -(ltn_add2r 1%N) !addn1 prednK // (ltn_trans _ Hsizeseqn0q). +(* size (seqn0 q) == 2 *) +have Hsizeseqn0q2 : (size (seqn0 q) == 2%N). + by rewrite eqn_leq -ltnS Hsizeseqn0q /= seqn0q_size. +rewrite changes_decomp_size2 // ?seqn0_all_neq0 //. +rewrite seqn0_0 ?q_0_neq0 // {1}(@pred_Sn 1) -(eqP Hsizeseqn0q2) + seqn0_n ?q_n_neq0 //. +apply/eqP. +by rewrite eqb1 pmulr_llt0 ?q_0_lt0 // ?q_n_gt0. +(* size (seqn0 q) = 3*) +rewrite changes_size3 // ?seqn0_all_neq0 //. + by rewrite seqn0_0 ?q_0_lt0 // q_0_neq0. +by rewrite (@pred_Sn 2) Hsizeseqn0q seqn0_n ?q_n_gt0 // q_n_neq0. +Qed. + +End Proof_Prop_2_44. diff --git a/theories/preliminaries.v b/theories/preliminaries.v new file mode 100644 index 0000000..a2ff380 --- /dev/null +++ b/theories/preliminaries.v @@ -0,0 +1,241 @@ +From elpi Require Import elpi. + +#[projections(primitive)] Record r := { fst : nat -> nat; snd : bool }. +Axiom t : r. +Elpi Command test. +Elpi Query lp:{{ + coq.say "quotation for primitive fst t" {{ t.(fst) 3 }}, + coq.say "quotation for compat fst t" {{ fst t 3 }}, + coq.locate "r" (indt I), + coq.env.projections I [some P1,some P2], + coq.say "compatibility constants" P1 P2, + coq.env.primitive-projections I [some (pr Q1 N1), some (pr Q2 N2)], + coq.say "fst primproj" Q1 N1, + coq.say "snd primproj" Q2 N2 +}}. + +From HB Require Import structures. +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import classical_sets reals Rstruct. +From infotheo Require Import convex. + +Import GRing.Theory Num.Theory convex. +Local Open Scope ring_scope. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* TODO: move to mathcomp ? *) +Lemma enum_rank_index {T : finType} i : + nat_of_ord (enum_rank i) = index i (enum T). +Proof. +rewrite /enum_rank [enum_rank_in]unlock /insubd /odflt /oapp insubT//. +by rewrite cardE index_mem mem_enum. +Qed. + +(* TODO: do we keep this as more newcomer friendly than having to look + deep into the library ? *) +Lemma enum_prodE {T1 T2 : finType} : enum {: T1 * T2} = prod_enum T1 T2. +Proof. +by rewrite /enum_mem unlock /= /prod_enum -(@eq_filter _ predT) ?filter_predT. +Qed. + +Lemma index_allpairs {T1 T2: eqType} (s1: seq T1) (s2: seq T2) x1 x2 : + x1 \in s1 -> x2 \in s2 -> + index (x1, x2) [seq (x1, x2) | x1 <- s1, x2 <- s2] = + ((index x1 s1) * (size s2) + index x2 s2)%N. +Proof. +move=>ins1 ins2. +elim: s1 ins1=>//= a s1 IHs1 ins1. (* HERE*) +rewrite index_cat. +case ax: (a == x1). + move: ax=>/eqP ax; subst a; rewrite /muln /muln_rec /addn /addn_rec /=. + move: ins2=>/(map_f (fun x => (x1, x))) ->. + by apply index_map=> x y eq; inversion eq. +move: ins1; rewrite in_cons=>/orP; case=> [ /eqP xa | ins1 ]. + by subst a; move: ax; rewrite eq_refl. +case in12: ((x1, x2) \in [seq (a, x0) | x0 <- s2]). + by move: in12=>/mapP [x xin xeq]; inversion xeq; subst a; move: ax; rewrite eq_refl. +by rewrite size_map (IHs1 ins1) addnA. +Qed. + +Lemma enum_rank_prod {T T': finType} (i : T) (j : T') : + (nat_of_ord (enum_rank (i, j)) = (enum_rank i) * #|T'| + enum_rank j)%N. +Proof. +do 3 rewrite enum_rank_index. +rewrite enum_prodE cardE /=. +by apply index_allpairs; rewrite enumT. +Qed. + +Lemma nth_cat_ord [T : Type] (x0 : T) (s1 s2 : seq T) (i: 'I_(size s1 + size s2)) : + nth x0 (s1 ++ s2) i = match split i with inl i=> nth x0 s1 i | inr i=> nth x0 s2 i end. +Proof. by move: (nth_cat x0 s1 s2 i)=>->; rewrite /split; case: (ltnP i (size s1)). Qed. + +Lemma nth_allpairs [T1 T2 rT : Type] (f : T1 -> T2 -> rT) + (s1: seq T1) (s2: seq T2) (x1: T1) (x2: T2) (x: rT) (i: 'I_(size s1 * size s2)) : + nth x (allpairs f s1 s2) i = let (i, j) := split_prod i in f (nth x1 s1 i) (nth x2 s2 j). +Proof. +elim: s1 i=>/= [| a s1 IHs1] i. + by exfalso; move: i=>[i ilt]; move: ilt; rewrite /muln /muln_rec /= ltn0. +move: i; rewrite /muln /muln_rec /= -/muln_rec -/muln -/addn_rec -/addn. +have->: (size s2 + size s1 * size s2 = size (map (f a) s2) + size (allpairs f s1 s2))%N. + rewrite size_map. + by move: (allpairs_tupleP f (in_tuple s1) (in_tuple s2))=>/eqP->. +move=>i; rewrite nth_cat_ord. +rewrite -{2 3}[i]splitK. +rewrite /split; case: ltnP=>/= i0. + rewrite (set_nth_default (f a x2)) //. + case: i i0=> [i ilt'] /=; rewrite size_map=> ilt. + by rewrite (nth_map x2)// divn_small// modn_small. +move: i i0; rewrite size_map=> [[i ilt']] i0. +have ilt: ((i - size s2) < size s1 * size s2)%N. + move: (allpairs_tupleP f (in_tuple s1) (in_tuple s2))=>/eqP<-. + apply (split_subproof i0). +rewrite (IHs1 (Ordinal ilt))=> /=. +rewrite addnC divnDr// divnn/= modnDr. +have [s20|] := ltnP 0 (size s2); first by rewrite addn1. +rewrite leqn0 => /eqP s20. +by move: ilt; rewrite s20 muln0. +Qed. + +(*TODO: move to mathcomp.*) +Lemma lift_range {aT rT: Type} [f: aT -> rT] (s: seq rT) : + all (fun u => u \in range f) s -> exists s', map f s' = s. +Proof. +elim: s=>[| a s IHs]. + by exists nil. +move=> /andP [/set_mem [a' _ ae] /IHs [s' se]]; subst a s. +by exists (a' :: s'). +Qed. + +Lemma index_enum_cast_ord n m (e: n = m) : + index_enum 'I_m = [seq (cast_ord e i) | i <- index_enum 'I_n]. +Proof. +subst m. +rewrite -{1}(map_id (index_enum 'I_n)). +apply eq_map=>[[x xlt]]. +rewrite /cast_ord; congr Ordinal; apply bool_irrelevance. +Qed. + +Lemma perm_map_bij [T: finType] [f : T -> T] (s: seq T) : + bijective f -> perm_eq (index_enum T) [seq f i | i <- index_enum T]. +Proof. +rewrite /index_enum; case: index_enum_key=>/=. +move=>fbij. +rewrite /perm_eq -enumT -forallb_tnth; apply /forallP=>i /=. +inversion fbij. +rewrite enumT enumP count_map -size_filter (@eq_in_filter _ _ (pred1 (g (tnth + (cat_tuple (enum_tuple T) (map_tuple [eta f] (enum_tuple T))) + i)))). + by rewrite size_filter enumP. +move=> x _ /=. +apply/eqP/eqP. + by move=>/(f_equal g) <-. +by move=>->. +Qed. + +(* TODO: this lemma has been moved to infotheo 0.5.1 *) +Section freeN_combination. +Import ssrnum vector. +Import Order.POrderTheory Num.Theory. +Variable (R : fieldType) (E : vectType R). +Local Open Scope ring_scope. +Local Open Scope classical_set_scope. +Import GRing. + +Lemma freeN_combination n (s : n.-tuple E) : ~~ free s -> + exists k : 'I_n -> R, (\sum_i k i *: s`_i = 0) /\ exists i, k i != 0. +Proof. +exact: freeN_combination. +Qed. + +End freeN_combination. + +Lemma ord_S_split n (i: 'I_n.+1): {j: 'I_n | i = lift ord0 j} + {i = ord0}. +Proof. +case: i; case=>[| i] ilt. + by right; apply val_inj. +by left; exists (Ordinal (ltnSE ilt)); apply val_inj. +Qed. + +Lemma subseq_incl (T : eqType) (s s' : seq T) x : subseq s s' -> + {f : 'I_(size s) -> 'I_(size s') | (forall i, nth x s' (f i) = nth x s i) /\ + {homo f : y x / (x < y)%O >-> (x < y)%O}}. +Proof. +elim: s' s=> [| a s' IHs'] s sub. + by move:sub=>/eqP -> /=; exists id; split=>// i j. +case: s sub=> [ _ | b s sub]. + move=>/=; simple refine (exist _ _ _). + by move=> i; case: i. + by split; move=> i; case: i. +move: sub=>/=; case sa: (b == a). + move: sa=>/eqP <- /IHs' [f [fn flt]]. + exists (fun i => match ord_S_split i with | inleft j => lift ord0 (f (proj1_sig j)) | inright _ => ord0 end). + split. + by move=> i; case: ord_S_split=> [ [j ie] | ie ]; subst i=>/=. + move=> i j; case: ord_S_split=> [ [i' ie] | ie ]; case: ord_S_split=> [ [j' je] | je ]; subst i j=>//=. + do 2 rewrite ltEord=>/=. + by rewrite /bump /= add1n add1n add1n add1n ltnS ltnS; apply flt. +by move=>/IHs' [f [fn flt]]; exists (fun i => lift ord0 (f i)). +Qed. + +Lemma hom_lt_inj {disp disp'} {T : orderType disp} {T' : porderType disp'} [f : T -> T'] : + {homo f : x y / (x < y)%O >-> (x < y)%O} -> injective f. +Proof. +move=>flt i j. +move: (Order.TotalTheory.le_total i j). +wlog: i j / (i <= j)%O. + move=>h /orP; case=>le fij. + by apply (h i j)=>//; rewrite le. + by apply/esym; apply (h j i)=>//; rewrite le. +rewrite Order.POrderTheory.le_eqVlt=>/orP; case=> [ /eqP ij | /flt fij ]=>// _ fije. +by move: fij; rewrite fije Order.POrderTheory.lt_irreflexive. +Qed. + +Lemma size_index_enum (T: finType): size (index_enum T) = #|T|. +Proof. by rewrite cardT enumT. Qed. + +Lemma map_nth_ord [T : Type] (x: T) (s : seq T) : + [seq nth x s (nat_of_ord i) | i <- index_enum 'I_(size s)] = s. +Proof. +rewrite /index_enum; case: index_enum_key=>/=; rewrite -enumT. +elim: s=>/= [| a s IHs]. + by case: (enum 'I_0)=> [| s q] //; inversion s. +by rewrite enum_ordSl /= -map_comp /=; congr cons. +Qed. + +Lemma nth_filter [T : Type] (P: {pred T}) x (s: seq T) n : + (n < size [seq i <- s | P i])%N -> P (nth x [seq i <- s | P i] n). +Proof. +elim: s n=> [| a s IHs] n //=. +case Pa: (P a). + 2: by apply IHs. +by case: n=>//=; rewrite ltnS; apply IHs. +Qed. + +Lemma big_pair [R : Type] (idr : R) (opr : R -> R -> R) [S : Type] (ids : S) + (ops : S -> S -> S) [I : Type] (r : seq I) (F : I -> R) (G: I -> S) : + \big[(fun (x y: R*S)=> (opr x.1 y.1, ops x.2 y.2))/(idr, ids)]_(i <- r) (F i, G i) = + (\big[opr/idr]_(i <- r) F i, \big[ops/ids]_(i <- r) G i). +Proof. +elim: r=>[| a r IHr]. + by do 3 rewrite big_nil. +by do 3 rewrite big_cons; rewrite IHr. +Qed. + +From infotheo Require Import fdist. +Local Open Scope fdist_scope. + +Lemma Convn_pair [T U : @convType Rdefinitions.R] [n : nat] (g : 'I_n -> T * U) + (d : {fdist 'I_n}) : + Convn conv d g = (Convn conv d (Datatypes.fst \o g), + Convn conv d (Datatypes.snd \o g)). +Proof. +elim: n g d => [|n IHn] g d. + by have := fdistI0_False d. +rewrite /Convn; case: (Bool.bool_dec _ _) => [_|d0]. + by rewrite -surjective_pairing. +have := IHn (g \o fdist_del_idx ord0) (fdist_del (Bool.eq_true_not_negb _ d0)). +by rewrite/Convn => ->. +Qed. diff --git a/theories/preliminaries_hull.v b/theories/preliminaries_hull.v new file mode 100644 index 0000000..496b471 --- /dev/null +++ b/theories/preliminaries_hull.v @@ -0,0 +1,280 @@ +From mathcomp Require Import all_ssreflect ssrnum zmodp order constructive_ereal. +Require Import preliminaries. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Import Order.POrderTheory Order.TotalTheory. +Local Open Scope order_scope. + +(******************************************************************************) +(* Zp_succ (i : 'I_n) == the ordinal i.+1 : 'I_n *) +(******************************************************************************) + +Definition Zp_succ p : 'I_p -> 'I_p := + match p with + 0 => id + | q.+1 => fun i : 'I_q.+1 => inZp i.+1 + end. + +Notation "n .+1mod" := (Zp_succ n) (at level 2, left associativity, + format "n .+1mod"). + +Lemma Zp_succE n (i : 'I_n) : val (i .+1mod) = i.+1 %% n. +Proof. by case: n i => // -[]. Qed. + +Lemma Zp_succ_max n : (@ord_max n).+1mod = ord0. +Proof. by apply: val_inj => /=; rewrite modnn. Qed. + +Lemma subseq_iota (n m : nat) (l : seq nat) : subseq l (iota n m) = + (l == [::]) || (n <= nth 0 l 0)%N && + [forall i : 'I_(size l), (nth 0 l i < nth 0 (rcons l (n+m)) i.+1)%N]. +Proof. +elim:l n m=>[| a l IHl] n m; first by case: (iota n m). +elim: m n=>[| m IHm] n. + rewrite /addn/addn_rec-plus_n_O. + move:(size_iota n 0)=>/size0nil->/=; apply/esym/negbTE. + rewrite negb_and orbC -implybE; apply/implyP=>/forallP lmono; rewrite -ltnNge. + elim:l a {IHl} lmono=>[| b l IHl] a; first by move=>/(_ ord0). + by move=>lmono; apply (ltn_trans (lmono ord0)); apply IHl=>i/=; apply (lmono (lift ord0 i)). +rewrite/iota-/(iota n.+1 m)/subseq. +case: ifP. + move=>/eqP an; subst a. + rewrite -/(subseq l (iota n.+1 m)) (IHl n.+1 m)/= leqnn/=. + destruct l=>/=. + by apply/esym/forallP; case; case=>//= _; rewrite -{1}(addn0 n) ltn_add2l. + apply/andP/forallP. + by move=>[nn0 /forallP nl] i; case (ord_S_split i)=>[ [j]->/= | ->// ]; rewrite -addSnnS; apply nl. + move=>nl; split; first by apply (nl ord0). + by apply/forallP=>i; rewrite addSnnS; apply (nl (lift ord0 i)). +move=>an. +rewrite -/(subseq (a :: l) (iota n.+1 m)) IHm; congr andb=>/=. + by rewrite ltn_neqAle eq_sym an. +by rewrite addSnnS. +Qed. + +Lemma count_card (T : eqType) (x : T) (l : seq T) (P : pred T) : + count P l = #|[set i : 'I_(size l) | P (nth x l i)]|. +Proof. +elim:l. + by move=>/=; apply/esym /eqP; rewrite cards_eq0 -subset0; apply/subsetP=>[[i ilt]]. +move=>a l IHl /=. +rewrite (cardsD1 (Ordinal (ltn0Sn _))) IHl. +rewrite cardsE. +have fi: injective (fun i : 'I_(size l)=> lift ord0 i) by move=>[i ilt] [j jlt]/(congr1 val)/=/eqP; rewrite/bump/= 2!add1n eqSS=>/eqP ij; apply val_inj. +rewrite -(card_imset _ fi)/=. +have/eqP->: [set i : 'I_(size l).+1 | P (nth x (a :: l) i)] :\ Ordinal (ltn0Sn (size l)) == [set lift ord0 i | i in fun x0 : 'I_(size l) => P (nth x l x0)]. + rewrite eqEsubset; apply/andP; split; apply/subsetP=>i; rewrite in_setD1 inE. + move=>/andP[i0 Pi]. + case: (ord_S_split i); last by move=>ie; subst i; move: i0=>/negP; elim. + move=>[j ie]; subst i. + by apply /imsetP=>/=; exists j. + move=>/imsetP/=[j Pj ie]; subst i. + by apply/andP; split. +by apply/eqP; rewrite eqn_add2r inE; apply/eqP. +Qed. + +Lemma filter_incl_surj (T : eqType) (x : T) (l : seq T) (P : pred T) : + let l' := [seq x <- l | P x] in forall (f : 'I_(size l') -> 'I_(size l)), + (forall i : 'I_(size l'), nth x l (f i) = nth x l' i) -> + {homo f : x0 y / x0 < y >-> x0 < y} -> + forall j : 'I_(size l), P (nth x l j) -> + exists i : 'I_(size l'), j = f i. +Proof. +set l' := [seq x0 <- l | P x0]=>/= f fi fh j Pj. +suff: exists i, ~~ (j != f i) by move=>[i /negPn/eqP ->]; exists i. +apply /existsP. +rewrite -negb_forall; apply /negP=>/forallP jf. +suff: size l' < count P l by rewrite size_filter lt_irreflexive. +rewrite (count_card x). +(* Huh ??? *) +have what: (size l' < (size l').+1) by move:(leqnn (size l').+1). +apply (lt_le_trans what). +rewrite -(card_ord (size l').+1). +have/card_codom<-: injective (fun i => + match ord_S_split i with + | inleft j => f (proj1_sig j) + | _ => j + end). + move=>a b. + case:(ord_S_split a). + move=>[a'/= ae]; subst a. + case:(ord_S_split b). + move=>[b'/= be]; subst b=>fab. + apply val_inj; apply/eqP; rewrite/=/bump/= 2!add1n eqSS. + by apply/negP=>/negP/lt_total/orP; case=>/fh; rewrite fab lt_irreflexive. + by move=>->/esym je; move:(jf a'); rewrite je eq_refl. + case:(ord_S_split b). + by move=>[b'/= be]; subst b=>fab je; move:(jf b'); rewrite je eq_refl. + by move=>-> -> _. +apply subset_leq_card; apply/subsetP=>k /codomP [a ->]. +case: (ord_S_split a). + move=>[a'/= _]; rewrite inE fi. + have/mem_nth: val a' < size l' by case: a'. + by move=>/(_ x); rewrite mem_filter=>/andP[h _]. +by move=>_; rewrite inE. +Qed. + +Lemma homo_lt_total disp disp' {T : orderType disp} + {T' : orderType disp'} [f : T -> T'] : {homo f : x y / x < y >-> x < y} -> + forall x y, f x < f y -> x < y. +Proof. +move=>fh x y fxy. +case xy: (x == y); first by move:xy fxy=>/eqP ->; rewrite lt_irreflexive. +move:xy=>/negbT/lt_total/orP; case=>// /fh fyx. +by move:(lt_trans fxy fyx); rewrite lt_irreflexive. +Qed. + +Lemma homo_lt_inj {disp disp'} {T : orderType disp} + {T' : orderType disp'} [f : T -> T'] : {homo f : x y / x < y >-> x < y} -> + injective f. +Proof. +move=>fh x y fxy. +case xy: (x == y); first by move:xy=>/eqP. +by move:xy=>/negbT/lt_total/orP; case=>/fh; rewrite fxy lt_irreflexive. +Qed. + +Lemma filter_succ (T : eqType) (x : T) (l : seq T) (P : pred T) : + let l' := [seq x <- l | P x] in forall (f : 'I_(size l') -> 'I_(size l)), + (forall i : 'I_(size l'), nth x l (f i) = nth x l' i) -> + {homo f : x0 y / x0 < y >-> x0 < y} -> + forall (i' : 'I_(size l')) k, + (f i' < k < (f i'.+1mod + (i'.+1 == size l')*(size l))%N)%N -> + ~~ P (nth x l (k %% size l)). +Proof. +(*Huh???*) +set l' := [seq x0 <- l | P x0]=>/= f fi fh i' k ikj; apply /negP=>Pkl. +have kl: k %% size l < size l. + apply ltn_pmod; destruct l=>//. + by move:(i')=>[a/= alt]. +move: (@filter_incl_surj _ _ _ _ _ fi fh (Ordinal kl) Pkl)=>[[a alt] /(congr1 val)/= ke]. +(*Way too long*) +destruct i' as [i' i'lt]. +move:(i'lt); rewrite leq_eqVlt => /predU1P[ie|]. + move:ikj; rewrite ie eq_refl mul1n. + case klt: (k < size l). + move:(alt); rewrite -{1}ie leq_eqVlt=>/orP; case. + rewrite eqSS=>/eqP ae; subst a. + move: ke; rewrite modn_small ?klt//; move=>->/andP. + have->:Ordinal alt = Ordinal i'lt by apply val_inj. + move=>[h _]. + by move: (lt_irreflexive (f (Ordinal i'lt)))=>/negbT/negP; apply. + rewrite ltnS=>ai' /andP[fik _]. + have/fh fai:Ordinal alt < Ordinal i'lt by []. + move:(ltn_trans fai fik); rewrite/= -ke modn_small ?klt//. + by rewrite ltnn. + move:klt; rewrite ltNge=>/negbT/negbNE lk. + move=>/andP[_]; rewrite addnC -ltn_subLR// =>kf. + have kmod: (k %% size l = k - size l)%N. + rewrite -{1}[k](subnK lk) modnDr modn_small//. + by apply (ltn_trans kf). + move:ke; rewrite kmod=>ke. + have ie' : val (Ordinal i'lt).+1mod = 0%N. + by move: ie i'lt {kf}=><- i'lt/=; apply modnn. + destruct a as [| a]. + have ae: Zp_succ (Ordinal i'lt) = Ordinal alt by apply val_inj. + by move: kf; rewrite ke -ae ltnn. + have /fh fia : (Ordinal i'lt).+1mod < Ordinal alt. + suff: val (Ordinal i'lt).+1mod < a.+1 by []. + by rewrite ie'; apply ltn0Sn. + have fai: f (Ordinal alt) < f (Ordinal i'lt).+1mod. + by have: val (f (Ordinal alt)) < val (f (Ordinal i'lt).+1mod) by rewrite/= -ke. + by move:(lt_trans fai fia); rewrite ltxx. +move=>i'lt'; move:ikj. +case ile: ((Ordinal i'lt).+1 == size l'). + by move:ile=>/=/eqP ile; move:i'lt'; rewrite ile ltnn. +rewrite/=/muln/muln_rec/= addnC/addn/addn_rec/= => /andP[fk kf]. +have kl': (k < size l)%N by apply (ltn_trans kf). +move:Pkl kl ke; rewrite modn_small// =>Pkl kl ke. +move:fk kf; rewrite ke=>/(@homo_lt_total _ _ _ _ _ fh) ia /(@homo_lt_total _ _ _ _ _ fh) ai. +have ia': (i' < a)%N by []. +have ai': (a < i'.+1)%N. + have ai': val (Ordinal alt) < val (Ordinal i'lt).+1mod by []. + move:f fi fh alt i'lt ile {ia} ke i'lt' ai ai'; rewrite/Zp_succ -/l'; generalize (size l'); case=>// n _ _ _ /= _ _ _ _ i'lt _. + by rewrite modn_small. +by move: (leq_ltn_trans ia' ai'); rewrite ltnn. +Qed. + +Lemma uniq_subseq_size (T: eqType) (l l': seq T) : + all (fun x => x \in l) l' -> uniq l' -> (size l' <= size l)%N. +Proof. +elim: l' l=>// a l' IHl' l /andP[al /allP l'l] /andP [al' l'uniq]. +move:(al)=>/size_rem/(f_equal S). +rewrite prednK; last by case: l l'l al. +move=><-; rewrite ltnS; apply IHl'=>//. +apply/allP=>b bl'; move:(bl')=>/l'l bl. +apply/negPn/negP=>/count_memPn brem. +move:al=>/perm_to_rem /allP /(_ b). +rewrite mem_cat bl/= =>/(_ Logic.eq_refl); rewrite brem. +case ab: (a == b); first by move=>_; move: al'=>/negP; apply; move: ab=>/eqP->. +by move=>/=/eqP/count_memPn/negP; apply. +Qed. + +Section ereal_tblattice. +Variable (R : realDomainType). +Local Open Scope ereal_scope. + +(* PRed to MathComp-Analysis: https://github.com/math-comp/analysis/pull/859 *) +(* +Definition ereal_blatticeMixin : + Order.BLattice.mixin_of (Order.POrder.class (@ereal_porderType R)). +exists (-oo); exact leNye. +Defined. +Canonical ereal_blatticeType := BLatticeType (\bar R) ereal_blatticeMixin. + + +Definition ereal_tblatticeMixin : + Order.TBLattice.mixin_of (Order.POrder.class (ereal_blatticeType)). +exists (+oo); exact leey. +Defined. +Canonical ereal_tblatticeType := TBLatticeType (\bar R) ereal_tblatticeMixin. +(* /PRed *) +*) + +(* Note: Should be generalized to tbLatticeType+orderType, but such a structure is not defined. *) +Lemma ereal_joins_lt + (J : Type) (r : seq J) (P : {pred J}) (F : J -> \bar R) (u : \bar R) : + -oo < u -> + (forall x, P x -> F x < u) -> \join_(x <- r | P x) F x < u. +Proof. by move=>u0 ltFm; elim/big_rec: _ => // i x Px xu; rewrite ltUx ltFm. Qed. + +Lemma ereal_meets_gt + (J : Type) (r : seq J) (P : {pred J}) (F : J -> \bar R) (u : \bar R) : + u < +oo -> + (forall x, P x -> u < F x) -> u < \meet_(x <- r | P x) F x. +Proof. by move=>u0 ltFm; elim/big_rec: _ => // i x Px xu; rewrite ltxI ltFm. Qed. + +End ereal_tblattice. + +Section bigop_partition. + +Lemma perm_eq_partition {aT rT : eqType} (l : seq aT) (s : seq rT) (f : aT -> rT) : + uniq s -> all (fun x=> f x \in s) l -> perm_eq [seq x | y <- s, x <- [seq x <- l | f x == y]] l. +Proof. +elim: s l; first by case. +move=>y s IHs l yus /allP fl /=. +move: (perm_filterC (fun x=> f x == y) l)=>/(_ l); rewrite perm_refl; apply perm_trans. +rewrite map_id; apply perm_cat=>//. +have->: [seq x | y0 <- s, x <- [seq x <- l | f x == y0]] = [seq x | y0 <- s, x <- [seq x <- [seq x <- l | predC (fun x : aT => f x == y) x] | f x == y0]]. + clear IHs fl. + elim: s y yus=>// y' s IHl y /andP[]; rewrite in_cons negb_or=> /andP [yy' ys] /andP[_ us] /=; congr cat; last by apply/IHl/andP; split. + rewrite 2!map_id -filter_predI; apply eq_filter=>x. + apply/idP/idP. + by move=>/=/eqP->; rewrite eq_refl eq_sym. + by move=>/andP[]. +apply IHs; first by move:yus=>/andP[]. +by apply/allP=>x; rewrite mem_filter=>/andP [/= /negPf fxy /fl]; rewrite in_cons=>/orP; case=>//; rewrite fxy. +Qed. + +Lemma big_partition {aT rT : eqType} {R : Type} {idx : R} {op : Monoid.com_law idx} {F : aT -> R} {l : seq aT} {s : seq rT} {f : aT -> rT} : + uniq s -> all (fun x=> f x \in s) l -> + \big[op/idx]_(i <- l) F i = \big[op/idx]_(y <- s) \big[op/idx]_(i <- l | f i == y) F i. +Proof. +move=>us fs. +move:(@big_allpairs_dep _ idx op _ _ _ (fun i j=> j) s (fun i=> [seq j <- l | f j == i]) F); congr eq. + by apply/perm_big/perm_eq_partition. +by apply congr_big=>//y _; rewrite big_filter. +Qed. + +End bigop_partition. diff --git a/theories/shortest_path.v b/theories/shortest_path.v new file mode 100644 index 0000000..ac4dac1 --- /dev/null +++ b/theories/shortest_path.v @@ -0,0 +1,71 @@ +From mathcomp Require Import all_ssreflect all_algebra. +Require Import ZArith String OrderedType OrderedTypeEx FMapAVL. + +Notation head := seq.head. +Notation seq := seq.seq. +Notation nth := seq.nth. +Notation sort := path.sort. + +Import Order.POrderTheory Order.TotalTheory. + +Section shortest_path. + +Variable R : Type. +Variable R0 : R. +Variable R_ltb : R -> R -> bool. +Variable R_add : R -> R -> R. + +Variable cell : Type. +Variable node : Type. +Variable node_eqb : node -> node -> bool. +Variable neighbors_of_node : node -> seq (node * R). +Variable source target : node. + +Variable priority_queue : Type. +Variable empty : priority_queue. +Variable gfind : priority_queue -> node -> option (seq node * option R). +Variable update : priority_queue -> node -> seq node -> option R -> + priority_queue. +Variable pop : priority_queue -> + option (node * seq node * option R * priority_queue). + +Definition cmp_option (v v' : option R) := + if v is Some x then + if v' is Some y then + (R_ltb x y)%O + else + true + else + false. + +Definition Dijkstra_step (d : node) (p : seq node) (dist : R) + (q : priority_queue) : priority_queue := + let neighbors := neighbors_of_node d in + foldr (fun '(d', dist') q => + match gfind q d' with + | None => q + | Some (p', o_dist) => + let new_dist_to_d' := Some (R_add dist dist') in + if cmp_option new_dist_to_d' o_dist then + update q d' (d :: p) new_dist_to_d' + else q + end) q neighbors. + +Fixpoint Dijkstra (fuel : nat) (q : priority_queue) := + match fuel with + | 0%nat => None + |S fuel' => + match pop q with + | Some (d, p, Some dist, q') => + if node_eqb d target then Some p else + Dijkstra fuel' (Dijkstra_step d p dist q') + | _ => None + end + end. + +Definition shortest_path (s : seq node) := + Dijkstra (size s) + (update (foldr [fun n q => update q n [::] None] empty s) + source [::] (Some R0)). + +End shortest_path. diff --git a/theories/shortest_path_proofs.v b/theories/shortest_path_proofs.v new file mode 100644 index 0000000..1e82b9d --- /dev/null +++ b/theories/shortest_path_proofs.v @@ -0,0 +1,105 @@ +From mathcomp Require Import all_ssreflect all_algebra. +Require Import ZArith String OrderedType OrderedTypeEx FMapAVL. +Require Import shortest_path. + +Notation head := seq.head. +Notation seq := seq.seq. +Notation nth := seq.nth. +Notation sort := path.sort. + +Import Order.POrderTheory Order.TotalTheory. + +Section shortest_path_proofs. + +Variable R : realDomainType. + +Variable node : eqType. + +Variable neighbors : node -> seq (node * R). + +Variable queue : Type. +Variable empty : queue. +Variable find : queue -> node -> option (seq node * option R). +Variable update : queue -> node -> seq node -> option R -> queue. +Variable pop : queue -> option (node * seq node * option R * queue). + +Hypothesis find_empty : + forall n, find empty n = None. +Hypothesis find_update_eq : forall q n p d p' d', + find q n = Some(p', d') -> cmp_option R <%R d d' -> + find (update q n p d) n = Some(p, d). +Hypothesis find_update_None : forall q n p d, + find q n = None -> find (update q n p d) n = Some(p, d). +Hypothesis find_update_diff : forall q n1 n2 p d, + n1 != n2 -> + find (update q n1 p d) n2 = find q n2. +Hypothesis pop_remove : + forall q n p d q', pop q = Some (n, p, d, q') -> + find q' n = None. +Hypothesis pop_find : + forall q n p d q', pop q = Some (n, p, d, q') -> + find q n = Some(p, d). +Hypothesis pop_diff : + forall q n1 n2 p d q', pop q = Some(n1, p, d, q') -> + n1 != n2 -> + find q' n2 = find q n2. +Hypothesis pop_min : forall q n1 n2 p p' d d' q', + pop q = Some(n1, p, d, q') -> + find q n2 = Some(p', d') -> cmp_option _ <%R d d'. +Hypothesis update_discard : + forall q n p d p' d', + find q n = Some(p, d) -> + ~~ cmp_option _ <%R d' d -> + find (update q n p' d') n = find q n. + +Lemma oltNgt (d1 d2 : option R) : cmp_option _ <%R d1 d2 -> + ~~ cmp_option _ <%R d2 d1. +Proof. +case: d1 => [d1 | ]; case: d2 => [d2 | ] //. +rewrite /cmp_option. +by rewrite -leNgt le_eqVlt orbC => ->. +Qed. + + +Lemma cmp_option_trans (r : rel R) : ssrbool.transitive r -> + ssrbool.transitive (cmp_option _ r). +Proof. +move=> rtr [y |] [x |] [z|] //=. +by apply: rtr. +Qed. + +Lemma cmp_option_le_lt_trans (y x z: option R) : + ~~ cmp_option _ <%R y x -> cmp_option _ <%R y z -> + cmp_option _ <%R x z. +Proof. +case: x => [x | ]; case: y => [y | ] // xley. +rewrite /= -leNgt le_eqVlt in xley. +case: (orP xley)=> [/eqP ->| xltkey ]; first by []. +apply: (cmp_option_trans <%R lt_trans). +exact: xltkey. +Qed. + +Arguments cmp_option_trans [r] _ [_ _ _]. + +(* A sobering counter example: you cannot swap updates, because they + may imply different choices between points at the same distance. *) +Lemma update_update_counterx n p1 p2 d : + p1 != p2 -> + find (update (update empty n p1 d) n p2 d) n != + find (update (update empty n p2 d) n p1 d) n. +Proof. +move=> pdif. +have testfail : ~~ cmp_option R <%R d d. + by case: d => [d | ] //=; rewrite lt_irreflexive. +have inup1 : find (update empty n p1 d) n = Some(p1, d). + by rewrite find_update_None. +rewrite (update_discard _ _ _ _ _ _ inup1) //. +rewrite inup1. +have inup2 : find (update empty n p2 d) n = Some(p2, d). + by rewrite find_update_None. +rewrite (update_discard _ _ _ _ _ _ inup2) //. +rewrite inup2. +by apply/eqP=> - [] /eqP; rewrite (negbTE pdif). +Qed. + +End shortest_path_proofs. diff --git a/theories/square_free.v b/theories/square_free.v new file mode 100644 index 0000000..4bfdc65 --- /dev/null +++ b/theories/square_free.v @@ -0,0 +1,119 @@ +From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype prime. +From mathcomp Require Import div ssralg poly polydiv polyorder ssrnum zmodp polyrcf. + +Set Implicit Arguments. +Unset Strict Implicit. + +Import GRing.Theory. (*Num.Theory Num.Def.*) +Import Pdiv.Idomain. + +Open Scope ring_scope. + +Section more_deriv. + +Lemma derivXsubCexpSn : forall (R : idomainType) (c : R) (n : nat), + (('X-c%:P) ^+(n.+1))^`() = (n.+1)%:R *: ('X-c%:P) ^+ n. +Proof. +move=> R c; elim=> [|m Hm]; first by rewrite scaler_nat expr0 expr1 derivXsubC. +rewrite exprSr derivM derivXsubC Hm -scalerAl -exprSr mulr1 scaler_nat -mulrSr. +by rewrite -scaler_nat. +Qed. + +Lemma derivXsubCexpn : forall (R : idomainType) (c : R) (n : nat), + (0 < n)%N -> (('X-c%:P) ^+n)^`() = n%:R *: ('X-c%:P) ^+ (n.-1). +Proof. by move=> R c; elim=> [|m Hm H] //=; rewrite derivXsubCexpSn. Qed. + +End more_deriv. + +Section poly_simple_roots. + +Variable R : idomainType. +Hypothesis HR : [char R] =i pred0. + +Lemma mu_x_gcdp : forall (p : {poly R}) (x : R), (p != 0) -> (root p x) -> + \mu_x (gcdp p p^`()) == (\mu_x p) .-1. +Proof. +move=> p x Hp zero_x. +(*about p*) +have [q Hq Hpp] := (@mu_spec R p x Hp). +(*mu x > 0*) +have Hmu : ((\mu_x p)%R > 0)%N by rewrite mu_gt0. +(*about p'*) +have Hpderiv : (deriv p) = + ('X - x%:P) ^+ (\mu_x p).-1 * ((\mu_x p)%:R *: q + ('X-x%:P) * (deriv q)). + by rewrite mulrDr mulrA -exprSr prednK // -scalerCA -derivXsubCexpn // + -derivM mulrC {1}Hpp. +(**********) +rewrite eq_sym -muP. + apply/andP; split. +(*(X-x)^m-1 divides pgcd*) + rewrite dvdp_gcd. + apply/andP; split. +(*(X-x)^m-1 divides p*) + by rewrite {2}Hpp -(@prednK (\mu_x p)) // exprS mulrA; apply dvdp_mulIr. +(*(X-x)^m-1 divides p'*) + by rewrite Hpderiv; apply dvdp_mulIl. +(*(X-x)^m doesn't divide pgcd*) + rewrite prednK // dvdp_gcd negb_and. + apply/orP; right. +(*(X-x)^m doesn't divide p'*) + rewrite Hpderiv -{1}(@prednK (\mu_x p)) // exprSr dvdp_mul2l. +(*(X-x) doesn't divide the remaining factor of p'*) + rewrite dvdp_addl; last by apply dvdp_mulr. + rewrite (@eqp_dvdr _ q ((\mu_x p)%:R *: q) ('X -x%:P)). + by rewrite dvdp_XsubCl. + apply eqp_scale. + have/charf0P ->:= HR. + by rewrite -lt0n //. + by rewrite -size_poly_gt0 size_exp_XsubC prednK //. +by rewrite gcdp_eq0 negb_and Hp. +Qed. + +Lemma mu_gcdp_eq1 : forall (p : {poly R}) (x : R), (p != 0) -> root p x -> + (\mu_x (divp p (gcdp p p^`())) == 1)%N. +Proof. +move=> p x Hp zero_x. +rewrite -(@eqn_add2r ((\mu_x)%R p)) (@addnC 1%N _) addn1 + -{1}(@prednK ((\mu_x)%R p)) ?mu_gt0 //. +rewrite addnS -(eqP (mu_x_gcdp Hp zero_x)) -mu_mul. + rewrite divpK ?mu_mulC //; last by apply dvdp_gcdl. + by apply lc_expn_scalp_neq0. +rewrite divpK. + rewrite -size_poly_gt0 -mul_polyC size_Cmul ?size_poly_gt0 //. + by apply lc_expn_scalp_neq0. +by apply dvdp_gcdl. +Qed. + +Lemma same_roots_1 : forall (p : {poly R}) (x : R), root p x -> + root (divp p (gcdp p p^`())) x. +Proof. +move=> p x zero_x. +case h: (p==0). + by move/eqP: h => H; move : zero_x; rewrite H deriv0 gcd0p div0p. +move/negbT: h => H; rewrite -mu_gt0. + by move/eqP : (mu_gcdp_eq1 H zero_x) => ->. +rewrite divpN0; first by apply: leq_gcdpl. +by move/negPf : H => H; rewrite gcdp_eq0 H. +Qed. + +Lemma same_roots_2 : forall (p : {poly R}) (x : R), + root (divp p (gcdp p p^`())) x -> root p x. +Proof. +move=> p x zero_x. +rewrite -(@rootZ R x (lead_coef (gcdp p p^`()) ^+ scalp (R:=R) p + (gcdp p p^`())) p). + rewrite -divpK. + by rewrite rootM zero_x. + by apply dvdp_gcdl. +by apply lc_expn_scalp_neq0. +Qed. + +Lemma gcdp_simple_roots : forall (p : {poly R}) (x : R), (p != 0) -> + root (divp p (gcdp p p^`())) x -> + (\mu_x (divp p (gcdp p p^`())) == 1)%N. +Proof. +by move=> p x Hp zero_x; apply (mu_gcdp_eq1 Hp); apply same_roots_2. +Qed. +(*p!=0 beause of mu_polyC.*) + +End poly_simple_roots. diff --git a/theories/three_circles.v b/theories/three_circles.v new file mode 100644 index 0000000..e782a95 --- /dev/null +++ b/theories/three_circles.v @@ -0,0 +1,756 @@ +From HB Require Import structures. +From mathcomp Require Import all_ssreflect. +From mathcomp Require Import ssralg poly polydiv polyorder ssrnum zmodp. +From mathcomp Require Import polyrcf qe_rcf_th complex. +Require Import poly_normal pol. + +(* +This file consists of several sections: +- nonnegative lists, polynomials with nonnegative coefs, + proof of Proposition 2.39 of [bpr], monic_roots_changes_eq0 +- complements for scaleX_poly +- complements for transformations in R and roots +- complements for transformations and equality +- complements for transformations in C and roots +- proof of 3 circles i) +- proof of 3 circles ii) +*) + +Set Implicit Arguments. +Unset Strict Implicit. + +Import Order.Theory GRing.Theory Num.Theory Num.Def. +Import Pdiv.Idomain. + +Local Open Scope ring_scope. + +Section about_nonneg. + +Variable R : rcfType. + +Local Notation C := (complex R). + +Definition nonneg (s : seq R) := all (fun x => 0 <= x) s. + +Lemma nonnegP (s : seq R) : + reflect (forall k, (k < size s)%N -> 0 <= s`_k) (nonneg s). +Proof. exact/all_nthP. Qed. + +Lemma nonneg_poly_deg1 (a : R) : nonneg ('X - a%:P) = (a <= 0). +Proof. +by rewrite polyseqXsubC /= ler01 oppr_ge0 !andbT. +Qed. + +Import complex. + +Lemma nonneg_poly_deg2 (z : C) : + nonneg ('X^2 + (1 *- 2 * Re z) *: 'X + (Re z ^+ 2 + Im z ^+ 2)%:P) = + ((Re z) <= 0). +Proof. +rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 /= ?oner_neq0 // ler01 !andbT. +by rewrite nmulr_rge0 ?oppr_lt0 ?ltr0n // addr_ge0 // sqr_ge0. +Qed. + +Lemma nonneg_mulr (p q : {poly R}) : nonneg p -> nonneg q -> nonneg (p * q). +Proof. +have [->|Hpsize] := eqVneq p 0; first by rewrite mul0r. +have [->|Hqsize Hp Hq] := eqVneq q 0; first by rewrite mulr0. +apply/nonnegP => k lpq. +rewrite coef_mul_poly /= sumr_ge0 // => i _. +apply: mulr_ge0. + have [Hi2|Hi2] := ltnP i (size p); first exact/nonnegP. + by rewrite -(coefK p) coef_poly ltnNge Hi2. +have [Hi2|Hi2] := ltnP (k - i) (size q); first exact/nonnegP. +by rewrite -(coefK q) coef_poly ltnNge Hi2. +Qed. + +Local Notation toC := (fun (p : {poly R}) => + @map_poly R _ (real_complex R) p). + +Lemma nonneg_root_nonpos (p : {poly R}) : p \is monic -> + (forall z : C, root (toC p) z -> (Re z <= 0)) -> nonneg p. +Proof. +move=> Hpmonic. +move: {2}(size p) (leqnn (size p)) => n. +elim: n p Hpmonic=> [p Hpmonic Hpsize Hproot | n IH p Hpmonic Hpsize Hproots]. +(* size p <= 0 *) + rewrite size_poly_leq0 in Hpsize. + by rewrite (eqP Hpsize) monicE lead_coef0 eq_sym oner_eq0 in Hpmonic. +(* size p <= n.+1 *) +case: (altP (size (toC p) =P 1%N)) => Hpsize2. +(* size p = 1 *) + rewrite size_map_poly_id0 in Hpsize2; + last by rewrite eq_sym negbT // lt_eqF // ltcR (eqP Hpmonic) ltr01. + have Hp := (size1_polyC (eq_leq Hpsize2)). + rewrite Hp in Hpsize2. + rewrite Hp monicE lead_coefE Hpsize2 -pred_Sn polyseqC in Hpmonic. + rewrite size_polyC in Hpsize2. + rewrite Hpsize2 /= in Hpmonic. + by rewrite Hp /= (eqP Hpmonic) polyseqC oner_neq0 /= ler01. +(* size p != 1 *) +move/closed_rootP : Hpsize2. +case=> x Hrootx. +have [Himx|Himx] := altP (Im x =P 0). +(* real root *) + have H := monicXsubC (Re x). + have Hp := real_root_div_poly_deg1 Himx Hrootx. + rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp. + rewrite (eqP Hp) nonneg_mulr //. + apply: IH=> [ | | z Hz]. + + by rewrite monicE -(@lead_coef_Mmonic _ (p %/ ('X - (Re x)%:P)) + ('X - (Re x)%:P)) // -(eqP Hp) -monicE. + - rewrite size_divp; last by apply: monic_neq0. + by rewrite size_XsubC leq_subLR addnC addn1. + + rewrite Hproots // (eqP Hp) rmorphM rootM. + apply/orP; by left. + by rewrite nonneg_poly_deg1 (Hproots x Hrootx). +(* pair of complex roots *) +have H : 'X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P \is monic. + by rewrite -(mul1r 'X^2) mul_polyC monicE lead_coefE polyseq_deg2 // oner_neq0. +have H2 : size ('X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P) = 3%N. + by rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 // oner_neq0. +have Hp := complex_root_div_poly_deg2 Himx Hrootx. +rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp. +rewrite (eqP Hp) nonneg_mulr //. + apply: IH=> [ | | z Hz]. + + by rewrite monicE -(@lead_coef_Mmonic _ _ ('X^2 + (1 *- 2 * Re x) *: 'X + + (Re x ^+ 2 + Im x ^+ 2)%:P)) // -(eqP Hp) -monicE. + - rewrite size_divp; last by apply: monic_neq0. + by rewrite H2 leq_subLR addnC addn2 (@leq_trans n.+1). + + by rewrite Hproots // (eqP Hp) rmorphM rootM Hz. +by rewrite nonneg_poly_deg2 (Hproots _ Hrootx). +Qed. + +Lemma nonneg_changes0 (s : seq R) : nonneg s -> changes s = 0%N. +Proof. +elim: s => [ |a ] //. +case=> [_ _ |b l IHbl /andP [] Ha Hblnonneg]. + by rewrite /= mulr0 addn0 ltxx. +have /andP[Hb Hlnonneg] := Hblnonneg. +apply/eqP; rewrite addn_eq0 eqb0 -leNgt mulr_ge0 //=. +apply/eqP; by apply: IHbl. +Qed. + +(* Proposition 2.39 *) +Lemma monic_roots_changes_eq0 (p : {poly R}) : p \is monic -> + (forall (z : C), (root (toC p) z) -> (Re z <= 0)) -> + changes p = 0%N. +Proof. +move=> Hpmonic H. +by rewrite nonneg_changes0 // nonneg_root_nonpos. +Qed. + +End about_nonneg. + +Section about_scaleX_poly. (* move this section to pol.v*) + +Variable (R : comRingType). + +Lemma scaleX_poly_is_linear (c : R) : linear (scaleX_poly c). +Proof. by move=> a u v; rewrite /scaleX_poly comp_polyD comp_polyZ. Qed. + +Lemma scaleX_poly_multiplicative (c : R) : multiplicative (scaleX_poly c). +Proof. +split. move=> x y; exact: comp_polyM. by rewrite /scaleX_poly comp_polyC. +Qed. + +HB.instance Definition _ (c : R) := GRing.isLinear.Build _ _ _ _ _ (scaleX_poly_is_linear c). + +HB.instance Definition _ c := GRing.isMultiplicative.Build _ _ _ (scaleX_poly_multiplicative c). + +(*Canonical scaleX_poly_rmorphism c := AddRMorphism (scaleX_poly_multiplicative c).*) + +Lemma scaleX_polyC (c a : R) : a%:P \scale c = a%:P. +Proof. by rewrite /scaleX_poly comp_polyC. Qed. + +End about_scaleX_poly. + +Section about_transformations. +Variable R : fieldType. +(* +Lemma root_shift_1 (p : {poly R}) (a x : R) : + (root p x) = root (p \shift a) (x-a). +Proof. by rewrite !rootE -horner_shift_poly1. Qed. +*) +Lemma root_shift_2 (p : {poly R}) (a x : R) : + root p (x + a) = root (p \shift a) x. +Proof. by rewrite !rootE -{2}(@addrK _ a x) -horner_shift_poly1. Qed. +(* +Lemma root_scale_1 (p : {poly R}) (a x : R) : (a != 0) -> + root p x = root (p \scale a) (x / a). +Proof. +move=> Ha. +by rewrite !rootE horner_scaleX_poly mulrC (@mulrVK _ a _ x) // unitfE. +Qed. +*) +Lemma root_scale_2 (p : {poly R}) (a x : R) : + root p (a * x) = root (p \scale a) x. +Proof. by rewrite !rootE horner_scaleX_poly. Qed. +(* +Lemma root_reciprocal_1 (p : {poly R}) (x : R) : (x != 0) -> + root p x = root (reciprocal_pol p) (x^-1). +Proof. +move=> Hx. +rewrite !rootE horner_reciprocal1; last by rewrite unitfE. +rewrite GRing.mulrI_eq0 //; apply: GRing.lregX. +by apply/lregP. +Qed. +*) +Lemma root_reciprocal_2 (p : {poly R}) (x : R) : x != 0 -> + root p (x^-1) = root (reciprocal_pol p) x. +Proof. +move=> Hx. +rewrite !rootE horner_reciprocal ?unitfE//. +by rewrite mulrI_eq0 //; apply/lregX/lregP. +Qed. +(* +Lemma root_Mobius_1 (p : {poly R}) (x : R) (l r : R) : + (l != r) -> (x != l) -> (x != r) -> + root p x = root (Mobius p l r) ((r - x) / (x - l)). +Proof. +move=> Hlr Hxl Hxr. +rewrite /Mobius. +rewrite -root_shift_2 -(@mulrK _ (x - l) _ 1); last by rewrite unitfE subr_eq0. +rewrite mul1r -mulrDl addrA -(@addrA _ _ (-x) x) (@addrC _ (-x) x) addrA addrK. +rewrite -root_reciprocal_2. + rewrite invrM; last by rewrite unitfE invr_eq0 subr_eq0. + rewrite invrK -root_scale_2 mulrC divrK; + last by rewrite unitfE subr_eq0 eq_sym. + by rewrite -root_shift_2 -addrA (@addrC _ _ l) addrA addrK. + by rewrite unitfE subr_eq0 eq_sym. +apply: GRing.mulf_neq0. + by rewrite subr_eq0 eq_sym. +by rewrite invr_eq0 subr_eq0. +Qed. +*) + +(* TODO(rei): define as an instance of Mobius in pol.v? *) +Definition Mobius' (R : ringType) (p : {poly R}) (a b : R) : {poly R} := +(* Mobius (size p).-1 a b p.? *) + reciprocal_pol ((p \shift a) \scale (b - a)) \shift 1. + +Lemma root_Mobius'_2 (p : {poly R}) (x : R) (l r : R) : + x + 1 != 0 -> + root p ((r + l * x) / (x + 1)) = root (Mobius' p l r) x. +Proof. +move=> Hx. +rewrite /Mobius -root_shift_2 -root_reciprocal_2 //. +rewrite -root_scale_2 -root_shift_2 -{3}(@mulrK _ (x + 1) _ l). + by rewrite -mulrDl {2}(@addrC _ x 1) mulrDr mulr1 addrA + -(addrA r (- l) l) (addrC (-l) l) addrA addrK. +by rewrite unitfE. +Qed. + +Lemma Mobius'M (p q : {poly R}) (l r : R) : + Mobius' (p * q) l r = Mobius' p l r * Mobius' q l r. +Proof. +by rewrite /Mobius' !rmorphM /= reciprocalM rmorphM. +Qed. + +Lemma Mobius'_Xsubc (c l r : R) : (l != r) -> + Mobius' ('X - c%:P) l r = (l - c) *: 'X + (r - c)%:P. +Proof. +move=> Hlr. +rewrite /Mobius' rmorphB /= shift_polyC rmorphB /= scaleX_polyC + /shift_poly comp_polyX rmorphD /= scaleX_polyC /scaleX_poly + comp_polyX -addrA -(rmorphB _ l c) /= reciprocal_monom. + by rewrite rmorphD rmorphM /= comp_polyX !comp_polyC + mulrDl polyC1 mul1r mulrC mul_polyC -addrA (addrC (l - c)%:P _) + -rmorphD /= addrA addrNK. +by rewrite subr_eq0 eq_sym. +Qed. + +Lemma Mobius'_Xsubc_monic (c l r : R) : l != r -> l != c -> + (lead_coef (Mobius' ('X - c%:P) l r))^-1 *: (Mobius' ('X - c%:P) l r) = + 'X + ((r - c) / (l - c))%:P. +Proof. +move=> Hlr Hlc. +rewrite Mobius'_Xsubc // lead_coefE. +have Hlc2 : (l - c) != 0 by rewrite subr_eq0. +have HlcP : ((l - c)%:P == 0) = false. + apply/eqP/eqP. + by rewrite polyC_eq0 subr_eq0. +have Hsize : size ((l - c) *: 'X + (r - c)%:P) = 2%N. + by rewrite -(mul_polyC (l - c) 'X) size_MXaddC HlcP /= size_polyC Hlc2. +have Hcoef1 : ((l - c) *: 'X + (r - c)%:P)`_1 = l - c. + by rewrite coefD coefC addr0 -mul_polyC coefMX coefC /=. +by rewrite Hsize -mul_polyC Hcoef1 mulrDr mul_polyC -rmorphM + mulrC -!mul_polyC mulrA (mulrC _ 'X) -rmorphM (mulrC _ (l - c)) + mulfV //= polyC1 mulr1. +Qed. + +End about_transformations. + +Section about_transformations_and_equality. + +Variable (R : idomainType). + +Lemma shift_poly_eq (p q : {poly R}) (a : R) : + (p == q) = (p \shift a == q \shift a). +Proof. +by rewrite /shift_poly -(subr_eq0 p q) -(@comp_poly2_eq0 _ (p-q) ('X + a%:P)) + ?size_XaddC // rmorphB subr_eq add0r. +Qed. + +Lemma scale_poly_eq (p q : {poly R}) (a : R) : (a != 0) -> + (p == q) = (p \scale a == q \scale a). +Proof. +move=> Ha. +by rewrite /scaleX_poly -(subr_eq0 p q) -(@comp_poly2_eq0 _ (p - q) ('X * a%:P)) + ?size_XmulC // rmorphB subr_eq add0r. +Qed. + +Lemma pdivmu0_0th_neq0 (p : {poly R}) : p != 0 -> (p %/ 'X^(\mu_0 p))`_0 != 0. +Proof. +move=> Hp. +have H0noroot : ~~(root (p %/ 'X^(\mu_0 p)) 0). + rewrite -mu_gt0. + rewrite -eqn0Ngt -(addr0 'X) -(@oppr0 {poly R}) -polyC0 mu_div + ?subn_eq0; by rewrite leqnn. + rewrite Pdiv.CommonIdomain.divp_eq0 negb_or Hp /= negb_or. + rewrite -size_poly_gt0 {1}size_polyXn /= -leqNgt dvdp_leq //. + by rewrite -(addr0 'X) -oppr0 -polyC0 root_mu. +rewrite -horner_coef0. apply: negbT. +by move/rootPf : H0noroot. +Qed. + +Lemma Mobius'0 (p : {poly R}) (a b : R) : a != b -> + (p == 0) = ((Mobius' p a b) == 0). +Proof. +move=> ab; apply/idP/idP => /eqP Hp. + by rewrite /Mobius' Hp /shift_poly /scaleX_poly !comp_polyC + reciprocalC comp_polyC. +rewrite /Mobius' in Hp. +rewrite (shift_poly_eq p 0 a) shift_polyC (@scale_poly_eq _ _ (b - a)). + by rewrite /scaleX_poly comp_polyC -reciprocal0 (shift_poly_eq _ _ 1) + shift_polyC Hp. +by rewrite subr_eq0 eq_sym. +Qed. + +End about_transformations_and_equality. + +From mathcomp Require Import complex. + +Section transformations_in_C. +Local Open Scope complex_scope. + +Variable (R : rcfType). +Local Notation C:= (complex R). + +Local Notation toC := (fun (p : {poly R}) => @map_poly R _ (real_complex R) p). + +Lemma shift_toC (p : {poly R}) (a : R) : toC (p \shift a) = (toC p) \shift a%:C. +Proof. +by rewrite /shift_poly (map_comp_poly _ p ('X + a%:P)) rmorphD /= + map_polyX map_polyC. +Qed. + +Lemma scale_toC (p : {poly R}) (a : R) : toC (p \scale a) = (toC p) \scale a%:C. +Proof. +by rewrite /scaleX_poly (map_comp_poly _ p ('X * a%:P)) rmorphM /= + map_polyX map_polyC. +Qed. + +Lemma reciprocal_toC (p : {poly R}) : + toC (@reciprocal_pol _ p) = reciprocal_pol (toC p). +Proof. +rewrite /reciprocal_pol poly_def rmorph_sum /= poly_def size_map_inj_poly. +- apply: eq_bigr => i _. + rewrite -mul_polyC rmorphM /= map_polyXn /=. + by rewrite !coef_map /= map_polyC /= mul_polyC. +- exact: complexI. +- by rewrite -complexr0. +Qed. + +Lemma Mobius'_toC (p : {poly R}) (l r : R) : + toC (Mobius' p l r) = Mobius' (toC p) l%:C r%:C. +Proof. +by rewrite {2}/Mobius' -shift_toC /= -rmorphB -scale_toC + -reciprocal_toC -shift_toC /Mobius. +Qed. + +(* +Lemma root_Mobius_C_1 : forall (p : {poly R}) (z : C) (l r : R), + (l != r) -> (z != l%:C) -> (z != r%:C) -> + root (toC p) z = + root (toC (Mobius p l r)) ((r%:C - z) / (z - l%:C)). +Proof. +move=> p z l r Hlr Hzl Hzr. +have HlrC : (l%:C != r%:C). + by rewrite -!complexr0 eq_complex /= negb_and eq_refl orbF. +rewrite !rootE Mobius_toC /Mobius -!rootE -@root_shift_2 + -(@mulrK _ (z - l%:C) _ 1). + rewrite mul1r -mulrDl addrA -(@addrA _ _ (-z) z) (@addrC _ (-z) z) addrA + addrK -root_reciprocal_2. + rewrite invrM. + rewrite invrK -root_scale_2 mulrC divrK. + by rewrite -root_shift_2 -addrA (@addrC _ _ l%:C) addrA addrK. + by rewrite unitfE subr_eq0 eq_sym. + by rewrite unitfE subr_eq0 eq_sym. + by rewrite unitfE invr_eq0 subr_eq0. + apply: GRing.mulf_neq0. + by rewrite subr_eq0 eq_sym. + by rewrite invr_eq0 subr_eq0. +by rewrite unitfE subr_eq0. +Qed. +*) + +Lemma root_Mobius'_C_2 (p : {poly R}) (z : C) (l r : R) : + z + 1 != 0 -> + root (toC p) ((r%:C + l%:C * z) / (z + 1)) = root (toC (Mobius' p l r)) z. +Proof. +move=> Hz. +rewrite !rootE Mobius'_toC /Mobius -!rootE -root_shift_2 -root_reciprocal_2 //. +rewrite -root_scale_2 -root_shift_2 -{3}(@mulrK _ (z + 1) _ l%:C). + by rewrite -mulrDl {2}(@addrC _ z 1) mulrDr mulr1 addrA + -(addrA r%:C (- l%:C) l%:C) (addrC (-l%:C) l%:C) addrA addrK. +by rewrite unitfE. +Qed. + +End transformations_in_C. + +Lemma mul_polyC_seqmul (R : rcfType) (p : {poly R}) (a : R) : + a != 0 -> + polyseq (a *: p) = seqmul (nseq (size p) a) p. +Proof. +move=> Ha; elim/poly_ind : p => [ | p c IHp]. + by rewrite size_poly0 /= seqmul0 -mul_polyC mulr0 -polyC0 polyseq0. +rewrite -{2}(cons_poly_def) -mul_polyC mulrDr mulrA mul_polyC -polyCM. +rewrite -!cons_poly_def !polyseq_cons. +case Hp : (nilp p); last first. + rewrite ifT; last first. + rewrite nil_poly in Hp. + by rewrite nil_poly -mul_polyC mulf_neq0 // ?Hp // polyC_eq0. + by rewrite seqmul_cons IHp. +rewrite ifF; last first. + rewrite nil_poly in Hp. + by rewrite nil_poly -mul_polyC mulf_eq0 Hp orbT. +rewrite /= size_polyC. +have [->|Hc] := eqVneq c 0; first by rewrite mulr0 seqmul0 polyseqC eq_refl. +by rewrite !polyseqC mulf_neq0//= Hc seqmul_cons. +Qed. + +Lemma changes_mulC (R : rcfType) (p : {poly R}) (a : R) : a != 0 -> + changes p = changes (a *: p). +Proof. +move=> Ha. +rewrite mul_polyC_seqmul //=. +case: p. +elim => [Hs//|b/=]. +case => [_ _ |c l IHcl Hs] //=. + by rewrite !addn0 !mulr0. +rewrite /= in IHcl. +rewrite IHcl //= /seqmul. +apply/eqP. +rewrite eqn_add2r !mulrA (mulrC a) -(mulrA b) -expr2 (mulrC _ (a^+2)) -mulrA + eq_sym. +by rewrite (@pmulr_rlt0 _ (a ^+2) (b * c)) // exprn_even_gt0. +Qed. + +Section thm_3_cercles_partie1. +Local Open Scope complex_scope. + +Variables (R : rcfType) (l r : R) (Hlr_le : l < r). + +Local Notation C := (complex R). + +Local Notation toC := (fun (p : {poly R}) => @map_poly R _ (real_complex R) p). + +Lemma HlrC : l%:C != r%:C. +Proof. by rewrite -!complexr0 eq_complex /= negb_and lt_eqF. Qed. + +Definition notinC (z : C) := + 0 <= (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 + r * l. + +Lemma notinC_Re_lt0_1 : forall (z : C), z != l%:C -> + notinC z = (Re ((r%:C - z) / (z - l%:C)) <= 0). +Proof. +case => a b Hab. +rewrite /notinC /=. +simpc. +rewrite !mulrA -(mulNr (b * b) _) -mulrDl + -expr2 (mulrDl r (-a) _) (mulrC r (a - l)) (mulrC (-a) _) (mulrDl _ _ r) + (mulrDl _ _ (-a)) mulrNN mulrN -expr2 !addrA (addrC (a * r) _) + -(addrA _ (a * r) _ ) (addrC (a * r) _ ) (mulrC a r) addrA + (addrC (- l * r) _ ) -(addrA _ (r * a) (l * a)) -(mulrDl _ _ a) + -(addrA (- a ^+2) _ _) (addrC (- l * r)) -!addrA (addrC _ (- b^+2)) + !addrA mulNr (mulrC l r) (addrC r l) -oppr_ge0 -[X in (_ = (0 <= X))]mulNr + !opprD !opprK pmulr_lge0 //. +rewrite invr_gt0 lt_neqAle addr_ge0 ?sqr_ge0 // andbT eq_sym paddr_eq0 ?sqr_ge0 // + negb_and !sqrf_eq0 subr_eq0. +by rewrite -complexr0 eq_complex negb_and /= in Hab. +Qed. + +Lemma notinC_Re_lt0_2 (z : C) : z + 1 != 0 -> + (notinC ((r%:C + l%:C * z) / (z + 1))) = (Re z <= 0). +Proof. +move=> Hz. +rewrite (@notinC_Re_lt0_1 ((r%:C + l%:C * z) / (z + 1))) /=. + rewrite -{1}(@mulrK _ (z+1) _ r%:C); last by rewrite unitfE. + rewrite -(mulNr (r%:C + l%:C * z) _ ) -(mulrDl _ _ (z+1)^-1) mulrDr mulr1 + opprD !addrA addrK -{3}(@mulrK _ (z+1) _ l%:C); last by rewrite unitfE. + rewrite -(mulNr (l%:C * (z+1)) _ ) -(mulrDl _ _ (z+1)^-1) mulrDr mulr1 + opprD !addrA addrK invrM. + rewrite invrK !mulrA -(mulrA _ _ (z+1)) (mulrC _ (z+1)) !mulrA mulrK; + last by rewrite unitfE. + rewrite -mulNr -mulrDl (mulrC _ z) mulrK //. + by rewrite unitfE subr_eq0 eq_sym HlrC. + by rewrite unitfE subr_eq0 eq_sym HlrC. + by rewrite -unitrV invrK unitfE. +rewrite -subr_eq0 -{2}(@mulrK _ (z + 1) _ l%:C); last by rewrite unitfE. +rewrite -mulNr -mulrDl mulrDr mulr1 opprD addrA addrK mulf_neq0 //. + by rewrite subr_eq add0r eq_sym HlrC. +by rewrite invr_eq0. +Qed. + +(* Theorem 10.47 i. *) +Theorem three_circles_1 (p : {poly R}) : + (forall (z : C), root (toC p) z -> (notinC z)) -> + changes (Mobius' p l r) = 0%N. +Proof. +move=> H. +have [/eqP|Hp0] := eqVneq p 0. + rewrite (@Mobius'0 _ p l r) ?lt_eqF// => /eqP ->. + by rewrite polyseq0. +rewrite (@changes_mulC R (Mobius' p l r) (lead_coef (Mobius' p l r))^-1). + apply: monic_roots_changes_eq0 => [ | z Hz]. + by rewrite monicE lead_coefZ mulrC -unitrE unitfE lead_coef_eq0 + -Mobius'0 ?lt_eqF// Hp0. + case/altP : (z+1 =P 0) => [/eqP Hz2 | Hz2]. + rewrite addr_eq0 eq_complex in Hz2. + move/andP : Hz2; case => /eqP Hrez _. + by rewrite Hrez raddfN lerN10. + rewrite map_polyZ rootZ /= -?root_Mobius'_C_2 // in Hz. + rewrite -notinC_Re_lt0_2 //. + apply: H => //. + rewrite -complexr0 eq_complex /= negb_and eq_refl orbF. + by rewrite invr_eq0 lead_coef_eq0 -Mobius'0 ?lt_eqF// negbT. +by rewrite invr_eq0 lead_coef_eq0 -Mobius'0 ?lt_eqF// negbT. +Qed. + +End thm_3_cercles_partie1. + +Section thm_3_cercles_partie2. +Variable R : rcfType. + +Local Notation C := (complex R). + +Definition inC1 := fun (l r : R) (z : C) => + (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 - + (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0. + +Definition inC2 := fun (l r : R) (z : C) => + (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 + + (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0. + +Definition inC12 := fun (l r : R) (z : C) => + ((Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 - + (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0) || + ((Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 + + (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0). + +Lemma inC1_or_inC2 (l r : R) (z : C) : + (inC1 l r z) || (inC2 l r z) = (inC12 l r z). +Proof. by []. Qed. + +Definition inB1 (z : C) := + (Re z - 1 <= 0) && ((Im z)^+2 <= 3%:R * (Re z - 1) ^+2). + +Lemma inB_inB1 : forall (z : C), inB z = inB1 (z + 1). +Proof. +case => a b. +by rewrite /inB1 /= addrK addr0 /inB. +Qed. + +Lemma inB1_help : forall (z : C), (inB1 z) = + (((Num.sqrt 3%:R) * (Re z - 1) - Im z <= 0) && + (0 <= - (Num.sqrt 3%:R * (Re z - 1)) - Im z)). +Proof. +case=> a b. +rewrite /inB1 /=. +case/altP : (a - 1 =P 0) => Ha. + rewrite Ha /= mulr0 oppr0 add0r lexx/= (expr2 0) !mulr0. + by rewrite -eq_le oppr_eq0 -sqrf_eq0 eq_le sqr_ge0 andbT. +rewrite -{1}(sqr_sqrtr (a:=3%:R)); last by apply: ler0n. +rewrite -exprMn -(ler_sqrt (b^+2)). + rewrite !sqrtr_sqr normrM (ger0_norm (x := Num.sqrt 3%:R)); + last by apply: sqrtr_ge0. + apply/idP/idP => /andP [] => H1 H2. + rewrite -(normrN (a - 1)) (gtr0_norm (x:= - (a - 1))) in H2. + by rewrite ler_norml mulrN opprK -subr_le0 + -[X in (_ && X)]subr_ge0 in H2. + by rewrite oppr_gt0 lt_def H1 eq_sym Ha. + have Hb : `|b| <= Num.sqrt 3%:R * -(a - 1). + by rewrite ler_norml mulrN opprK -subr_le0 -[X in (_ && X)]subr_ge0 H1 H2. + have Ha2 : (0 <= - (a - 1)). + rewrite -(pmulr_lge0 (x:=Num.sqrt 3%:R)); last by rewrite sqrtr_gt0 ltr0n. + by rewrite mulrC (@le_trans _ _ `| b |). + by rewrite -oppr_ge0 Ha2 /= -(normrN (a-1)) (ger0_norm (x:= -(a-1))). +by rewrite exprMn mulr_ge0 // ?sqr_ge0//. +Qed. + +Lemma Re_invc (z : C) : Re z^-1 = Re z / ((Re z) ^+ 2 + (Im z) ^+2). +Proof. by case: z. Qed. + +Lemma Im_invc : forall (z : C), Im z^-1 = (- Im z) / ((Re z) ^+ 2 + (Im z) ^+2). +Proof. by case => a b; rewrite mulNr. Qed. + +Lemma inB1_notinC1201 : forall (z : C), z != 0 -> inB1 z = ~~ inC12 0 1 (z ^-1). +Proof. +case=> a b Hz. +rewrite -inC1_or_inC2 negb_or inB1_help /=. +have H : a ^+ 2 + b ^+ 2 \is a GRing.unit. + rewrite eq_complex /= negb_and in Hz. + case/orP: Hz=> H; + by rewrite unitfE paddr_eq0 ?sqr_ge0 // negb_and !sqrf_eq0 H ?orbT. +have H3 : (Num.ExtraDef.sqrtr (GRing.natmul (V:=R) (GRing.one R) (3))) + \is a GRing.unit. + by rewrite unitfE sqrtr_eq0 -ltNge ltr0n. +rewrite /inC1 /= -leNgt add0r oppr0 mul0r !addr0 !mul1r. +rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA + exprMn -(mulNr b) exprMn sqrrN -mulrDl + (expr2 ((a^+2 + b^+2)^-1)) -{2}(mulr1 (a^+2 + b^+2)) -invrM // + -mulf_div [x in (0 <= _ + x + _)]mulrC !mulrA (mulrK (x:=(a^+2 + b^+2))) //. +rewrite -[in x in _ = x](mulNr a) -mulrDl. +rewrite -{5}(opprK 1) -(opprD a (- 1)) -mulrA -invrM //. +rewrite -[in x in _ = x]mulNr -(mul1r ( - (a - 1) / (a ^+ 2 + b ^+ 2))) + -{5}(@mulrK _ (Num.sqrt 3%:R) _ 1) //. +rewrite mul1r mulf_div -mulrDl mulrN -[in x in (_ = x)]opprD. +rewrite /inC2 /= -leNgt add0r oppr0 mul0r !addr0 !mul1r. +rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA + exprMn -(mulNr b) exprMn sqrrN -mulrDl + (expr2 ((a^+2 + b^+2)^-1)) -{3}(mulr1 (a^+2 + b^+2)) -invrM // + -mulf_div [x in (0 <= _ + x + _)]mulrC !mulrA (mulrK (x:=(a^+2 + b^+2))) // + -[in x in (_ = _ && x)]mulNr -mulrDl -{8}(opprK 1) -(opprD a (- 1)) -mulrA + -invrM //. +rewrite -(mul1r ( - (a - 1) / (a ^+ 2 + b ^+ 2))) + -{8}(@mulrK _ (Num.sqrt 3%:R) _ 1) //. +rewrite mul1r mulf_div -mulrDl mulNr oppr_ge0 pmulr_lge0. + rewrite pmulr_lle0 ?mulrN //. + by rewrite invr_gt0 lt_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 // + addr_ge0 // sqr_ge0. +by rewrite invr_gt0 lt_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 // + addr_ge0 // sqr_ge0. +Qed. + +Local Open Scope complex_scope. + +Lemma notinC1201_lr_scale (l r : R) : forall (z : C), l != r -> + ~~ inC12 0 1 z = ~~ inC12 0 (r - l) ((r - l)%:C * z). +Proof. +case=> a b Hlr. +rewrite !/inC12. simpc. rewrite /=. +rewrite !exprMn !(mulrA (r - l) _ a) !(mulrA (r - l) _ b) + -expr2 -(mulrN _ a) -mulrA -(mulrN _ (b / Num.sqrt 3%:R)) + -!(mulrDr ((r - l)^+2)) !negb_or -!leNgt. +by rewrite !pmulr_rge0 // lt_def sqr_ge0 sqrf_eq0 subr_eq0 eq_sym Hlr. +Qed. + +Lemma notinC12lr_shift (l r : R) : forall (z : C), l != r -> + ~~ inC12 0 (r - l) z = ~~ inC12 l r (z + l%:C). +Proof. +case=> a b Hlr. +rewrite !/inC12. simpc. rewrite /= !negb_or -!leNgt. +by rewrite (expr2 (a+l)) (mulrDl a l) !mulrDr (mulrDl l r) + (mulrDl l r) -!expr2 !opprD + [l * a + _]addrC !addrA addrK -(addrA _ (- (r * a)) _) + (addrC (- (r * a)) _) !addrA addrK -(addrA _ (a * l) _) + (addrC (a * l)) (mulrC a l) -{5 9}(opprK l) mulNr -opprD + -mulrDl [X in (_ = (0 <= X) && _)]addrC [X in (_ = _ && (0 <= X))]addrC + !addrA (addrC (l * r)) -(addrA _ (l * r) _) + (addrC (l * r)) (mulrC l r) !addrA addrK. +Qed. + +Lemma inB_notinC12 (l r : R) (z : C) : l != r -> z + 1 != 0 -> + inB z = ~~ inC12 l r ((r%:C + l%:C * z) / (z + 1)). +Proof. +move=> Hlr Hz. +have H : (r%:C + l%:C * z) / (z + 1) = ((r - l)%:C / (z + 1) + l%:C). + rewrite -{2}[l%:C](@mulrK _ (z + 1)); last by rewrite unitfE. + by rewrite -mulrDl {2}[z+1]addrC mulrDr mulr1 rmorphB /= !addrA addrNK. +by rewrite H -notinC12lr_shift // -notinC1201_lr_scale // + -inB1_notinC1201 // -inB_inB1. +Qed. + +Lemma changes_nseq : forall (s : seq R) (a : R), a != 0 -> + changes (seqmul (nseq (size s) a) s) = changes s. +Proof. +elim => [ | c l IHl a Ha] //. +case : l IHl => [IH |b l IHbl ] //. + by rewrite /= !mulr0 addn0. +have -> : (changes [::c, b & l]) = ((c * b < 0)%R + changes [:: b & l])%N. + by []. +rewrite -(IHbl a) //. +suff : ((a * c) * (a * b) < 0) = (c * b < 0) by move=> <-. +rewrite (mulrC a b) -mulrA (mulrC a) -!mulrA -expr2 mulrA. +by rewrite pmulr_llt0 // exprn_even_gt0. +Qed. + +Lemma seqn0_nseq : forall (s : seq R) (a : R), a != 0 -> + seqmul (nseq (size (seqn0 s)) a) (seqn0 s) = + seqn0 (seqmul (nseq (size s) a) s). +Proof. +elim => [ | c l IHl a Ha] //. +case Hc : (c != 0). + have Hac : a * c != 0 by apply: mulf_neq0. + by rewrite seqmul_cons /= Hac /= Hc /= seqmul_cons /= -IHl. +have Hac : (a * c != 0) = false by rewrite mulf_eq0 negb_or Ha Hc. +by rewrite seqmul_cons /= Hc /= Hac /= IHl. +Qed. + +Lemma inBneg1 : @inB R (-1). +Proof. +by rewrite /inB !raddfN lerN10 /= oppr0 sqrrN !expr2 mulr0 !mulr1 ler0n. +Qed. + +Local Notation toC := (fun (p : {poly R}) => @map_poly R _ (real_complex R) p). + +(* (~~ root p r) because of (~~ root (Mobius p l r) 0) *) +Theorem three_circles_2 (l r : R) (p : {poly R}) (a : R) : + ~~ root p r -> l < a < r -> ~~ root p a -> + (forall z : C, root (toC p) z -> ~~ inC12 l r z) -> + changes (seqn0 (Mobius' (p * ('X - a%:P)) l r)) = 1%N. +Proof. +move=> Hpnorootr /andP [] Hal Har Hpnoroota H. +have Hlr : l != r by rewrite lt_eqF// (lt_trans Hal). +have Hal2 : l != a by rewrite negbT // lt_eqF. +have [Hp|Hp] := eqVneq p 0. + have : false => //. + by rewrite -(andbN (root p a)) Hpnoroota Hp root0. +have Hlc1 : (lead_coef (Mobius' (R:=R) (p * ('X - a%:P)) l r))^-1 != 0. + rewrite invr_neq0 // Mobius'M lead_coefM mulf_neq0 //; + rewrite lead_coef_eq0 -Mobius'0 // negbT //. + exact: polyXsubC_eq0. +have Hl2 : lead_coef (Mobius' p l r) != 0 by rewrite lead_coef_eq0 -Mobius'0. +rewrite -(@changes_nseq _ + (lead_coef (Mobius' (p * ('X - a%:P)) l r)) ^-1) // + seqn0_nseq // -mul_polyC_seqmul //. +rewrite Mobius'M lead_coefM -mul_polyC invrM ?unitfE; [ | by [] |]; last first. + by rewrite lead_coef_eq0 -Mobius'0 // negbT // polyXsubC_eq0. +rewrite rmorphM /= mulrA mulrC !mulrA + (mulrC (Mobius' ('X - a%:P) _ _) _) + mul_polyC -mulrA mul_polyC mulrC + [in X in (changes (R:=R) (seqn0 (polyseq (_ * X))))] + (@Mobius'_Xsubc_monic R a l r Hlr Hal2) + -(opprK ((r - a) / (l - a))%:P) -polyCN. + apply: normal_changes. + by rewrite oppr_gt0 pmulr_rlt0 ?invr_lt0 ?subr_lt0 // subr_gt0. + apply: normal_root_inB => [ | z Hz]. + rewrite monicE lead_coef_lreg. + by rewrite mulrC -unitrE unitfE. + exact/lregP/invr_neq0. + have [/eqP Hz2|Hz2] := eqVneq (z + 1) 0. + rewrite addr_eq0 in Hz2. + by rewrite (eqP Hz2) inBneg1. + rewrite (inB_notinC12 Hlr) //. + rewrite -mul_polyC rmorphM /= map_polyC mul_polyC rootZ in Hz. + apply: H. + by rewrite root_Mobius'_C_2. + by rewrite /= eq_complex negb_and/= invr_neq0. +rewrite rootZ. + rewrite -root_Mobius'_2; last by rewrite add0r oner_neq0. + by rewrite mulr0 addr0 add0r invr1 mulr1. +exact: invr_neq0. +Qed. + +End thm_3_cercles_partie2. diff --git a/theories/xssralg.v b/theories/xssralg.v new file mode 100644 index 0000000..9af8ea7 --- /dev/null +++ b/theories/xssralg.v @@ -0,0 +1,1166 @@ +(* TODO(rei): remove this file? *) +From mathcomp Require Import ssreflect eqtype ssrbool ssrnat fintype seq ssrfun. +From mathcomp Require Import bigop (*groups*) choice. +From mathcomp Require Export ssralg. + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +(*Import GroupScope .*) +Import GRing.Theory . + +Local Open Scope ring_scope . + +Structure orderb (M : Type) (R : M -> M -> bool) : Type := Orderb { + reflb : reflexive R; + antisymb : antisymmetric R; + transb : transitive R +} . + +Structure sorderb (M : Type) (R : M -> M -> bool) : Type := SOrderb { + irreflsb : irreflexive R; + transsb : transitive R +} . + +Reserved Notation "x <<= y" (at level 70, no associativity) . +Reserved Notation "x < R -> bool) := + forall (x y₁ y₂ : R), r 0 x -> r y₁ y₂ -> r (x * y₁) (x * y₂) . + + Definition rcompatible (r : R -> R -> bool) := + forall (x y₁ y₂ : R), r 0 x -> r y₁ y₂ -> r (y₁* x) (y₂ * x) . + + +End Compatible . + + +(* -------------------------------------------------------------------- *) +Module GOrdered . + (* ------------------------------------------------------------------ *) + Module OComRing. + + Record mixin_of (G : GRing.Ring.type) : Type := Mixin { + leb : G -> G -> bool; + ltb : G -> G -> bool; + _ : sorderb ltb; + _ : forall x y, leb x y -> forall z, leb (x+z) (y+z); + _ : forall x y, leb x y = (ltb x y) || (x == y); + _ : forall x y, (leb x y) || (leb y x); + _ : lcompatible ltb + } . + + Record class_of (R : Type) : Type := Class { + base :> GRing.ComRing.class_of R; + mixin :> mixin_of (GRing.Ring.Pack base R) + } . + + + Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}. + + Definition class cT := let: Pack _ c _ := cT return class_of cT in c. + Definition unpack K (k : forall T (c : class_of T), K T c) cT := + let: Pack T c _ := cT return K _ (class cT) in k _ c. + Definition repack cT : _ -> Type -> type := + let k T c p := p c in unpack k cT. + + Definition pack := let k T c m := + Pack (@Class T c m) T in GRing.ComRing.unpack k. + + Definition eqType cT := Equality.Pack (class cT) cT. + Definition choiceType cT := Choice.Pack (class cT) cT. + Definition zmodType cT := GRing.Zmodule.Pack (class cT) cT. + Definition ringType cT := GRing.Ring.Pack (class cT) cT. + Coercion comringType cT := GRing.ComRing.Pack (class cT) cT. + + Definition EtaMixin R leb ltb ltr_sorderb leb_addr leb_ltb_eq leb_total ltb_lcompatible := + let _ := @Mixin R leb ltb ltr_sorderb leb_addr leb_ltb_eq leb_total ltb_lcompatible in + @Mixin (GRing.Ring.Pack (GRing.Ring.class R) R) leb ltb ltr_sorderb leb_addr leb_ltb_eq leb_total ltb_lcompatible. + + + End OComRing . + + Canonical Structure OComRing.eqType. + Canonical Structure OComRing.choiceType. + Canonical Structure OComRing.zmodType. + Canonical Structure OComRing.ringType. + Canonical Structure OComRing.comringType. + + Bind Scope comring_scope with OComRing.sort . + + Definition ltbDef (R : OComRing.type) : R -> R -> bool := OComRing.ltb (OComRing.class R). + Notation ltb := (@ltbDef _). + + Definition lebDef (R : OComRing.type) : R -> R -> bool := OComRing.leb (OComRing.class R). + Notation leb := (@lebDef _). + +(* Definition leb R := OComRing.leb (OComRing.class R).*) +(* Definition ltb R := OComRing.ltb (OComRing.class R).*) + + Local Notation "x <<= y" := (leb x y) . + Local Notation "x < [T [? []]] . Qed . + + Lemma ltr_irrefl : irreflexive (@ltbDef G). + Proof . by case ltr_sorderb . Qed . + + Lemma ltr_trans : transitive (@ltbDef G) . + Proof . by case ltr_sorderb . Qed . + + Lemma ltr_lcompat : lcompatible (@ltbDef G) . + Proof . by case G => [T [? []]] . Qed . + + Lemma ltr_rcompat : rcompatible (@ltbDef G). + Proof. by move=> x y z; rewrite mulrC [z * _]mulrC; exact: ltr_lcompat. Qed. + + + (* ------------------------------------------------------------------ *) + + Lemma ler_ltreq : forall x y, (x <<= y) = (x < [T [? []]]. Qed. +(* Proof . + move=> x y; rewrite ltr_lerne /negb; case D: (x == y) . + + by rewrite (eqP D) ler_refl . + + by rewrite orbF andbT . + Qed . +*) + + Lemma ler_refl : reflexive (@lebDef G) . + Proof. by move=> x; rewrite ler_ltreq eqxx orbT. Qed. + + Lemma ler_antisym : forall (x y : G), x <<= y -> y <<= x -> x = y . + Proof . + case: ltr_sorderb => h3 h4 x y; rewrite !ler_ltreq. + case/orP=> hxy; last by move/eqP: hxy. + case/orP=> hyx; last by move/eqP: hyx. + by move: (h4 _ _ _ hxy hyx); rewrite (h3 x). + Qed . + + Lemma ler_trans : transitive (@lebDef G) . + Proof . + case: ltr_sorderb=> h1 h2. + move=> x y z; rewrite !ler_ltreq; case/orP; last first. + move/eqP->; case/orP; by [move-> | move/eqP->; rewrite eqxx orbT]. + move=> hyx; case/orP; last by move/eqP<-; rewrite hyx. + by move=> hxz; rewrite (h2 _ _ _ hyx). + Qed. + + Lemma ler_order : orderb (@lebDef G) . + Proof . + constructor. + - exact: ler_refl. + - move=> x y; case/andP; exact: ler_antisym. + - exact: ler_trans. + Qed. + + Lemma ler_total : forall x y, (x <<= y) || (y <<= x) . + Proof . by case G => [T [? []]] . Qed . + + Lemma ler_lcompat : lcompatible (@lebDef G) . + Proof . + move=> x y z; rewrite !ler_ltreq => px. + case/orP; last by move/eqP->; rewrite eqxx orbT. + move=> hyz; case/orP: px => hx; first by rewrite ltr_lcompat. + by rewrite -(eqP hx) !mul0r eqxx orbT. + Qed. + + Lemma ler_rcompat : rcompatible (@lebDef G). + Proof. by move=> x y z; rewrite mulrC [z * _]mulrC; exact: ler_lcompat. Qed. + + Lemma eq_ler : forall x y, (x == y) = (x <<= y) && (y <<= x) . + Proof . + move=> x y; apply/idP/idP . + + by move/eqP => ->; rewrite ler_refl . + + by case/andP=> Hxy Hyx; rewrite (ler_antisym Hxy Hyx) . + Qed . + + (* ------------------------------------------------------------------ *) + + + + Lemma ltr_lerne : forall x y, (x < x y; rewrite ler_ltreq; case e: (x < //; rewrite (eqP exy) ltr_irrefl. + Qed . + + Lemma ltr_ne : forall x y, (x < (x != y) . + Proof. by move=> x y; rewrite ltr_lerne; case/andP. Qed. + + Lemma ltrW : forall x y, x < x <<= y . + Proof . by move=> x y H; rewrite ler_ltreq H . Qed . + + Lemma lerNgtr : forall x y, (x <<= y) = ~~ (y < x y; rewrite ltr_lerne eq_ler; case e: (y <<= x); rewrite ?negbK //=. + by move: (ler_total x y); rewrite e orbF. + Qed. + + Lemma ltr_ler_trans : + forall x y z, x < y <<= z -> x < x y z Hxy Hyz; rewrite ltr_lerne; apply/andP; split . + + by apply ler_trans with y; first apply ltrW . + + apply/eqP; move=> H; subst z . + rewrite ltr_lerne in Hxy; case/andP: Hxy => Hxy . + by rewrite eq_ler Hyz Hxy . + Qed . + + + Lemma ler_ltr_trans : forall x y z, + x <<= y -> y < x < x y z Hxy Hyz; rewrite ltr_lerne; apply/andP; split . + + by apply ler_trans with y; last apply ltrW . + + apply/eqP; move=> H; subst z . + rewrite ltr_lerne in Hyz; case/andP: Hyz => Hyz . + by rewrite eq_ler Hyz Hxy . + Qed. + (* ------------------------------------------------------------------ *) + + Lemma ltrN : forall x y, x < ~~ (y < x y; case e: (y < //; move/(ltr_trans e); rewrite ltr_irrefl. + Qed. + + + Lemma ltrNger : forall x y, (x < x y; rewrite lerNgtr negbK . + Qed . + + (* ------------------------------------------------------------------ *) + Lemma lerTl : forall x y, x <<= y -> forall z, x+z <<= y+z . + Proof . by case G => T [? []] . Qed . + + Lemma lerTr : forall x y, x <<= y -> forall z, z+x <<= z+y . + Proof . + by move=> x y Hxy z; rewrite ![z+_]addrC; apply lerTl . + Qed . + + Lemma lerTlb : forall z x y, (x+z <<= y+z) = (x <<= y) . + Proof . + move=> z x y; apply /idP/idP => H; last by apply lerTl . + rewrite -[x](addr0) -(addrN z) -[y](addr0) -(addrN z) . + by rewrite !addrA; apply lerTl . + Qed . + + Lemma lerTrb : forall z x y, (z+x <<= z+y) = (x <<= y) . + Proof . by move=> z x y; rewrite ![z+_]addrC; apply lerTlb . Qed . + + (* ------------------------------------------------------------------ *) + Lemma ltrTl : forall x y, x < forall z, x+z < x y H z; rewrite ltr_lerne; apply/andP; split . + + by apply lerTl; apply ltrW . + + rewrite ltr_lerne in H; case/andP: H => _ H . + by apply/eqP => Hz; rewrite (addIr Hz) eqxx in H . + Qed . + + Lemma ltrTr : forall x y, x < forall z, z+x < x y Hxy z; rewrite ![z+_]addrC; apply ltrTl . + Qed . + + Lemma ltrTlb : forall z x y, (x+z < z x y; apply/idP/idP => H; last by apply ltrTl . + rewrite -[x](addr0) -(addrN z) -[y](addr0) -(addrN z) . + by rewrite !addrA; apply ltrTl . + Qed . + + Lemma ltrTrb : forall z x y, (z+x < z x y; rewrite ![z+_]addrC; apply ltrTlb . Qed . + + (* ------------------------------------------------------------------ *) + Lemma lerT : + forall (x₁ y₁ x₂ y₂ : G), x₁ <<= y₁ -> x₂ <<= y₂ -> x₁ + x₂ <<= y₁ + y₂ . + Proof . + move=> x₁ y₁ x₂ y₂ Hx Hy; apply ler_trans with (x₁+y₂) . + by apply lerTr . by apply lerTl . + Qed . + + Lemma lerT0 : + forall (x y : G), 0 <<= x -> 0 <<= y -> 0 <<= x + y . + Proof . + by move=> x y Hx Hy; rewrite -[0]addr0; apply lerT . + Qed . + + + Lemma ler0T : + forall (x y : G), x <<= 0 -> y <<= 0 -> x + y <<= 0. + Proof . + by move=> x y Hx Hy; rewrite -[0]add0r; apply lerT . + Qed . + + Lemma ltrT : + forall (x₁ y₁ x₂ y₂ : G), x₁ < x₂ < x₁ + x₂ < x₁ y₁ x₂ y₂ H1 H2; apply ltr_ler_trans with (y₁ + x₂) . + - by apply ltrTl . + - by apply: lerT; rewrite ?ler_refl //; apply: ltrW. + Qed . + + Lemma ltr_lerT : + forall (x₁ y₁ x₂ y₂ : G), x₁ < x₂ <<= y₂ -> x₁ + x₂ < x₁ y₁ x₂ y₂ H1 H2; apply ltr_ler_trans with (y₁ + x₂) . + by apply ltrTl . by apply lerTr . + Qed . + + Lemma ltrT0 : + forall (x y : G), 0 < 0 < 0 < x y Hx Hy; rewrite -[0]addr0; apply ltrT => //. + Qed . + + Lemma ltr0T : + forall (x y : G), x < y < x + y < x y Hx Hy; rewrite -[0]add0r; apply ltrT . + Qed . + + + + (* ------------------------------------------------------------------ *) + Lemma ler_oppger : forall x y, (-x <<= -y) = (y <<= x) . + Proof . + move=> x y; rewrite -(lerTlb x) addNr -(lerTrb y) . + by rewrite addrA addrN addr0 add0r . + Qed . + + Lemma le0r_geNr0 : forall x, (0 <<= -x) = (x <<= 0) . + Proof . by move => x; rewrite -{1}oppr0 ler_oppger . Qed . + + Lemma ger0_leNr0 : forall x, (0 <<= x) = (- x <<= 0). + Proof. by move=> x; rewrite -{2}oppr0 ler_oppger. Qed. + + Lemma ltr_oppgtr : forall x y, (-x < x y . + rewrite !ltr_lerne ler_oppger; case (y <<= x) => //= . + apply congr1; apply/eqP/eqP => [H|->//] . + by rewrite -[y]opprK -[x]opprK H . + Qed . + + Lemma lt0r_gtNr0 : forall x, (0 < x; rewrite -{1}oppr0 ltr_oppgtr . Qed . + + Lemma gtr0_ltNr0 : forall x, (0 < x; rewrite -[x]opprK lt0r_gtNr0 opprK. Qed. + + Lemma opp_ler_ler0 : forall x, ( -x <<= x) = (0 <<= x). + Proof. + move=> x;rewrite -(lerTlb x) addNr. + case e : (0 <<= x); first by rewrite lerT0 //. + by apply: negbTE; rewrite lerNgtr negbK ltr0T // ltrNger e. + Qed. + + Lemma opp_lrr_lrr0 : forall x, ( -x < x;rewrite -(ltrTlb x) addNr. + case e : (0 < x;rewrite -(lerTlb x) addNr. + case e : (x <<= 0); first by rewrite ler0T //. + by apply: negbTE; rewrite lerNgtr negbK ltrT0 // ltrNger e. + Qed. + + Lemma lrr_opp_lrr0 : forall x, ( x < x;rewrite -(ltrTlb x) addNr. + case e : (x < 0 <<= y -> 0 <<= x * y . + Proof . + by move=> x y Hx Hy; rewrite -[0](mulr0 x); apply ler_lcompat . + Qed . + + Lemma ler_neg0_lcompat : forall x y, x <<= 0 -> y <<= 0 -> 0 <<= x * y . + Proof . + move=> x y Hx Hy . + by rewrite -mulrNN; apply ler_0_lcompat; rewrite le0r_geNr0 . + Qed . + + Lemma ltr_0_1 : 0 < // H . + by rewrite -[1](mulr1 1); apply ler_neg0_lcompat . + Qed . + + + (* ------------------------------------------------------------------ *) + Lemma ler_add_0l : forall x y, 0 <<= x -> 0 <<= y -> x+y = 0 -> x = 0 . + Proof . + move=> x y Hx Hy; move/(congr1 (+%R^~ -y)) . + rewrite -addrA addrN addr0 add0r; move=> H; subst x . + rewrite -ler_oppger oppr0 in Hy . + by apply/eqP; rewrite eq_ler Hx Hy . + Qed . + + Lemma ler_add_0r : forall x y, 0 <<= x -> 0 <<= y -> x+y = 0 -> y = 0 . + Proof . + move=> x y Hx Hy Hxy; apply ler_add_0l with x => // . + by rewrite addrC . + Qed . + + (* ------------------------------------------------------------------ *) + CoInductive ler_xor_gtr (x y : G) : bool -> bool -> Set := + | LerNotGtr of x <<= y : ler_xor_gtr x y true false + | GtrNotLer of y < bool -> Set := + | LtrNotGer of x < x y; rewrite ltrNger; case Hxy: (x <<= y); constructor=> // . + by rewrite ltrNger Hxy . + Qed. + + Lemma ltrP : forall x y, ltr_xor_ger x y (x < x y; rewrite lerNgtr; case Hxy: (x < // . + by rewrite lerNgtr Hxy . + Qed . + + CoInductive compare x y : bool -> bool -> bool -> Set := + | CompareLt of x < x y; rewrite ltrNger eq_ler andbC ltr_lerne . + case: ltrP; [by constructor | rewrite ler_ltreq; case: lerP => //=] . + + by move=> _; move/eqP => ->; rewrite eqxx; constructor . + + by move=> Hxy _; rewrite (ltr_ne Hxy); constructor . + Qed . + + Lemma ltrNgtr : forall x y, x < ~~(y < x y; case: compareP . Qed . + + (* ------------------------------------------------------------------ *) + + Lemma χ0_ltr : forall n, (0 : G) < [|n IH]; [apply ltr_0_1 | rewrite 2!mulrS; apply ltrTr] . + elim=> [|n IH]; [by apply ltr_0_1 | apply: ltr_trans] . + by apply IH . by rewrite 2!mulrS; apply ltrTr; apply HnSn . + Qed . + + Lemma χ0 : forall n, 1 *+ n.+1 != 0 :> G. + Proof . + move=> n; case D: (n.+1%:R == 0) => //= . + by move/eqP: D => D; have H := χ0_ltr n; rewrite D ltr_irrefl in H . + Qed . + + + Lemma sign_posR : forall x, 0 < sign x = 1 . + Proof . by move=> x hx; rewrite /sign hx. Qed. + + + Lemma sign_negR : forall x, x < sign x = -1 . + Proof . by move=> x hx; rewrite /sign hx (negbTE (ltrN hx)). Qed. + + Lemma sign0 : sign 0 = 0 :> G. + Proof . by rewrite /sign !ltr_irrefl . Qed . + + Lemma sign0P : forall x, reflect (sign x = 0) (x == 0) . + Proof . + move=> x; rewrite /sign; case: (compareP 0 x)=> H; last first. + + by rewrite -H eqxx; constructor. + + rewrite (negbTE (ltr_ne H)); constructor. + by apply/eqP; rewrite oppr_eq0 nonzero1r. + + rewrite eq_sym (negbTE (ltr_ne H)); constructor. + by apply/eqP; rewrite nonzero1r. + Qed. + + + Lemma sign_codomP : + forall x, [\/ sign x = 1, sign x = -1 | sign x = 0] . + Proof . + move=> x; case: (compareP 0 x) => H; [apply Or31 | apply Or32 | apply Or33] . + - by apply: sign_posR. + - by apply: sign_negR. + - by rewrite -H sign0 . + Qed . + + + (* ------------------------------------------------------------------ *) + Lemma absr_nneg : forall x, 0 <<= x -> absr x = x . + Proof . + move=> x Hx; rewrite /absr ltrNger . + + by case D: (0 <<= x) => //=; rewrite Hx in D . + Qed . + + Lemma absr_npos : forall x, x <<= 0 -> absr x = -x . + Proof . + move=> x Hx; rewrite /absr ltrNger; case Hx': (0 <<= x) => //= . + have Hx0: x = 0 by apply/eqP; rewrite eq_ler Hx Hx' . + by rewrite Hx0 oppr0 . + Qed . + + Lemma absr_neg : forall x, x < absr x = -x . + Proof . by move=> x Hx; apply absr_npos; apply ltrW . Qed . + + Lemma absr0 : absr 0 = 0 :> G . + Proof . by rewrite /absr ltr_irrefl . Qed . + + Lemma absrpos : forall x, 0 <<= absr x . + Proof . + move=> x; case: (ltrP x 0) => H . + + by rewrite absr_neg // le0r_geNr0; apply ltrW . + + by rewrite absr_nneg. + Qed . + + Lemma absrK : forall x, absr (absr x) = absr x . + Proof . by move=> x; rewrite absr_nneg // absrpos . Qed . + + Lemma absr_oppr : forall x, absr(-x) = absr x. + Proof. + move=> x. + case a : (0 < a'; rewrite (absr_npos a'). + by rewrite absr_nneg // -ler_oppger opprK oppr0. + Qed. + + Lemma absr_sign : forall x , (absr x) = (sign x) * x . + Proof . + move=> x; case: (compareP x 0) => h. + + by rewrite /absr h; move/sign_negR: h=> ->; rewrite mulN1r. + + by rewrite absr_nneg ?ltrW //; move/sign_posR: h=> ->; rewrite mul1r . + + by rewrite h sign0 absr0 mul0r. + Qed . + + + + Lemma absr_addr : + forall x y, absr (x + y) <<= (absr x) + (absr y). + move=> x y; rewrite !absr_sign. + case: (compareP x 0) => hx. + - rewrite (sign_negR hx) mulN1r; case: (compareP y 0) => hy. + + rewrite (sign_negR hy) mulN1r mulr_addr. + rewrite (_ : sign _ = -1) ?mulN1r ?ler_refl //; apply: sign_negR. + by apply: ltr0T. + + rewrite (sign_posR hy) mul1r ; case: (compareP (x + y) 0) => hxy. + * by rewrite (sign_negR hxy) mulr_addr !mulN1r lerTrb opp_ler_ler0 ltrW. + * by rewrite (sign_posR hxy) mul1r lerTlb ler_opp_ler0 ltrW. + * by rewrite hxy sign0 mul0r lerT0 // ?le0r_geNr0 ltrW. + + by rewrite hy mulr0 !addr0 (sign_negR hx) mulN1r ler_refl. + - rewrite (sign_posR hx) mul1r; case: (compareP y 0) => hy. + + rewrite (sign_negR hy) mulN1r mulr_addr; case: (compareP (x + y) 0) => hxy. + * by rewrite (sign_negR hxy) !mulN1r lerTlb opp_ler_ler0 ltrW. + * by rewrite (sign_posR hxy) !mul1r lerTrb ler_opp_ler0 ltrW. + * by rewrite hxy sign0 !mul0r addr0 lerT0 // ?le0r_geNr0 ltrW. + + rewrite (sign_posR hy) mul1r (_ : sign _ = 1) ?mul1r ?ler_refl //. + by apply: sign_posR; apply: ltrT0. + + by rewrite hy mulr0 !addr0 (sign_posR hx) mul1r ler_refl. + - by rewrite hx mulr0 !add0r ler_refl. + Qed. + + +Lemma absr_lt : forall x y, absr x < x < x y h. +have py : 0 < h2. +- by rewrite (ltr_trans h2). +- by rewrite -[x]absr_nneg // ltrW. +- by rewrite h2. +Qed. + +Lemma absr_le : forall x y, absr x <<= y -> x <<= y. +Proof. +move=> x y h. +have py : 0 <<= y by apply: (ler_trans (absrpos x)). +case: (compareP x 0) => h2. +- by rewrite ltrW // (ltr_ler_trans h2). +- by rewrite -[x]absr_nneg // ltrW. +- by rewrite h2. +Qed. + +Lemma lt_absr : forall x y, absr x < - y < x y h. +have py : 0 < h2. +- by rewrite -[x]opprK ltr_oppgtr -[- x]absr_npos // ltrW. +- by rewrite -[x]opprK -ltr_oppgtr !opprK; apply: ltr_trans py; rewrite -gtr0_ltNr0. +- by rewrite h2 -gtr0_ltNr0. +Qed. + +Lemma le_absr : forall x y, absr x <<= y -> - y <<= x. +Proof. +move=> x y h. +have py : 0 <<= y by apply: (ler_trans (absrpos x)). +case: (compareP x 0) => h2. +- by rewrite -[x]opprK ler_oppger -[- x]absr_npos // ltrW. +- by rewrite -[x]opprK -ler_oppger !opprK; apply: ler_trans py; rewrite -ger0_leNr0 ltrW. +- by rewrite h2 -ger0_leNr0. +Qed. + +(* ------------------------------------------------------------------ *) +Lemma ler_addl_abs : + forall x₁ x₂, x₁ <<= x₂ -> + forall y, (absr y) <<= (x₂ - x₁) -> + x₁ <<= x₂ + y . +Proof. +move=> x1 x2 hx12 y; move/le_absr. rewrite -(@lerTlb x2) addrC oppr_add opprK. +by rewrite addrA addrN add0r addrC. +Qed. + + + Lemma ler0_addl_abs : + forall x y, 0 <<= x -> (absr y) <<= x -> 0 <<= x + y . + Proof . + by move=> x y Hx Hy; apply ler_addl_abs; last rewrite oppr0 addr0 . + Qed . + End OComringTheory . + +(* + Module OField . + + Record class_of (R : Type) : Type := Class { + base1 :> GRing.Field.class_of R; + ext :> OComRing.mixin_of (GRing.Field.Pack base1 R) + } . + +(* Coercion base2 R m := OComRing.Class (@ext R m).*) + Coercion base2 R m := @OComRing.Class R _ (@ext R m). + + + Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}. + + Definition class cT := let: Pack _ c _ := cT return class_of cT in c. + Definition unpack K (k : forall T (c : class_of T), K T c) cT := + let: Pack T c _ := cT return K _ (class cT) in k _ c. + Definition repack cT : _ -> Type -> type := + let k T c p := p c in unpack k cT. + +(* Mixin here ? *) + Definition pack := + let k T c m := Pack (@Class T c m) T in GRing.Field.unpack k. + + Definition eqType cT := Equality.Pack (class cT) cT. + Definition choiceType cT := Choice.Pack (class cT) cT. + Definition zmodType cT := GRing.Zmodule.Pack (class cT) cT. + Definition ringType cT := GRing.Ring.Pack (class cT) cT. + Definition unitRingType cT := GRing.UnitRing.Pack (class cT) cT. + Definition comRingType cT := GRing.ComRing.Pack (class cT) cT. + Definition comUnitRingType cT := GRing.ComUnitRing.Pack (class cT) cT. + Definition idomainType cT := GRing.IntegralDomain.Pack (class cT) cT. + Coercion fieldType cT := GRing.Field.Pack (class cT) cT. + Coercion oComRingType cT := OComRing.Pack (class cT) cT. + Definition oFieldType cT := + @OComRing.Pack (fieldType cT) (class cT) cT. + + End OField . + + Canonical Structure OField.eqType. + Canonical Structure OField.choiceType. + Canonical Structure OField.zmodType. + Canonical Structure OField.ringType. + Canonical Structure OField.comRingType. + Canonical Structure OField.unitRingType. + Canonical Structure OField.comUnitRingType. + Canonical Structure OField.idomainType. + Canonical Structure OField.fieldType. + + Bind Scope comring_scope with OField.sort . +*) + Module OField . + + Record class_of (R : Type) : Type := Class { + base1 :> GRing.Field.class_of R; + ext :> OComRing.mixin_of (GRing.Field.Pack base1 R) + } . + + Coercion base2 R m := @OComRing.Class R _ (@ext R m). + + Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}. + + Definition class cT := let: Pack _ c _ := cT return class_of cT in c. + Definition unpack K (k : forall T (c : class_of T), K T c) cT := + let: Pack T c _ := cT return K _ (class cT) in k _ c. + Definition repack cT : _ -> Type -> type := + let k T c p := p c in unpack k cT. + +(* Mixin here ? *) + Definition pack := + let k T c m := Pack (@Class T c m) T in GRing.Field.unpack k. + + Definition eqType cT := Equality.Pack (class cT) cT. + Definition choiceType cT := Choice.Pack (class cT) cT. + Definition zmodType cT := GRing.Zmodule.Pack (class cT) cT. + Definition ringType cT := GRing.Ring.Pack (class cT) cT. + Definition unitRingType cT := GRing.UnitRing.Pack (class cT) cT. + Definition comRingType cT := GRing.ComRing.Pack (class cT) cT. + Definition comUnitRingType cT := GRing.ComUnitRing.Pack (class cT) cT. + Definition idomainType cT := GRing.IntegralDomain.Pack (class cT) cT. + Coercion fieldType cT := GRing.Field.Pack (class cT) cT. + Coercion oComRingType cT := OComRing.Pack (class cT) cT. + Definition oFieldType cT := + @OComRing.Pack (fieldType cT) (class cT) cT. + + End OField . + + Canonical Structure OField.eqType. + Canonical Structure OField.choiceType. + Canonical Structure OField.zmodType. + Canonical Structure OField.ringType. + Canonical Structure OField.comRingType. + Canonical Structure OField.unitRingType. + Canonical Structure OField.comUnitRingType. + Canonical Structure OField.idomainType. + Canonical Structure OField.fieldType. + Canonical Structure OField.oComRingType. + +Bind Scope ring_scope with OField.sort. + +Section OrderedFieldTheory. + + Variable G : OField.type . + Implicit Types x y : G. + + Lemma ltr_0_lcompat : forall x y, 0 < 0 < 0 < x y Hx Hy; rewrite ltr_lerne; apply/andP; split . + + by apply ler_0_lcompat; apply ltrW . + + rewrite eq_sym mulf_eq0 negb_or . + by rewrite ![_ == 0]eq_sym (ltr_ne Hx) (ltr_ne Hy) . + Qed . + + Lemma oppreq_0 : forall x, (x == -x) = (x == 0) . + Proof . + move=> x; apply/eqP/eqP => [|->]; last by rewrite oppr0 . + move/(congr1 (+%R x)); rewrite addrN -{1 2}[x](mul1r) -mulr_addl . + move/eqP; rewrite mulf_eq0; case/orP; last by move/eqP => -> . + by rewrite (negbTE (χ0 G 1%nat)). + Qed. + + Lemma sign_pos : forall x, reflect (sign x = 1) (0 < x; rewrite /sign; case: (compareP 0 x) => h; constructor => //. + + by apply/eqP; rewrite eq_sym oppreq_0 nonzero1r. + + by apply/eqP; rewrite eq_sym nonzero1r. + Qed . + + Lemma sign_neg : forall x, reflect (sign x = -1) (x < x; rewrite /sign; case: (compareP 0 x) => _; constructor=> // . + + apply/eqP; rewrite oppreq_0; exact: nonzero1r . + + move/(congr1 -%R); rewrite opprK oppr0; move/eqP . + by rewrite eq_sym (negbTE (nonzero1r _)) . + Qed . + + Lemma mulr_sign : forall x y, sign (x * y) = (sign x) * (sign y) . + Proof . + move=> x y; case: (compareP 0 x) . + + case: (compareP 0 y) => Hy Hx . + * by rewrite !sign_posR ?mul1r //; apply ltr_0_lcompat . + * rewrite [sign x]sign_posR // !sign_negR ?mul1r // . + rewrite -lt0r_gtNr0 -mulrN; apply ltr_0_lcompat => // . + by rewrite lt0r_gtNr0 . + * by rewrite -Hy mulr0 sign0 mulr0 . + + case: (compareP 0 y) => Hy Hx . + * rewrite [sign y]sign_posR // !sign_negR ?mulr1 // . + rewrite -lt0r_gtNr0 -mulNr; apply ltr_0_lcompat => // . + by rewrite lt0r_gtNr0 . + * rewrite [sign x]sign_negR // [sign y]sign_negR // . + rewrite sign_posR; first by rewrite ?mulrNN ?mulr1 . + by rewrite -mulrNN; apply ltr_0_lcompat; rewrite lt0r_gtNr0 . + * by rewrite -Hy mulr0 sign0 mulr0 . + + by move=> <-; rewrite mul0r sign0 mul0r . + Qed . + + (* ------------------------------------------------------------------ *) + + + Lemma invr_ltr : forall x, (0 < sign (x^-1 * x) = 1 . + + by move=> x Hx; rewrite mulVf // sign_posR // ltr_0_1 . + + have HP: forall x, 0 < 0 < x Hx; apply/sign_pos; rewrite -(Hsign x) . + * rewrite mulr_sign -{1}[sign x^-1]mulr1 . + by congr (_ * _); symmetry; apply/sign_pos . + * by rewrite eq_sym; apply (ltr_ne Hx) . + + move=> x; apply/idP/idP; last exact: HP . + by move=> Hx; rewrite -(invrK x); apply HP . + Qed . + + Lemma ler_Ilcompat_r : + forall x y₁ y₂, 0 < x * y₁ <<= x * y₂ -> y₁ <<= y₂ . + Proof . + move=> x y₁ y₂ Hx Hy . + rewrite -[y₁](mul1r) -[y₂](mul1r) -[1](@mulVf _ x) 1?eq_sym ?(ltr_ne Hx) //. + by rewrite -!mulrA; apply ler_lcompat => //; apply ltrW; rewrite invr_ltr . + Qed . + + Lemma ler_Ilcompat_l : + forall x y₁ y₂, 0 < y₁ * x <<= y₂ * x -> y₁ <<= y₂ . + Proof . + move=> x y₁ y₂; rewrite mulrC [y₂ * _]mulrC; exact: ler_Ilcompat_r. + Qed . + + Lemma ltr_Ilcompat_r : + forall x y₁ y₂, 0 < x * y₁ < y₁ < x y₁ y₂ Hx Hy . + rewrite -[y₁](mul1r) -[y₂](mul1r) -[1](@mulVf _ x) 1?eq_sym ?(ltr_ne Hx) //. + by rewrite -!mulrA; apply ltr_lcompat => //; rewrite invr_ltr . + Qed . + + Lemma ltr_Ilcompat_l : + forall x y₁ y₂, 0 < y₁ * x < y₁ < x y₁ y₂; rewrite mulrC [y₂ * _]mulrC; exact: ltr_Ilcompat_r. + Qed . + + + Lemma invr1_ltr0_ltr1 : forall x, 0 < (x < x hx; move:(hx); rewrite ltr_lerne eq_sym; case/andP=> hx1 hx2. + rewrite -{1}(divff hx2) -{1}(mulr1 x); case e: (1 < (1 < x hx; apply/idP/idP => h1. + apply: (ltr_Ilcompat_r hx); rewrite divff // ?mulr1 //. + by move: hx; rewrite ltr_lerne eq_sym; case/andP. + move:(hx); rewrite -invr_ltr=> hIx; apply: (ltr_Ilcompat_r hIx). + by rewrite mulr1 mulVf //; move: hx; rewrite ltr_lerne eq_sym; case/andP. + Qed. + + Lemma invr1_0ltr_ltr1I : forall x, x < (x < x; rewrite -(opprK x). + rewrite invrN !ltr_oppgtr -lt0r_gtNr0 opprK; exact: invr1_ltr0_1ltr. + Qed. + + Lemma invr1_0ltr_ltrI1 : forall x, x < (-1 < x; rewrite -(opprK x). + rewrite invrN !ltr_oppgtr -lt0r_gtNr0 opprK; exact: invr1_ltr0_ltr1. + Qed. + + (* We cannot define a theory of floor since some ordered comring do not have...*) + + (* ------------------------------------------------------------------ *) + Lemma Ndiscrete01 : exists x : G, (0 < // . + rewrite -(ltrTlb (-1)) addrN . + rewrite -{4}[1](@mulfV _ (1+1)); last exact: (χ0 _ 1) . + rewrite -mulNr -mulr_addl -mulN1r mulr_addr mulN1r . + by rewrite addrA addrN add0r mulNr -ltr_oppgtr oppr0 opprK . + Qed . + + Lemma Ndiscrete : forall x z, x < exists y, (x < x z Hxz; elim Ndiscrete01=> y; case/andP => Hylow Hyhi . + exists (y * (z-x) + x); apply/andP; split . + + rewrite -{1}[x]add0r ltrTlb; apply ltr_0_lcompat => // . + by rewrite -[0](addrN x) ltrTlb . + + rewrite -(ltrTlb (-x)) -addrA addrN addr0 . + rewrite mulrC -{2}[z-x]mulr1; apply ltr_lcompat => // . + by rewrite -[0](addrN x) ltrTlb . + Qed . + + + Lemma absr_mulr : + forall x y, absr (x * y) = (absr x) * (absr y) . + Proof . + move=> x y; rewrite !absr_sign mulr_sign . + by rewrite -[_ * x * _]mulrA -[x * (_ * _)]mulrCA !mulrA . + Qed . + + + +End OrderedFieldTheory. + +End GOrdered . + +Bind Scope comring_scope with GOrdered.OComRing.sort . + +Canonical Structure GOrdered.OComRing.eqType. +Canonical Structure GOrdered.OComRing.choiceType. +Canonical Structure GOrdered.OComRing.zmodType. +Canonical Structure GOrdered.OComRing.ringType. +Canonical Structure GOrdered.OComRing.comringType. + +Notation ocomringType := (GOrdered.OComRing.type) . +Notation OcomringType := (GOrdered.OComRing.pack) . +Notation OcomringMixin := (GOrdered.OComRing.Mixin) . + +Canonical Structure GOrdered.OField.eqType. +Canonical Structure GOrdered.OField.choiceType. +Canonical Structure GOrdered.OField.zmodType. +Canonical Structure GOrdered.OField.ringType. +Canonical Structure GOrdered.OField.comRingType. +Canonical Structure GOrdered.OField.unitRingType. +Canonical Structure GOrdered.OField.comUnitRingType. +Canonical Structure GOrdered.OField.idomainType. +Canonical Structure GOrdered.OField.fieldType. +Canonical Structure GOrdered.OField.oComRingType. + +Notation ofieldType := (GOrdered.OField.type) . +Notation OfieldType := (GOrdered.OField.pack) . + + +Notation "x <<= y" := (GOrdered.leb x y) . +Notation "x < R . + + Definition minB (x0 : R) (r : seq I) := + if (filter P r) is x::xs + then \big[minr/(F x)]_(i <- xs) (F i) + else x0 . + End MinB . + End Defs . +End Min . + +Notation minr := (@Min.minr _) . +Notation minB := (@Min.minB _ _) . + +Section MinTheory . + Variable R : ocomringType . + + Import GOrdered . + + Lemma minrC : commutative (@Min.minr R) . + Proof . by move=> x y; rewrite /minr; case: (compareP x y) . Qed . + + Lemma minrA : associative (@Min.minr R) . + move=> x y z; rewrite /minr . + (case: (compareP y z); last (move=> <-)); + (case: (compareP x y); last (move=> <-)); + try solve + [ by do! (move=> H; rewrite ?H ?(negbTE (ltrNgtr H)) => {H}) + | by rewrite ltr_irrefl ] . + + by move=> Hxy Hyz; rewrite (ltr_trans Hxy Hyz) . + + move=> Hyx Hzy; rewrite (negbTE (ltrNgtr Hzy)) . + by rewrite (negbTE (ltrNgtr (ltr_trans Hzy Hyx))) . + Qed . + + Lemma minrCA : left_commutative (@Min.minr R) . + Proof . + by move=> x y z; rewrite minrA [minr x y]minrC -minrA . + Qed . + + Lemma minrAC : right_commutative (@Min.minr R) . + Proof . + by move=> x y z; rewrite -minrA [minr y z]minrC minrA . + Qed . + + Lemma minrl : forall (x y : R), minr x y <<= x . + Proof . + by move=> x y; rewrite /minr; case: (ltrP x y); rewrite // ler_refl . + Qed . + + Lemma minrr : forall (x y : R), minr x y <<= y . + Proof . + by move=> x y; rewrite minrC; apply minrl . + Qed . + + Section minB . + Variable I : eqType . + Variable P : pred I . + Variable F : I -> R . + Variable x0 : R . + + Lemma minB_nil : minB P F x0 [::] = x0 . + Proof . by [] . Qed . + + Lemma minB_seq1 : forall x, P x -> minB P F x0 [:: x] = (F x) . + Proof . by move=> x H; rewrite /minB /filter H big_nil . Qed . + + Lemma minB_cons : + forall x xs, P x -> has P xs + -> minB P F x0 (x::xs) = minr (F x) (minB P F x0 xs) . + Proof . + move=> x xs HPx HPxs; rewrite {1}/minB /= HPx . + rewrite has_filter in HPxs; move/eqP: HPxs => HPxs . + rewrite /minB; case D: (filter P xs) => [|z₁ zs] {D HPx} // . + elim: zs x z₁ => [|z₂ zs IH] x z₁ . + + by rewrite unlock /= minrC . + + by rewrite big_cons !IH minrCA . + Qed . + + Lemma minB_head : + forall x xs, ~~ (has P xs) -> + minB P F x0 (x::xs) = (if P x then F x else x0) . + Proof . + move=> x xs HPxs; rewrite /minB /= . + rewrite has_filter negbK in HPxs; rewrite (eqP HPxs) . + by case (P x); rewrite ?big_nil . + Qed . + + Lemma minB_tail : + forall x xs, ~~ (P x) -> minB P F x0 (x::xs) = minB P F x0 xs . + Proof . + by move=> x xs HPx; rewrite {1}/minB /= (negbTE HPx) . + Qed . + + Lemma minB_empty : + forall xs, ~~ (has P xs) -> minB P F x0 xs = x0 . + Proof . + elim=> [|x xs IH] //= . + rewrite negb_orb; case/andP=> HPx HPxs . + by rewrite minB_tail // IH . + Qed . + + Lemma minBE : + forall (r : seq I), + forall z, z \in r -> P z -> minB P F x0 r <<= F z . + Proof . + elim=> [|x xs IH] // z Hmem Hpz . + rewrite in_cons in Hmem; case/orP: Hmem => [|Hz] . + + move/eqP => <-; case D: (has P xs) . + * by rewrite minB_cons // minrl . + * by rewrite minB_head /negb ?D // Hpz ler_refl . + + have Htail: has P xs by (apply/hasP; exists z) . + case D: (P x) . + * rewrite minB_cons //; apply: ler_trans . + by apply minrr . by apply IH . + * by rewrite minB_tail /negb ?D //; apply IH . + Qed . + + Lemma minBP : + forall d (r : seq I), has P r -> + exists i, + let x := nth d r i in + [/\ (i < size r), P x & (minB P F x0 r = F x)] . + Proof . + move=> d; elim=> [|x xs IH] //= H . + case Dhead: (P x); case Dtail: (has P xs) . + + rewrite minB_cons // /minr; case: ltrP => _ . + * by exists 0%N => // . + * by elim (IH Dtail)=> i [Hsize HPi Hmini]; exists i.+1 . + + exists 0%N; split=> // . + by rewrite minB_head ?Dhead //=; apply negbT . + + elim (IH Dtail)=> i [Hsize HPi Hmini]; exists i.+1 . + by split=> //=; rewrite minB_tail //; apply negbT . + + by rewrite Dhead Dtail in H . + Qed . + + Lemma minBI : + forall (r : seq I), has P r -> (minB P F x0 r) \in (map F r) . + Proof . + move=> r; move/hasP=> [d Hdr HPd]; elim (@minBP d r) . + + move=> n [Hsize HP Heq]; apply/nthP; exists n . + * by rewrite size_map . + * by rewrite Heq -(nth_map d x0) //; reflexivity . + + by apply/hasP; exists d . + Qed . + + Lemma min_fall_lt : + forall (r : seq I) x, has P r + -> (forall z, z \in r -> P z -> x < x < [|x xs IH] // z Hpz H . + case Dhead: (P x); case Dtail: (has P xs) . + + rewrite minB_cons // /minr; case: (ltrP (F x)) => D . + * by apply H => //; rewrite in_cons eqxx . + * by apply IH => // w Hw HPw; apply H => //; rewrite in_cons Hw orbT . + + rewrite minB_head /negb ?Dtail // Dhead . + by apply H => //; rewrite in_cons eqxx . + + rewrite minB_tail /negb ?Dhead //; apply IH => // . + by move=> w Hw HPw; apply H => //; rewrite in_cons Hw orbT . + + by rewrite /= Dhead Dtail in Hpz . + Qed . + + Lemma min_fall_le : + forall (r : seq I) x, has P r + -> (forall z, z \in r -> P z -> x <<= F z) + -> x <<= minB P F x0 r . + Proof . + elim=> [|x xs IH] // z Hpz H . + case Dhead: (P x); case Dtail: (has P xs) . + + rewrite minB_cons // /minr; case: (ltrP (F x)) => D . + * by apply H => //; rewrite in_cons eqxx . + * by apply IH => // w Hw HPw; apply H => //; rewrite in_cons Hw orbT . + + rewrite minB_head /negb ?Dtail // Dhead . + by apply H => //; rewrite in_cons eqxx . + + rewrite minB_tail /negb ?Dhead //; apply IH => // . + by move=> w Hw HPw; apply H => //; rewrite in_cons Hw orbT . + + by rewrite /= Dhead Dtail in Hpz . + Qed . + End minB . +End MinTheory . + +Notation "\minB_ ( i | P ) F" := + (minB (fun i => P%B) (fun i => F) 0 (index_enum _)) + (at level 36, F at level 36, i at level 50) . + +Notation "\minB_ ( i \in I | P ) F" + := (\minB_(i | (i \in I) && P) F) + (at level 36, F at level 36, i, A at level 50) .