diff --git a/.github/workflows/docker-action.yml b/.github/workflows/docker-action.yml
index 69e39c5..052158a 100644
--- a/.github/workflows/docker-action.yml
+++ b/.github/workflows/docker-action.yml
@@ -6,13 +6,9 @@ on:
   push:
     branches:
       - master
-    paths-ignore:
-      - 'documents/**'
   pull_request:
     branches:
       - '**'
-    paths-ignore:
-      - 'documents/**'
 
 jobs:
   build:
@@ -21,8 +17,7 @@ jobs:
     strategy:
       matrix:
         image:
-          - 'mathcomp/mathcomp:1.16.0-coq-8.15'
-          - 'mathcomp/mathcomp:1.16.0-coq-8.16'
+          - 'mathcomp/mathcomp:2.2.0-coq-8.19'
       fail-fast: false
     steps:
       - uses: actions/checkout@v3
diff --git a/.gitignore b/.gitignore
index c4e0fb6..1935569 100644
--- a/.gitignore
+++ b/.gitignore
@@ -8,7 +8,7 @@
 Makefile.coq
 Makefile.coq.conf
 .Makefile.coq.d
-html/*.cmo
-html/*.cmi
-html/*.bytes
-html/*.js
\ No newline at end of file
+www/*.cmo
+www/*.cmi
+www/*.bytes
+www/*.js
diff --git a/README.md b/README.md
index 2e27acb..06103b0 100644
--- a/README.md
+++ b/README.md
@@ -6,8 +6,8 @@ Follow the instructions on https://github.com/coq-community/templates to regener
 
 [![Docker CI][docker-action-shield]][docker-action-link]
 
-[docker-action-shield]: https://github.com/math-comp/trajectories/workflows/Docker%20CI/badge.svg?branch=master
-[docker-action-link]: https://github.com/math-comp/trajectories/actions?query=workflow:"Docker%20CI"
+[docker-action-shield]: https://github.com/math-comp/trajectories/actions/workflows/docker-action.yml/badge.svg?branch=master
+[docker-action-link]: https://github.com/math-comp/trajectories/actions/workflows/docker-action.yml
 
 
 
@@ -20,20 +20,20 @@ TODO
   - Reynald Affeldt (initial)
   - Yves Bertot (initial)
 - License: [CeCILL-C](LICENSE)
-- Compatible Coq versions: Coq >= 8.15, MathComp >= 1.16
+- Compatible Coq versions: Coq >= 8.17, MathComp >= 2.2.0
 - Additional dependencies:
-  - [MathComp ssreflect 1.15 or later](https://math-comp.github.io)
-  - [MathComp fingroup 1.15 or later](https://math-comp.github.io)
-  - [MathComp algebra 1.15 or later](https://math-comp.github.io)
-  - [MathComp solvable 1.15 or later](https://math-comp.github.io)
-  - [MathComp field 1.16 or later](https://math-comp.github.io)
-  - [Mathcomp real closed 1.1.3 or later](https://github.com/math-comp/real-closed/)
-  - [Algebra tactics 1.0.0](https://github.com/math-comp/algebra-tactics)
-  - [MathComp analysis](https://github.com/math-comp/analysis)
-  - [Infotheo](https://github.com/affeldt-aist/infotheo)
+  - [MathComp ssreflect 2.2.0 or later](https://math-comp.github.io)
+  - [MathComp fingroup 2.2.0 or later](https://math-comp.github.io)
+  - [MathComp algebra 2.2.0 or later](https://math-comp.github.io)
+  - [MathComp solvable 2.2.0 or later](https://math-comp.github.io)
+  - [MathComp field 2.2.0 or later](https://math-comp.github.io)
+  - [Mathcomp real closed 2.0.0 or later](https://github.com/math-comp/real-closed/)
+  - [Algebra tactics 1.2.0 or later](https://github.com/math-comp/algebra-tactics)
+  - [MathComp analysis 1.0.0 or later](https://github.com/math-comp/analysis)
+  - [Infotheo 0.7.0 of later](https://github.com/affeldt-aist/infotheo)
 - Coq namespace: `mathcomp.trajectories`
 - Related publication(s):
-  - [TODO](TODO) doi:[TODO](https://doi.org/TODO)
+  - [Safe Smooth Paths between Straight Line Obstacles](https://inria.hal.science/hal-04312815) doi:[https://doi.org/10.1007/978-3-031-61716-4_3](https://doi.org/https://doi.org/10.1007/978-3-031-61716-4_3)
 
 ## Building and installation instructions
 
@@ -70,6 +70,9 @@ references:
   https://hal.inria.fr/inria-00503017v2/document
 - Theorem of three circles in Coq (2013)
   https://arxiv.org/abs/1306.0783
+- Safe Smooth Paths between straight line obstacles
+  https://inria.hal.science/hal-04312815
+  https://link.springer.com/chapter/10.1007/978-3-031-61716-4_3
 
 ## Development information
 
diff --git a/_CoqProject b/_CoqProject
index 8dcf076..517d550 100644
--- a/_CoqProject
+++ b/_CoqProject
@@ -1,3 +1,4 @@
+theories/shortest_path.v
 theories/generic_trajectories.v
 theories/smooth_trajectories.v
 theories/convex.v
@@ -22,6 +23,16 @@ 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/opening_cells.v
+theories/points_and_edges.v
+theories/safe_cells.v
 
 -R theories trajectories
 
diff --git a/coq-mathcomp-trajectories.opam b/coq-mathcomp-trajectories.opam
index 6badeca..db76215 100644
--- a/coq-mathcomp-trajectories.opam
+++ b/coq-mathcomp-trajectories.opam
@@ -17,16 +17,16 @@ TODO"""
 build: [make "-j%{jobs}%"]
 install: [make "install"]
 depends: [
-  "coq" { (>= "8.14" & < "8.17~") | (= "dev") }
-  "coq-mathcomp-ssreflect" { (>= "1.16.0" & < "1.17~") | (= "dev") }
-  "coq-mathcomp-fingroup" { (>= "1.16.0" & < "1.17~") | (= "dev") }
-  "coq-mathcomp-algebra" { (>= "1.16.0" & < "1.17~") | (= "dev") }
-  "coq-mathcomp-solvable" { (>= "1.16.0" & < "1.17~") | (= "dev") }
-  "coq-mathcomp-field" { (>= "1.16.0" & < "1.17~") | (= "dev") }
-  "coq-mathcomp-real-closed" { (>= "1.1.3") | (= "dev") }
-  "coq-mathcomp-algebra-tactics" { (>= "1.0.0") | (= "dev") }
-  "coq-mathcomp-analysis" { (>= "0.6.1") & (< "0.7~")}
-  "coq-infotheo" { >= "0.5.1" & < "0.6~"}
+  "coq" { (>= "8.17" & < "8.20~") | (= "dev") }
+  "coq-mathcomp-ssreflect" { (>= "2.2.0") | (= "dev") }
+  "coq-mathcomp-fingroup" { (>= "2.2.0") | (= "dev") }
+  "coq-mathcomp-algebra" { (>= "2.2.0") | (= "dev") }
+  "coq-mathcomp-solvable" { (>= "2.2.0") | (= "dev") }
+  "coq-mathcomp-field" { (>= "2.2.0") | (= "dev") }
+  "coq-mathcomp-real-closed" { (>= "2.0.0") | (= "dev") }
+  "coq-mathcomp-algebra-tactics" { (>= "1.2.0") | (= "dev") }
+  "coq-mathcomp-analysis" { (>= "1.0.0") }
+  "coq-infotheo" { >= "0.7.0"}
 ]
 
 tags: [
diff --git a/documents/FHG_slides.tex b/documents/FHG_slides.tex
new file mode 100644
index 0000000..d9394f2
--- /dev/null
+++ b/documents/FHG_slides.tex
@@ -0,0 +1,192 @@
+\documentclass[compress]{beamer}
+\usepackage[latin1]{inputenc}
+\usepackage{alltt}
+\newdimen\topcrop
+\topcrop=10cm  %alternatively 8cm if the pdf inclusions are in letter format
+\newdimen\topcropBezier
+\topcropBezier=19cm %alternatively 16cm if the inclusions are in letter format
+
+\setbeamertemplate{footline}[frame number]
+\title{Smooth trajectories in straight line mazes}
+\author{Yves Bertot\\
+Joint work with Thomas Portet, Quentin Vermande}
+\date{April 2023}
+\mode<presentation>
+\begin{document}
+
+\maketitle
+\begin{frame}
+\frametitle{The game}
+\begin{itemize}
+\item Apply Type Theory-based verification to a problem understood by a
+  wide audience
+\item Find a smooth path in a maze
+\item Decompose the problem
+\begin{itemize}
+\item Find a discrete approximation of the problem
+\item Construct a piece-wise linear path
+\item smoothen the angles
+\end{itemize}
+\item Prove the correctness of the algorithm
+\begin{itemize}
+\item Safety: absence of collision
+\item work in progress
+\end{itemize}
+\end{itemize}
+\end{frame}
+\begin{frame}
+\frametitle{Example}
+\includegraphics[trim={0 0 0 \topcrop}, clip, width=\textwidth]{empty_spiral.pdf}
+\end{frame}
+\begin{frame}
+\frametitle{Cell decomposition}
+\begin{itemize}
+\item Decompose the space into simple cells
+\item Each cell is convex
+\item Each cell is free of obstacles
+\item Each cell may have safely reachable neighbors
+\end{itemize}
+\end{frame}
+\begin{frame}
+\frametitle{Vertical cell decomposition example}
+\includegraphics[trim={0 0 0 \topcrop}, clip, width=\textwidth]{cells_spiral.pdf}
+\end{frame}
+\begin{frame}
+\frametitle{Cell properties}
+\begin{itemize}
+\item Vertical edges are safe passages between two cells
+\item Moving directly from a left-edge to a right-edge is safe
+\begin{itemize}
+\item and vice-versa
+\end{itemize}
+\item Moving from a left-edge to the cell center is safe
+\begin{itemize}
+\item similarly for a right-edge
+\item moving from left-edge to left-edge is safe by going through the
+  cell center
+\end{itemize}
+\end{itemize}
+\end{frame}
+\begin{frame}
+\frametitle{Finding a path in the cell graph}
+\begin{itemize}
+\item A discrete path from cell to cell is found by breadth-first search
+\item Connected components of the graph are defined by polygons
+\item Special care for points that are already on the common edge of two cells
+\item Recent improvement: take distances into account
+\begin{itemize}
+\item Use a graph of doors instead of cells
+\item Easier to associate a distance between pairs of doors
+\item Dijkstra shortest path algorithm
+\end{itemize}
+\item In the end, a path from door to door
+\end{itemize}
+\end{frame}
+\begin{frame}
+\frametitle{Two examples of elementary safe paths}
+\includegraphics[trim={0 0 0 \topcrop}, clip, width=\textwidth]{spiral_safe2.pdf}
+\end{frame}
+\begin{frame}
+\frametitle{piecewise linear path}
+\label{broken-line}
+\includegraphics[trim={0 0 0 \topcrop}, clip, width=\textwidth]{spiral_bline.pdf}
+\end{frame}
+\begin{frame}
+\frametitle{Making corners smooth}
+\begin{itemize}
+\item Using quadratic Bezier curves
+\item Bezier curves are given by a set of control points
+   (3 for a quadratic curve)
+\item Points on the curves are obtained by computing weighted barycenters
+\begin{itemize}
+\item The curve is enclosed in the convex hull of the control points
+\end{itemize}
+\item Given control points \(a_0, a_1, \ldots, a_{n-1}, a_n\), \(a_0, a_1\)
+is tangent to the curve in \(a_0\)
+\begin{itemize}
+\item same for \(a_{n-1}, a_n\) in \(a_n\)
+\end{itemize}
+\end{itemize}
+\end{frame}
+\begin{frame}
+\frametitle{Bezier curve illustration}
+\begin{itemize}
+\item How the point for ratio \(4/9\) is computed
+\item Control points for the two subcurves are given by the new point,
+the initial starting and end points, and the solid green straight edge tip
+\end{itemize}
+\includegraphics[trim={0 6cm 0 \topcropBezier}, clip, width=\textwidth]{bezier_example2.pdf}
+\end{frame}
+\begin{frame}
+\frametitle{Using Bezier curves for smoothing}
+\begin{itemize}
+\item Add extra points in the middle of each straight line segment
+\item Uses these extra points as first and last control points for Bezier curves
+\item Use the angle point as the middle control point
+\item Check the Bezier curve for collision and repair if need be
+\end{itemize}
+\end{frame}
+\begin{frame}
+\frametitle{Collision checking, graphically}
+\includegraphics[trim={0 4cm 0 17cm}, clip, width=\textwidth]{collision.pdf}
+\end{frame}
+\begin{frame}
+\frametitle{Not passing in the top door}
+\includegraphics[trim={0 4cm 0 17cm}, clip, width=\textwidth]{collision2.pdf}
+\end{frame}
+\begin{frame}
+\frametitle{Final trajectories}
+\label{final-spiral}
+\includegraphics[trim={0 0 0 \topcrop}, clip, width=\textwidth]{smooth_spiral2.pdf}
+\end{frame}
+\begin{frame}
+\frametitle{Proof tools}
+\begin{itemize}
+\item Convex hulls (Pichardie \& B. 2001)
+\begin{itemize}
+\item Orientation predicate
+\item point below or above edge
+\end{itemize}
+\item Linear arithmetic
+\begin{itemize}
+\item Algorithms only use rational numbers
+\item Bezier curve intersections rely on algebraic numbers
+\end{itemize}
+\item Convex spaces and Bezier Curve
+\begin{itemize}
+\item Internship by Q. Vermande
+\item Using {\tt infotheo}, especially convex and conical spaces
+         (Affeldt \& Garrigue \& Saikawa 2020)
+\end{itemize}
+\end{itemize}
+\end{frame}
+\begin{frame}
+\frametitle{Vertical cell decomposition proofs}
+\begin{itemize}
+\item Use of semi-closed vertical cells
+\item Show disjoint property
+\item Show that obstacles are covered by cell tops
+\end{itemize}
+\end{frame}
+\begin{frame}
+\frametitle{Future work}
+\begin{itemize}
+\item Intend to prove only safety
+\item Produce concrete code from abstract models
+\begin{itemize}
+\item Move from exact computation to approximations
+\item Efficient implementation of graphs
+\end{itemize}
+\item Already usable in \textcolor{blue}{\href{https://stamp.gitlabpages.inria.fr/trajectories.html}{web-base demonstration}.}
+\begin{itemize}
+\item Extracted code to Ocaml, then compile to JavaScript
+\end{itemize}
+\end{itemize}
+\end{frame}
+\end{document}
+
+
+%%% Local Variables: 
+%%% mode: latex
+%%% TeX-master: t
+%%% End: 
diff --git a/documents/Makefile b/documents/Makefile
index 3038b9a..60dd236 100644
--- a/documents/Makefile
+++ b/documents/Makefile
@@ -1,4 +1,4 @@
-all : intro_slides.pdf FHG_paper.pdf
+all : intro_slides.pdf FHG_paper.pdf FHG_slides.pdf
 
 PSFILES=bezier_example.ps bezier_example2.ps cells_spiral.ps \
   collision.ps collision2.ps empty_spiral.ps polygon.ps repair2.ps \
@@ -16,5 +16,8 @@ FHG_paper.pdf : FHG_paper.tex FHG_paper.bib $(PDFFILES) illustration.png
 	pdflatex FHG_paper.tex; bibtex FHG_paper; pdflatex FHG_paper.tex \
         FHG_paper.tex
 
+FHG_slides.pdf : FHG_slides.tex $(PDFFILES)
+	PDFLATEX FHG_slides.tex; pdflatex FHG_slides.tex
+
 $(PDFFILES): %.pdf: %.ps
 	ps2pdf -sPAPERSIZE=a4 $<
diff --git a/documents/collision.ps b/documents/collision.ps
index 03beb13..ff64f80 100644
Binary files a/documents/collision.ps and b/documents/collision.ps differ
diff --git a/documents/collision2.ps b/documents/collision2.ps
index ddf615f..9ddbf9f 100644
Binary files a/documents/collision2.ps and b/documents/collision2.ps differ
diff --git a/html/Add.html b/html/Add.html
deleted file mode 100755
index aefc4fa..0000000
--- a/html/Add.html
+++ /dev/null
@@ -1,30 +0,0 @@
-
-
-<HTML>
-
-    <HEAD>
-
-        <TITLE>Add</TITLE>
-
-    </HEAD><BODY>
-
-        <H1> Add </H1>
-       
-        <p>
-	        <script src="Add.js"></script>
-	        <script src="AddScript.js"></script>
-  </div>
-  <div>
-    <textarea id="text" name="text"
-          rows="1" cols="33">
-1 2 1 2 
-</textarea>
-<p>
-  <button onclick="myadd()" class="Clear"> Test </button>
- </div>
-</div>
-        </p>
-
-    </BODY>
-
-</HTML>
diff --git a/html/Add.ml b/html/Add.ml
deleted file mode 100644
index c94be3b..0000000
--- a/html/Add.ml
+++ /dev/null
@@ -1,403 +0,0 @@
-
-type nat =
-| O
-| S of nat
-
-type ('a, 'b) prod =
-| Pair of 'a * 'b
-
-(** val snd : ('a1, 'a2) prod -> 'a2 **)
-
-let snd = function
-| Pair (_, y) -> y
-
-type 'a list =
-| Nil
-| Cons of 'a * 'a list
-
-type comparison =
-| Eq
-| Lt
-| Gt
-
-module Coq__1 = struct
- (** val add : nat -> nat -> nat **)
- let rec add n m =
-   match n with
-   | O -> m
-   | S p -> S (add p m)
-end
-include Coq__1
-
-type positive =
-| XI of positive
-| XO of positive
-| XH
-
-type z =
-| Z0
-| Zpos of positive
-| Zneg of positive
-
-module Pos =
- struct
-  type mask =
-  | IsNul
-  | IsPos of positive
-  | IsNeg
- end
-
-module Coq_Pos =
- struct
-  (** val succ : positive -> positive **)
-
-  let rec succ = function
-  | XI p -> XO (succ p)
-  | XO p -> XI p
-  | XH -> XO XH
-
-  (** val add : positive -> positive -> positive **)
-
-  let rec add x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> XO (add_carry p q0)
-       | XO q0 -> XI (add p q0)
-       | XH -> XO (succ p))
-    | XO p ->
-      (match y with
-       | XI q0 -> XI (add p q0)
-       | XO q0 -> XO (add p q0)
-       | XH -> XI p)
-    | XH -> (match y with
-             | XI q0 -> XO (succ q0)
-             | XO q0 -> XI q0
-             | XH -> XO XH)
-
-  (** val add_carry : positive -> positive -> positive **)
-
-  and add_carry x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> XI (add_carry p q0)
-       | XO q0 -> XO (add_carry p q0)
-       | XH -> XI (succ p))
-    | XO p ->
-      (match y with
-       | XI q0 -> XO (add_carry p q0)
-       | XO q0 -> XI (add p q0)
-       | XH -> XO (succ p))
-    | XH ->
-      (match y with
-       | XI q0 -> XI (succ q0)
-       | XO q0 -> XO (succ q0)
-       | XH -> XI XH)
-
-  (** val pred_double : positive -> positive **)
-
-  let rec pred_double = function
-  | XI p -> XI (XO p)
-  | XO p -> XI (pred_double p)
-  | XH -> XH
-
-  type mask = Pos.mask =
-  | IsNul
-  | IsPos of positive
-  | IsNeg
-
-  (** val succ_double_mask : mask -> mask **)
-
-  let succ_double_mask = function
-  | IsNul -> IsPos XH
-  | IsPos p -> IsPos (XI p)
-  | IsNeg -> IsNeg
-
-  (** val double_mask : mask -> mask **)
-
-  let double_mask = function
-  | IsPos p -> IsPos (XO p)
-  | x0 -> x0
-
-  (** val double_pred_mask : positive -> mask **)
-
-  let double_pred_mask = function
-  | XI p -> IsPos (XO (XO p))
-  | XO p -> IsPos (XO (pred_double p))
-  | XH -> IsNul
-
-  (** val sub_mask : positive -> positive -> mask **)
-
-  let rec sub_mask x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> double_mask (sub_mask p q0)
-       | XO q0 -> succ_double_mask (sub_mask p q0)
-       | XH -> IsPos (XO p))
-    | XO p ->
-      (match y with
-       | XI q0 -> succ_double_mask (sub_mask_carry p q0)
-       | XO q0 -> double_mask (sub_mask p q0)
-       | XH -> IsPos (pred_double p))
-    | XH -> (match y with
-             | XH -> IsNul
-             | _ -> IsNeg)
-
-  (** val sub_mask_carry : positive -> positive -> mask **)
-
-  and sub_mask_carry x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> succ_double_mask (sub_mask_carry p q0)
-       | XO q0 -> double_mask (sub_mask p q0)
-       | XH -> IsPos (pred_double p))
-    | XO p ->
-      (match y with
-       | XI q0 -> double_mask (sub_mask_carry p q0)
-       | XO q0 -> succ_double_mask (sub_mask_carry p q0)
-       | XH -> double_pred_mask p)
-    | XH -> IsNeg
-
-  (** val sub : positive -> positive -> positive **)
-
-  let sub x y =
-    match sub_mask x y with
-    | IsPos z0 -> z0
-    | _ -> XH
-
-  (** val mul : positive -> positive -> positive **)
-
-  let rec mul x y =
-    match x with
-    | XI p -> add y (XO (mul p y))
-    | XO p -> XO (mul p y)
-    | XH -> y
-
-  (** val size_nat : positive -> nat **)
-
-  let rec size_nat = function
-  | XI p0 -> S (size_nat p0)
-  | XO p0 -> S (size_nat p0)
-  | XH -> S O
-
-  (** val compare_cont : comparison -> positive -> positive -> comparison **)
-
-  let rec compare_cont r x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> compare_cont r p q0
-       | XO q0 -> compare_cont Gt p q0
-       | XH -> Gt)
-    | XO p ->
-      (match y with
-       | XI q0 -> compare_cont Lt p q0
-       | XO q0 -> compare_cont r p q0
-       | XH -> Gt)
-    | XH -> (match y with
-             | XH -> r
-             | _ -> Lt)
-
-  (** val compare : positive -> positive -> comparison **)
-
-  let compare =
-    compare_cont Eq
-
-  (** val ggcdn :
-      nat -> positive -> positive -> (positive, (positive, positive) prod)
-      prod **)
-
-  let rec ggcdn n a b =
-    match n with
-    | O -> Pair (XH, (Pair (a, b)))
-    | S n0 ->
-      (match a with
-       | XI a' ->
-         (match b with
-          | XI b' ->
-            (match compare a' b' with
-             | Eq -> Pair (a, (Pair (XH, XH)))
-             | Lt ->
-               let Pair (g, p) = ggcdn n0 (sub b' a') a in
-               let Pair (ba, aa) = p in
-               Pair (g, (Pair (aa, (add aa (XO ba)))))
-             | Gt ->
-               let Pair (g, p) = ggcdn n0 (sub a' b') b in
-               let Pair (ab, bb) = p in
-               Pair (g, (Pair ((add bb (XO ab)), bb))))
-          | XO b0 ->
-            let Pair (g, p) = ggcdn n0 a b0 in
-            let Pair (aa, bb) = p in Pair (g, (Pair (aa, (XO bb))))
-          | XH -> Pair (XH, (Pair (a, XH))))
-       | XO a0 ->
-         (match b with
-          | XI _ ->
-            let Pair (g, p) = ggcdn n0 a0 b in
-            let Pair (aa, bb) = p in Pair (g, (Pair ((XO aa), bb)))
-          | XO b0 -> let Pair (g, p) = ggcdn n0 a0 b0 in Pair ((XO g), p)
-          | XH -> Pair (XH, (Pair (a, XH))))
-       | XH -> Pair (XH, (Pair (XH, b))))
-
-  (** val ggcd :
-      positive -> positive -> (positive, (positive, positive) prod) prod **)
-
-  let ggcd a b =
-    ggcdn (Coq__1.add (size_nat a) (size_nat b)) a b
- end
-
-module Z =
- struct
-  (** val double : z -> z **)
-
-  let double = function
-  | Z0 -> Z0
-  | Zpos p -> Zpos (XO p)
-  | Zneg p -> Zneg (XO p)
-
-  (** val succ_double : z -> z **)
-
-  let succ_double = function
-  | Z0 -> Zpos XH
-  | Zpos p -> Zpos (XI p)
-  | Zneg p -> Zneg (Coq_Pos.pred_double p)
-
-  (** val pred_double : z -> z **)
-
-  let pred_double = function
-  | Z0 -> Zneg XH
-  | Zpos p -> Zpos (Coq_Pos.pred_double p)
-  | Zneg p -> Zneg (XI p)
-
-  (** val pos_sub : positive -> positive -> z **)
-
-  let rec pos_sub x y =
-    match x with
-    | XI p ->
-      (match y with
-       | XI q0 -> double (pos_sub p q0)
-       | XO q0 -> succ_double (pos_sub p q0)
-       | XH -> Zpos (XO p))
-    | XO p ->
-      (match y with
-       | XI q0 -> pred_double (pos_sub p q0)
-       | XO q0 -> double (pos_sub p q0)
-       | XH -> Zpos (Coq_Pos.pred_double p))
-    | XH ->
-      (match y with
-       | XI q0 -> Zneg (XO q0)
-       | XO q0 -> Zneg (Coq_Pos.pred_double q0)
-       | XH -> Z0)
-
-  (** val add : z -> z -> z **)
-
-  let add x y =
-    match x with
-    | Z0 -> y
-    | Zpos x' ->
-      (match y with
-       | Z0 -> x
-       | Zpos y' -> Zpos (Coq_Pos.add x' y')
-       | Zneg y' -> pos_sub x' y')
-    | Zneg x' ->
-      (match y with
-       | Z0 -> x
-       | Zpos y' -> pos_sub y' x'
-       | Zneg y' -> Zneg (Coq_Pos.add x' y'))
-
-  (** val mul : z -> z -> z **)
-
-  let mul x y =
-    match x with
-    | Z0 -> Z0
-    | Zpos x' ->
-      (match y with
-       | Z0 -> Z0
-       | Zpos y' -> Zpos (Coq_Pos.mul x' y')
-       | Zneg y' -> Zneg (Coq_Pos.mul x' y'))
-    | Zneg x' ->
-      (match y with
-       | Z0 -> Z0
-       | Zpos y' -> Zneg (Coq_Pos.mul x' y')
-       | Zneg y' -> Zpos (Coq_Pos.mul x' y'))
-
-  (** val sgn : z -> z **)
-
-  let sgn = function
-  | Z0 -> Z0
-  | Zpos _ -> Zpos XH
-  | Zneg _ -> Zneg XH
-
-  (** val abs : z -> z **)
-
-  let abs = function
-  | Zneg p -> Zpos p
-  | x -> x
-
-  (** val to_pos : z -> positive **)
-
-  let to_pos = function
-  | Zpos p -> p
-  | _ -> XH
-
-  (** val ggcd : z -> z -> (z, (z, z) prod) prod **)
-
-  let ggcd a b =
-    match a with
-    | Z0 -> Pair ((abs b), (Pair (Z0, (sgn b))))
-    | Zpos a0 ->
-      (match b with
-       | Z0 -> Pair ((abs a), (Pair ((sgn a), Z0)))
-       | Zpos b0 ->
-         let Pair (g, p) = Coq_Pos.ggcd a0 b0 in
-         let Pair (aa, bb) = p in
-         Pair ((Zpos g), (Pair ((Zpos aa), (Zpos bb))))
-       | Zneg b0 ->
-         let Pair (g, p) = Coq_Pos.ggcd a0 b0 in
-         let Pair (aa, bb) = p in
-         Pair ((Zpos g), (Pair ((Zpos aa), (Zneg bb)))))
-    | Zneg a0 ->
-      (match b with
-       | Z0 -> Pair ((abs a), (Pair ((sgn a), Z0)))
-       | Zpos b0 ->
-         let Pair (g, p) = Coq_Pos.ggcd a0 b0 in
-         let Pair (aa, bb) = p in
-         Pair ((Zpos g), (Pair ((Zneg aa), (Zpos bb))))
-       | Zneg b0 ->
-         let Pair (g, p) = Coq_Pos.ggcd a0 b0 in
-         let Pair (aa, bb) = p in
-         Pair ((Zpos g), (Pair ((Zneg aa), (Zneg bb)))))
- end
-
-type q = { qnum : z; qden : positive }
-
-(** val qplus : q -> q -> q **)
-
-let qplus x y =
-  { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)));
-    qden = (Coq_Pos.mul x.qden y.qden) }
-
-(** val qred : q -> q **)
-
-let qred q0 =
-  let { qnum = q1; qden = q2 } = q0 in
-  let Pair (r1, r2) = snd (Z.ggcd q1 (Zpos q2)) in
-  { qnum = r1; qden = (Z.to_pos r2) }
-
-(** val a_val : q list **)
-
-let a_val =
-  Cons ({ qnum = (Zpos XH); qden = XH }, Nil)
-
-(** val sum_val_rec : q list -> q **)
-
-let rec sum_val_rec = function
-| Nil -> { qnum = Z0; qden = XH }
-| Cons (a, l0) -> qred (qplus a (sum_val_rec l0))
-
-(** val sum_val : q list -> q list **)
-
-let sum_val l =
-  Cons ((sum_val_rec l), Nil)
diff --git a/html/AddScript.js b/html/AddScript.js
deleted file mode 100644
index eee5860..0000000
--- a/html/AddScript.js
+++ /dev/null
@@ -1,4 +0,0 @@
-function myadd() {
-  let v = document.getElementById("text").value;
- window.alert(add(v));
-}
diff --git a/html/Makefile.coq.local b/html/Makefile.coq.local
deleted file mode 100644
index 7083bfd..0000000
--- a/html/Makefile.coq.local
+++ /dev/null
@@ -1,62 +0,0 @@
-post-all::
-	$(MAKE) -f $(SELF) Add.mli SmoothTrajectories.mli
-clean::
-	rm -f Add.mli
-
-Add.mli : add.vo
-	echo "mli"
-post-all::
-		$(MAKE) -f $(SELF) Add.ml
-clean::
-		rm -f Add.ml
-Add.ml : add.vo
-		echo "ml"
-
-post-all::
-	$(MAKE) -f $(SELF) Add.cmi SmoothTrajectories.cmi
-
-clean::
-	rm -f Add.cmi Add.cmo jAdd.cmi jAdd.cmo SmoothTrajectories.cmi SmoothTrajectories.cmo jSmoothTrajectories.cmi jSmoothTrajectories.cmo
-
-Add.cmi : Add.mli
-	ocamlfind ocamlc Add.mli
-
-SmoothTrajectories.ml SmoothTrajectories.mli : ../theories/smooth_trajectories.vo
-	cd ../theories; echo 'Require Import QArith smooth_trajectories. Extraction "SmoothTrajectories.ml" Qsmooth_point_to_point Qedges_to_cells Qreduction.Qred.' | coqtop -R . trajectories
-	cp ../theories/SmoothTrajectories.ml ../theories/SmoothTrajectories.mli .
-
-SmoothTrajectories.cmi : SmoothTrajectories.mli
-	ocamlfind ocamlc SmoothTrajectories.mli
-
-post-all::
-	$(MAKE) -f $(SELF) jAdd.cmi jSmoothTrajectories.cmi
-clean::
-	rm -f jAdd.cmi jSmoothTrajectories.cmi
-
-jAdd.cmi :  jAdd.ml
-	ocamlfind ocamlc jAdd.mli
-
-jSmoothTrajectories.cmi :  jSmoothTrajectories.ml
-	ocamlfind ocamlc jSmoothTrajectories.mli
-
-post-all::
-	$(MAKE) -f $(SELF) Add.bytes SmoothTrajectories.bytes
-clean::
-	rm -f Add.bytes SmoothTrajectories.bytes
-
-Add.bytes :  jAdd.cmi jAdd.ml Add.ml Add.cmi
-	ocamlfind ocamlc -package js_of_ocaml -package js_of_ocaml-ppx -linkpkg -o Add.bytes Add.ml jAdd.ml
-
-SmoothTrajectories.bytes :  jSmoothTrajectories.cmi jSmoothTrajectories.ml SmoothTrajectories.ml SmoothTrajectories.cmi
-	ocamlfind ocamlc -package js_of_ocaml -package js_of_ocaml-ppx -linkpkg -o SmoothTrajectories.bytes SmoothTrajectories.ml jSmoothTrajectories.ml
-
-post-all::
-	$(MAKE) -f $(SELF) Add.js SmoothTrajectories.js
-clean::
-	rm -f Add.js SmoothTrajectories.js
-
-Add.js :  Add.bytes
-	js_of_ocaml Add.bytes
-
-SmoothTrajectories.js :  SmoothTrajectories.bytes
-	js_of_ocaml --opt=3 SmoothTrajectories.bytes
diff --git a/html/add.v b/html/add.v
deleted file mode 100644
index 0d36de6..0000000
--- a/html/add.v
+++ /dev/null
@@ -1,14 +0,0 @@
-Require Import List QArith Extraction.
-
-
-Definition a_val := 1%Q :: nil.
-
-Fixpoint sum_val_rec l :=
- match l with a :: l =>     Qred (a + sum_val_rec l)%Q | _ => 0%Q end.
-
-Definition sum_val l := (sum_val_rec l) :: nil.
-
-Compute sum_val ((1#2)%Q :: (1#2)%Q :: nil).
-
-Extraction "Add.ml" a_val sum_val.
-
diff --git a/html/curve.html b/html/curve.html
deleted file mode 100755
index 6de55e6..0000000
--- a/html/curve.html
+++ /dev/null
@@ -1,27 +0,0 @@
-<html>
-	<head>
-		<meta charset="utf-8">
-		<title>Curve</title>
-    <style>
-      body {
-              overflow: hidden;
-              margin: 0px;
-           }
-    </style>
-    <script async
-      src="https://unpkg.com/es-module-shims@1.6.3/dist/es-module-shims.js">
-    </script>
-
-    <script type="importmap">
-      {
-        "imports": {
-        "three": "https://unpkg.com/three@0.150.1/build/three.module.js",
-        "three/addons/": "https://unpkg.com/three@0.150.1/examples/jsm/"
-        }
-      }
-    </script>
-	</head>
-  <body>
-  <script defer type="module" src="./script.js"></script>
-  </body>
-</html>
\ No newline at end of file
diff --git a/html/jAdd.ml b/html/jAdd.ml
deleted file mode 100644
index a57188e..0000000
--- a/html/jAdd.ml
+++ /dev/null
@@ -1,57 +0,0 @@
-(** link code **)
-
-open Js_of_ocaml
-open Add
-
-let rec n2pos n = if n < 2 then XH else 
-                  if n mod 2 == 0 then 
-                  XO (n2pos (n / 2)) else XI (n2pos (n / 2))
-
-let rec pos2n n = 
-  match n with XH -> 1 | XO n -> 2 * (pos2n n) | XI n -> 2 * (pos2n n) + 1
-
-let n2z n = if n = 0 then Z0 else 
-            if 0 < n then Zpos (n2pos n)
-            else Zneg (n2pos n)
-
-let z2n n = match n with
-| Z0 -> 0
-| Zpos n -> pos2n n
-| Zneg n -> - pos2n n
-
-let string2lr s =
-  let le = String.length s in
-  let rec iter i si vi = if i = le then Nil else
-    let v = String.get s i in 
-    if (v == '-') then iter (i + 1) (-1) vi else
-    if (v == '+') then iter (i + 1) (1) vi else
-    if (v == ' ') then Cons (n2z (si * vi), iter (i + 1) 1 0) else
-    iter (i + 1) si (vi * 10 + (Char.code v - 48)) in
-  iter 0 1 0
-
-let rec string2lr1 l = 
-match l with 
-| Cons (n , Cons (Z0, l)) -> Cons ({qnum = n; qden = XH}, (string2lr1 l))
-| Cons (n, Cons (Zpos d, l)) -> Cons ({qnum = n; qden = d}, (string2lr1 l))
-| _ -> Nil
-
-let string2l s = string2lr1 (string2lr s)
-
-let rec l2stringr s l =
-  match l with
-    Nil -> s
-  | Cons (n,l) ->  l2stringr (s ^ (string_of_int (z2n n.qnum)) ^ " " ^
-                                  (string_of_int (pos2n n.qden)) ^ " ")
-                             l
-
-let l2string l = l2stringr "" l
-
-let main s =
-  let l = string2l s in l2string (sum_val l)
-
-let _ =
-  Js.export_all
-    (object%js
-      method add s = Js.string (main (Js.to_string s))
-    end)
-
diff --git a/html/jAdd.mli b/html/jAdd.mli
deleted file mode 100644
index 2fe4da4..0000000
--- a/html/jAdd.mli
+++ /dev/null
@@ -1,6 +0,0 @@
-open Add
-
-val n2pos : int -> positive
-val pos2n : positive -> int
-val n2z : int -> z
-val z2n : z -> int
diff --git a/html/script.js b/html/script.js
deleted file mode 100644
index a0e24cb..0000000
--- a/html/script.js
+++ /dev/null
@@ -1,171 +0,0 @@
-import * as THREE from 'three';
-import { FontLoader } from 'three/addons/loaders/FontLoader.js';
-import { TextGeometry } from 'three/addons/geometries/TextGeometry.js';
-
-const renderer = new THREE.WebGLRenderer();
-renderer.setSize( window.innerWidth, window.innerHeight );
-document.body.appendChild( renderer.domElement );
-
-const camera = new THREE.PerspectiveCamera( 45, window.innerWidth / window.innerHeight, 1, 500 );
-camera.position.set( 0, 0, 10 );
-camera.lookAt( 0, 0, 0 );
-
-const scene = new THREE.Scene();
-scene.background = new THREE.Color( 'lightgrey' );
-
-//create a blue LineBasicMaterial
-const material = new THREE.LineBasicMaterial( { color: 'black' } );
-const cmaterial = new THREE.LineBasicMaterial( { color: 'red' } );
-
-/* 
-BOTTOM
-  ({| left_pt := {| p_x := -4; p_y := -4|};
-      right_pt := {| p_x := 4; p_y := -4|}|}).
-
-*/
-
-const bpoints = [];
-bpoints.push( new THREE.Vector3( - 4, - 4, 0 ) );
-bpoints.push( new THREE.Vector3(   4, - 4, 0 ) );
-
-const bgeometry = new THREE.BufferGeometry().setFromPoints( bpoints );
-
-const bline = new THREE.Line( bgeometry, material );
-
-scene.add( bline );
-
-/* 
-Notation TOP :=
-  ({| left_pt := {| p_x := -4; p_y := 2|};
-      right_pt := {| p_x := 4; p_y := 2|}|}).
-
-*/
-
-const tpoints = [];
-tpoints.push( new THREE.Vector3( - 4, 2, 0 ) );
-tpoints.push( new THREE.Vector3(   4, 2, 0 ) );
-
-const tgeometry = new THREE.BufferGeometry().setFromPoints( tpoints );
-
-const tline = new THREE.Line( tgeometry, material );
-
-scene.add( tline );
-
-/* 
-Definition example_edge_list : seq edge :=
-  Bedge (Bpt (-3) 0) (Bpt (-2) 1) ::
-  Bedge (Bpt (-3) 0) (Bpt 0 (-3)) ::
-  Bedge (Bpt 0 (-3)) (Bpt 3 0) ::
-  Bedge (Bpt (-2) 1) (Bpt 0 1) ::
-  Bedge (Bpt 0 1) (Bpt 1 0) ::
-  Bedge (Bpt (-1) 0) (Bpt 0 (-1)) ::
-  Bedge (Bpt 0 (-1)) (Bpt 1 0) :: nil.
-*/
-
-const edge_list = [
-  {fx : -3, fy : 0, tx : -2, ty : 1},  
-  {fx : -3, fy : 0, tx :  0, ty : -3},
-  {fx :  0, fy : -3, tx : 3, ty : 0},
-  {fx :  -2, fy : 1, tx : 0, ty : 1},
-  {fx :  0, fy : 1, tx : 1, ty : 0},
-  {fx :  -1, fy : 0, tx : 0, ty : -1},
-  {fx :  0, fy : -1, tx : 1, ty : 0}
-];
-
-edge_list.forEach(add_edge);
-
-function add_edge(edge) {
-  let epoints = [];
-  epoints.push( new THREE.Vector3(edge.fx, edge.fy, 0 ) );
-  epoints.push( new THREE.Vector3(edge.tx, edge.ty, 0 ) );
-  let egeometry = new THREE.BufferGeometry().setFromPoints( epoints );
-  let eline = new THREE.Line( egeometry, material );
-  scene.add( eline );
-}
-
-/* curve
-	 = straight {| p_x := -1.9; p_y := -3 # 2 |};
-              {| p_x := -19 # 20; p_y := -480 # 192 |} :: 
-      bezier  {| p_x := -19 # 20; p_y := -480 # 192 |};
-              {| p_x := 0; p_y := -168 # 48 |}
-              {| p_x := 3 # 2; p_y := -12672 # 4608 |}; ::
-      bezier  {| p_x := 3 # 2; p_y := -12672 # 4608 |};
-              {| p_x := 3; p_y := -96 # 48 |}
-              {| p_x := 0x3.4%xQ; p_y := -589824 # 393216 |} :: 
-      bezier  {| p_x := 0x3.4%xQ; p_y := -589824 # 393216 |}
-              {| p_x := 28 # 8; p_y := (-0x1.000)%xQ |}
-              {| p_x := 0x3.4%xQ; p_y := 0 # 131072 |}  ::
-      bezier  {| p_x := 0x3.4%xQ; p_y := 0 # 131072 |}
-              {| p_x := 3; p_y := 0x1.0%xQ |}
-              {| p_x := 4 # 2; p_y := 0 # 192 |} ::
-      bezier  {| p_x := 4 # 2; p_y := 0 # 192 |}
-              {| p_x := 1; p_y := -6 # 6 |}
-              {| p_x := 1 # 2; p_y := -36 # 24 |} ::
-      bezier  {| p_x := 1 # 2; p_y := -36 # 24 |}
-              {| p_x := 0; p_y := -4 # 2 |}
-              {| p_x := -1 # 2; p_y := -36 # 24 |}
-      bezier  {| p_x := -1 # 2; p_y := -36 # 24 |}
-              {| p_x := -1; p_y := -6 # 6 |}
-              {| p_x := (-0x1.4)%xQ; p_y := -1080 # 1728 |} ::
-      bezier  {| p_x := (-0x1.4)%xQ; p_y := -1080 # 1728 |}
-              {| p_x := -12 # 8; p_y := -36 # 144 |}
-              {| p_x := (-0x1.4)%xQ; p_y := 144 # 1152 |} ::
-      bezier  {| p_x := (-0x1.4)%xQ; p_y := 144 # 1152 |}
-              {| p_x := -1; p_y := 2 # 4 |}
-              {| p_x := -1 # 2; p_y := 8 # 32 |} ::
-      bezier  {| p_x := -1 # 2; p_y := 8 # 32 |};
-               ({| p_x := 0; p_y := 0|}).
-              {| p_x := 1 # 6; p_y := 0 # 8 |} ::
-      straight {| p_x := 1 # 6; p_y := 0 # 8 |};
-               {| p_x := 1 # 3; p_y := 0 |};
-*/
-
-const curve_list = [
-  {b : false, fx : -1.9, fy : -(3/2), tx : -(19/20), ty : - (480 / 192)},  
-  {b : true, fx : -(19/20), fy : -(480/192), 
-             cx : 0, cy : -(168/48), tx : (3/2), ty : -(12672/4608)},
- {b : true, fx : (3/2), fy : -(12672/4608), 
-             cx : 3, cy : -(96/48), tx : (3 + 4/16), ty : -(589824/393216)},
- {b : true, fx : (3 + 4 /16), fy : -(589824/393216), 
-             cx : (28/8), cy : -(1), tx : (3 + 4/16), ty : 0},
- {b : true, fx : (3 + 4/16), fy : 0, 
-             cx : 3, cy : 1.0, tx : (4/2), ty : 0},
- {b : true, fx : (4/2), fy : 0, 
-             cx : 1, cy : -(6/6), tx : (1/2), ty : -(36/24)},
- {b : true, fx : (1/2), fy : -(36/24), 
-             cx : 0, cy : -(4/2), tx : -(1/2), ty : -(36/24)},
- {b : true, fx : -(1/2), fy : -(36/24), 
-             cx : -1, cy : -(6/6), tx : -(1 + 4 / 16), ty : -(1080/1728)},
- {b : true, fx : -(1 + 4 / 16), fy : -(1080/1728), 
-             cx : -(12/8), cy : -(36/144), tx : -(1 + 4/16), ty : (144/1152)},
- {b : true, fx : -(1 + 4 / 16), fy : (144/1152), 
-             cx : -1, cy : (2/4), tx : -(1/2), ty : (8/32)},
- {b : true, fx : -(1/2), fy : (8/32), 
-             cx : 0, cy : 0, tx : (1/6), ty : 0},
-  {b : false, fx : (1/6), fy : 0, tx : (1/3), ty : 0}  
-];
-
-curve_list.forEach(add_curve);
-
-function add_curve(curve) {
-  if (curve.b) {
-    let ccurve = new THREE.QuadraticBezierCurve3(
-                	new THREE.Vector3(curve.fx, curve.fy, 0 ),
-	                new THREE.Vector3(curve.cx, curve.cy, 0 ),
-	                new THREE.Vector3(curve.tx, curve.ty, 0 )
-                );
-    let cpoints = ccurve.getPoints( 50 );
-    let cgeometry = new THREE.BufferGeometry().setFromPoints( cpoints );
-    let cline = new THREE.Line( cgeometry, cmaterial );
-    scene.add( cline );
-  } else {
-    let epoints = [];
-    epoints.push( new THREE.Vector3(curve.fx, curve.fy, 0 ) );
-    epoints.push( new THREE.Vector3(curve.tx, curve.ty, 0 ) );
-    let egeometry = new THREE.BufferGeometry().setFromPoints( epoints );
-    let sline = new THREE.Line( egeometry, cmaterial );
-    scene.add( sline );
-  }
-}
-
-renderer.render( scene, camera );
diff --git a/meta.yml b/meta.yml
index 0ae1a2f..60a7716 100644
--- a/meta.yml
+++ b/meta.yml
@@ -27,61 +27,59 @@ license:
   file: LICENSE
 
 supported_coq_versions:
-  text: Coq >= 8.15, MathComp >= 1.16
-  opam: '{ (>= "8.14" & < "8.17~") | (= "dev") }'
+  text: Coq >= 8.17, MathComp >= 2.2.0
+  opam: '{ (>= "8.17" & < "8.20~") | (= "dev") }'
 
 tested_coq_opam_versions:
-- version: '1.16.0-coq-8.15'
-  repo: 'mathcomp/mathcomp'
-- version: '1.16.0-coq-8.16'
+- version: '2.2.0-coq-8.19'
   repo: 'mathcomp/mathcomp'
 
 dependencies:
 - opam:
     name: coq-mathcomp-ssreflect
-    version: '{ (>= "1.16.0" & < "1.17~") | (= "dev") }'
+    version: '{ (>= "2.2.0") | (= "dev") }'
   description: |-
-    [MathComp ssreflect 1.15 or later](https://math-comp.github.io)
+    [MathComp ssreflect 2.2.0 or later](https://math-comp.github.io)
 - opam:
     name: coq-mathcomp-fingroup
-    version: '{ (>= "1.16.0" & < "1.17~") | (= "dev") }'
+    version: '{ (>= "2.2.0") | (= "dev") }'
   description: |-
-    [MathComp fingroup 1.15 or later](https://math-comp.github.io)
+    [MathComp fingroup 2.2.0 or later](https://math-comp.github.io)
 - opam:
     name: coq-mathcomp-algebra
-    version: '{ (>= "1.16.0" & < "1.17~") | (= "dev") }'
+    version: '{ (>= "2.2.0") | (= "dev") }'
   description: |-
-    [MathComp algebra 1.15 or later](https://math-comp.github.io)
+    [MathComp algebra 2.2.0 or later](https://math-comp.github.io)
 - opam:
     name: coq-mathcomp-solvable
-    version: '{ (>= "1.16.0" & < "1.17~") | (= "dev") }'
+    version: '{ (>= "2.2.0") | (= "dev") }'
   description: |-
-    [MathComp solvable 1.15 or later](https://math-comp.github.io)
+    [MathComp solvable 2.2.0 or later](https://math-comp.github.io)
 - opam:
     name: coq-mathcomp-field
-    version: '{ (>= "1.16.0" & < "1.17~") | (= "dev") }'
+    version: '{ (>= "2.2.0") | (= "dev") }'
   description: |-
-    [MathComp field 1.16 or later](https://math-comp.github.io)
+    [MathComp field 2.2.0 or later](https://math-comp.github.io)
 - opam:
     name: coq-mathcomp-real-closed
-    version: '{ (>= "1.1.3") | (= "dev") }'
+    version: '{ (>= "2.0.0") | (= "dev") }'
   description: |-
-    [Mathcomp real closed 1.1.3 or later](https://github.com/math-comp/real-closed/)
+    [Mathcomp real closed 2.0.0 or later](https://github.com/math-comp/real-closed/)
 - opam:
     name: coq-mathcomp-algebra-tactics
-    version: '{ (>= "1.0.0") | (= "dev") }'
+    version: '{ (>= "1.2.0") | (= "dev") }'
   description: |-
-    [Algebra tactics 1.0.0](https://github.com/math-comp/algebra-tactics)
+    [Algebra tactics 1.2.0 or later](https://github.com/math-comp/algebra-tactics)
 - opam:
     name: coq-mathcomp-analysis
-    version: '{ (>= "0.6.1") & (< "0.7~")}'
+    version: '{ (>= "1.0.0") }'
   description: |-
-    [MathComp analysis](https://github.com/math-comp/analysis)
+    [MathComp analysis 1.0.0 or later](https://github.com/math-comp/analysis)
 - opam:
     name: coq-infotheo
-    version: '{ >= "0.5.1" & < "0.6~"}'
+    version: '{ >= "0.7.0"}'
   description: |-
-    [Infotheo](https://github.com/affeldt-aist/infotheo)
+    [Infotheo 0.7.0 of later](https://github.com/affeldt-aist/infotheo)
 
 namespace: mathcomp.trajectories
 
@@ -92,9 +90,9 @@ categories:
 - name: Mathematics/Real Calculus and Topology
 
 publications:
-- pub_url: TODO
-  pub_title:  TODO
-  pub_doi: TODO
+- pub_url: https://inria.hal.science/hal-04312815
+  pub_title:  Safe Smooth Paths between Straight Line Obstacles
+  pub_doi: https://doi.org/10.1007/978-3-031-61716-4_3
 
 documentation: |-
   ## Disclaimer
@@ -112,6 +110,9 @@ documentation: |-
     https://hal.inria.fr/inria-00503017v2/document
   - Theorem of three circles in Coq (2013)
     https://arxiv.org/abs/1306.0783
+  - Safe Smooth Paths between straight line obstacles
+    https://inria.hal.science/hal-04312815
+    https://link.springer.com/chapter/10.1007/978-3-031-61716-4_3
 
   ## Development information
 
diff --git a/theories/axiomsKnuth.v b/theories/axiomsKnuth.v
index 7937f36..6812757 100644
--- a/theories/axiomsKnuth.v
+++ b/theories/axiomsKnuth.v
@@ -7,7 +7,7 @@ Module Type KnuthAxioms.
 Section Dummy.
 
 Variable R : realType.
-Definition Plane := pair_vectType (regular_vectType R) (regular_vectType R).
+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
diff --git a/theories/bern.v b/theories/bern.v
index a71af14..4e0d1bc 100644
--- a/theories/bern.v
+++ b/theories/bern.v
@@ -1,4 +1,4 @@
-From mathcomp Require Import all_ssreflect all_algebra.
+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.
@@ -64,15 +64,15 @@ 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 ltr_add2l.
+- by rewrite ltrD2l.
 - move=> x abx xax1; rewrite (_ : x = x - a + a); last by rewrite addrNK.
-  by rewrite -translate_polq; apply: neg; rewrite ?ltr_subr_addl ?ler_subl_addl.
+  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 ?ler_subr_addl ?ltr_le_sub.
+  by apply: sl; rewrite ?lerBrDl ?ltr_leD.
 Qed.
 
 Lemma one_root1_translate {R : archiFieldType} (l : {poly R}) a b c :
@@ -80,21 +80,21 @@ Lemma one_root1_translate {R : archiFieldType} (l : {poly R}) a b c :
 Proof.
 move=> [x1 [x2 [k [[ax1 x1x2 x2b kp] pos neg sl]]]].
 exists (c + x1), (c + x2), k; split.
-- by rewrite !ltr_add2l.
+- by rewrite !ltrD2l.
 - move=> x cax xcx1; rewrite (_ : x = x - c + c); last by rewrite addrNK.
-  by rewrite -translate_polq; apply pos; rewrite ?ltr_subr_addl ?ler_subl_addl.
+  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 ltr_subr_addl.
-  by rewrite ltr_subl_addl.
+    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 ?ler_add2l.
-  + by rewrite ltr_subr_addl.
-  + by rewrite ler_sub.
-  + by rewrite ltr_subl_addl.
+  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) :
@@ -110,12 +110,12 @@ exists (z * k + z ^+ n) => [| x y x0 xy yz].
 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 ler_add //=.
+rewrite [_ * (y-x)]mulrDl lerD //=.
   rewrite -mulrA (@le_trans _ _ (y * (k * (y - x))))//.
-    rewrite (ler_wpmul2l (le_trans (ltW x0) xy))//.
+    rewrite (ler_wpM2l (le_trans (ltW x0) xy))//.
     exact: kp.
-  by rewrite !(mulrCA _ k) ler_wpmul2l// ler_wpmul2r// subr_ge0.
-rewrite (mulrC (_ - _)) ler_wpmul2r ?subr_ge0// ler_expn2r//.
+  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.
@@ -133,9 +133,9 @@ 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_pdivr_mulr// ?ltr0n// ltr_pmulr// ltr1n.
+   by rewrite ltr_pdivrMr// ?ltr0n// ltr_pMr// ltr1n.
 split => //.
-by rewrite -mulrDr ger_pmulr// -mulr2n -mulr_natr mulVf// pnatr_eq0.
+by rewrite -splitr.
 Qed.
 
 Lemma ler_horner_norm_pol {R : realFieldType} (l : {poly R}) x :
@@ -149,16 +149,16 @@ have [->|ln0] := eqVneq l 0%R.
   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_norm_add _ _))//.
+rewrite (le_trans (ler_normD _ _))//.
 rewrite coefD coefMX eqxx add0r coefC eqxx hornerE [X in X <= _]addrC.
-rewrite ler_add// !hornerE.
+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_wpmul2r.
+by rewrite (eq_bigr _ exteq) -mulr_suml ler_wpM2r.
 Qed.
 
 Lemma cm3 {R : realFieldType} (b : R) :
@@ -174,14 +174,14 @@ 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_norm_add _ _)) //.
+rewrite -addrA (le_trans (ler_normD _ _)) //.
 rewrite -mulrBr -mulrBl !normrM (ger0_norm xge0) (ger0_norm psyx).
-rewrite [X in _ <= X]mulrDl ler_add//.
-  rewrite ler_wpmul2r// (le_trans (ler_horner_norm_pol l y py))//.
+rewrite [X in _ <= X]mulrDl lerD//.
+  rewrite ler_wpM2r// (le_trans (ler_horner_norm_pol l y py))//.
   apply: ler_sum => i _.
-  rewrite ler_wpmul2l ?normr_ge0//.
-  by rewrite ler_expn2r// nnegrE (le_trans _ yb).
-rewrite mulrAC ler_pmul//; first exact: cp.
+  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.
 
@@ -192,7 +192,7 @@ 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' -(ltr_add2l (-x1)) addNr addrA addNr add0r -mulNr.
+  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.
@@ -207,10 +207,10 @@ have [u' u1 u'u] : exists2 u', (1 <= u')%R & (u <= u')%R.
   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_pdivr_mulr// ler_pemulr.
+  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 ltr_addl ltr01.
+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 _=> /=.
@@ -245,28 +245,28 @@ 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 ltr_addl// divr_gt0.
+    - by rewrite ltrDl// divr_gt0.
     - by rewrite (addrC b') addrK mulrA (mulrC c) mulfK // gt_eqF.
-    - apply: le_trans cmp; rewrite ler_add2l//.
-      by rewrite ler_pmul// ltW// invr_gt0.
+    - 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_pdivl_mulr// ltr_subl_addl ltNge cmp.
+  - 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_pinv.
+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_pinv// ltW.
+  + 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_pinv// (le_lt_trans _ bb'v).
+    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 /=.
@@ -276,12 +276,12 @@ exists b^-1, a^-1, k'; split => //.
 - 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_pinv// posrE// 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_pinv// ?posrE ltr01//.
+    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.
@@ -313,34 +313,34 @@ exists b^-1, a^-1, k'; split => //.
     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_pinv ?posrE ?invr_gt0 ?ltW.
-  rewrite mulrDl; apply: ler_add; last first.
+    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_pinv ?posrE.
+          by rewrite lef_pV2 ?posrE.
         by move=> /(_ n'.+1) /andP[].
-      rewrite lter_pmul2l // /t3.
+      rewrite lter_pM2l // /t3.
       apply: (lt_le_trans _ (_ : k * (x ^-1 - z ^-1) <= _)); last first.
         apply: sl; first by apply: ltW.
-        by rewrite ltf_pinv.
-      by rewrite mulr_gt0 // subr_gt0 ltf_pinv.
+        by rewrite ltf_pV2.
+      by rewrite mulr_gt0 // subr_gt0 ltf_pV2.
     apply: le_trans maj'; rewrite /t3 k2p mulrAC.
-    rewrite lter_pmul2r; last by apply: exprn_gt0; rewrite invr_gt0.
+    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_pmul2r; last by [].
+      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_pmul2r; last by rewrite subr_gte0.
-      apply: lt_le_trans (_ : x1 / z <= _); first by rewrite lter_pmul2l.
-      rewrite lter_pmul2r; last by rewrite invr_gte0.
-      by apply: ltW (lt_trans x1ltvz _); rewrite ltef_pinv ?posrE.
+      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_pinv ?posrE.
+    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'].
@@ -350,39 +350,39 @@ exists b^-1, a^-1, k'; split => //.
     by move=>/(_ n'.+1)=> /andP[].
   case: (lerP 0 ((reciprocal_pol l).[x^-1])) => sign; last first.
     apply: le_trans (_ : 0 <= _)%R.
-      rewrite mulNr lter_oppl oppr0; apply: mulr_ge0; last first.
+      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 lter_oppl -mulNr opprB.
+  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_pinv ?posrE.
+        by rewrite subr_ge0 ltW // -(invrK b) ltef_pV2 ?posrE.
       apply: sl.
-        by apply: (ltW (lt_trans x1ltvz _)); rewrite ltef_pinv ?posrE.
-      by rewrite -(invrK b) ltef_pinv ?posrE.
+        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: ler_add; first by [].
+    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_pmul2l.
+  by rewrite lter_pM2l.
 rewrite [_ * e]mulrC; apply: le_trans (_ : e * (u' * (z - x)) <= _)=> /=.
-  rewrite ler_pmul2l//.
+  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_pmul2r// subr_gt0.
+  by rewrite ler_pM2r// subr_gt0.
 rewrite mulrA.
-rewrite ler_pmul2r// ?subr_gt0//.
+rewrite ler_pM2r// ?subr_gt0//.
 by rewrite /e divrK// unitfE gt_eqF.
 Qed.
 
diff --git a/theories/casteljau.v b/theories/casteljau.v
index 5016c64..6f1c6bb 100644
--- a/theories/casteljau.v
+++ b/theories/casteljau.v
@@ -1,5 +1,5 @@
 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.
+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.
 
@@ -43,15 +43,15 @@ 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_norm_add _ _) _=> /=.
-by rewrite ler_add2r; apply: ihm.
+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_pmul2l; first exact: ihm.
+rewrite ltr_pM2l; first exact: ihm.
 apply: lt_trans hx; exact: ltr01.
 Qed.
 
@@ -59,7 +59,7 @@ 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_pmulr; first exact: ihm.
+rewrite ler_pMr; first exact: ihm.
 apply: lt_le_trans hx; exact: ltr01.
 Qed.
 
@@ -125,8 +125,8 @@ 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_pmul2l h1) /= mulr1 /C mulrA mulfV ?normr_eq0 // mul1r.
-  by rewrite big_ord_recr /= -{1}(add0r `|E n|) ler_add2r sumr_ge0.
+  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.
@@ -145,13 +145,13 @@ have xmn0 : ~~ (x^+m == 0) 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) /= ler_addl /= normr_ge0.
+    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_wpmul2l ?normr_ge0 //.
+  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_pdivl_mull; last by rewrite normr_gt0 -e.
+rewrite lter_pdivlMl; last by rewrite normr_gt0 -e.
 by apply: le_trans h3=> /=; rewrite -normrM h2 normrN lexx.
 Qed.
 
@@ -724,7 +724,7 @@ have -> // : forall c : R, c != 0 ->
   move=> c hc; rewrite scaleX_polyE size_factor_expr.
   rewrite [(_ * _ + _) ^+ _]exprDn.
   rewrite (reindex_inj rev_ord_inj) /=.
-  rewrite power_monom poly_def; apply: eq_bigr => j _.
+  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.
@@ -753,7 +753,7 @@ Qed.
 
 Lemma scaleD (p q : {poly R}) u : (p + q) \shift u = p \shift u + (q \shift u).
 Proof.
-by rewrite /scaleX_poly linearD.
+by apply: linearD.
 Qed.
 
 (* TODO : move to another section and abstract over deg a b, maybe *)
@@ -894,11 +894,15 @@ rewrite [_ \shift 0]/shift_poly addr0 comp_polyXr.
   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.
-by rewrite mulVf // mulr1 comp_polyXr linearZ /= shift_polyDK.
+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.
@@ -1047,7 +1051,7 @@ have -> : bernp a b p k =
   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.
+  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.
@@ -1280,24 +1284,24 @@ 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_paddl.
-have ublt : ub < ub' by rewrite ltr_spaddr // ltr01.
+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_minr ltr_spaddr ?A //=
-    ?lt_minl ?B ?orbT // -mulNr mulr_gt0 // ?invr_gt0 // oppr_gt0.
+  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 ler_subl_addl le_minl mulNr lexx.
-rewrite -(ler_pmul2r ub'0) mulfVK; last first.
+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_pmul2r xma) => pu2.
+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_pmul2r // ltNge;case/negP.
+have := (le_lt_trans ab' abs); rewrite ltr_pM2r // ltNge;case/negP.
 by rewrite ltW.
 Qed.
 
@@ -1310,10 +1314,10 @@ 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 lter_oppE itv2.
-  by rewrite hornerN lter_oppE.
+    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 !lter_oppE qd0 qc0.
+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.
@@ -1333,12 +1337,12 @@ exists x; split.
   case/andP: xin=> cx xd.
   case ux : (u <= x).
     have := (sl _ _ cu' ux xd).
-    rewrite qu0 xr subrr -(mulr0 k) ler_pmul2l // subr_le0 => xu.
+    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_pmul2l // subr_le0 => ux'.
+    rewrite qu0 xr subrr -(mulr0 k) ler_pM2l // subr_le0 => ux'.
   by apply/eqP; rewrite eq_le ux'.
 Qed.
 
@@ -1416,7 +1420,7 @@ case h0: (head 0 (seqn0 l) == 0); move: (h0).
   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_nmul2l hsn0) mulr0.
+rewrite lt_neqAle h0 /= -(ler_nM2l hsn0) mulr0.
 by move: p1; rewrite eqb0 ltNge negbK.
 Qed.
 
@@ -1431,7 +1435,7 @@ case h0: (head 0 (seqn0 l) == 0); move: (h0).
 move=> _ /eqP; rewrite hsn0 addn_eq0 /= => /andP [p1]/eqP.
 apply: IH.
 have hsn0' : 0 < a by rewrite lt_neqAle eq_sym a0.
-rewrite  -(ler_pmul2l hsn0') mulr0.
+rewrite -(ler_pM2l hsn0') mulr0.
 by move: p1; rewrite eqb0 ltNge negbK.
 Qed.
 
@@ -1463,7 +1467,7 @@ case alt: (a * head 0 (seqn0 l) < 0)%R; last first.
   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_pmul2l agt0) mulr0 leNgt; apply: negbT; exact alt.
+    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.
@@ -1474,7 +1478,7 @@ case alt: (a * head 0 (seqn0 l) < 0)%R; last first.
 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_pmul2l ap') mulr0 alt.
+  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.
@@ -1636,7 +1640,7 @@ wlog : l q / (0 <= (seqn0 l)`_0).
   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 ler_oppr oppr0 ltW // ltNge sg.
+            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.
@@ -1813,10 +1817,10 @@ have qh :
                       ((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 => //.
+  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) => //.
+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).
diff --git a/theories/cells.v b/theories/cells.v
new file mode 100644
index 0000000..a376596
--- /dev/null
+++ b/theories/cells.v
@@ -0,0 +1,1404 @@
+From HB Require Import structures.
+From mathcomp Require Import all_ssreflect all_algebra.
+Require Export Field.
+Require Import math_comp_complements generic_trajectories points_and_edges
+  events.
+
+
+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.
+
+Section working_environment.
+
+Variable R : realFieldType.
+
+Notation pt := (pt R).
+Notation Bpt := (Bpt R).
+Notation p_x := (p_x R).
+Notation p_y := (p_y R).
+Notation edge := (edge R).
+Notation event := (event R edge).
+Notation point := (point R edge).
+Notation outgoing := (outgoing R edge).
+
+Notation cell := (cell R edge).
+Notation Bcell := (Bcell R edge).
+Notation low := (low R edge).
+Notation high := (high R edge).
+Notation left_pts := (left_pts R edge).
+Notation right_pts := (right_pts R edge).
+
+Definition cell_eqb (ca cb : cell) : bool :=
+  let: generic_trajectories.Bcell lptsa rptsa lowa higha := ca in
+  let: generic_trajectories.Bcell lptsb rptsb lowb highb:= cb in
+  (lptsa == lptsb :> seq pt) && (rptsa == rptsb :> seq pt) &&
+  (lowa == lowb) && (higha == highb).
+
+Lemma cell_eqP : Equality.axiom cell_eqb.
+Proof.
+rewrite /Equality.axiom.
+move => [lptsa rptsa lowa higha] [lptsb rptsb lowb highb] /=.
+have [/eqP <-|/eqP anb] := boolP(lptsa == lptsb :> seq pt).
+  have [/eqP <-|/eqP anb] := boolP(rptsa == rptsb :> seq pt).
+    have [/eqP <-|/eqP anb] := boolP(lowa == lowb).
+      have [/eqP <-|/eqP anb] := boolP(higha == highb).
+        by apply:ReflectT.
+      by apply : ReflectF => [][].
+    by apply : ReflectF => [][].
+  by apply: ReflectF=> [][].
+by apply: ReflectF=> [][].
+Qed.
+
+HB.instance Definition _ := hasDecEq.Build _ cell_eqP.
+
+Definition valid_cell c x := valid_edge (low c) x /\ valid_edge (high c) x.
+
+Lemma order_edges_viz_point c p :
+valid_edge (low c) p -> valid_edge (high c) p ->
+(low c) <| (high c) ->
+p <<= (low c) -> p <<= (high c).
+Proof. apply : order_edges_viz_point'. Qed.
+
+Lemma order_edges_strict_viz_point c p :
+valid_edge (low c) p -> valid_edge (high c) p ->
+(low c) <| (high c) ->
+p <<< (low c) ->  p <<< (high c).
+Proof. apply: order_edges_strict_viz_point'. Qed.
+
+Definition unsafe_Bedge (a b : pt) :=
+  if (ltrP (p_x a) (p_x b)) is LtrNotGe h then Bedge h else
+    Bedge (ltr01 : p_x (Bpt 0 0) < p_x (Bpt 1 0)).
+
+Notation dummy_pt := (generic_trajectories.dummy_pt R 1).
+Notation dummy_event := (generic_trajectories.dummy_event R 1 edge).
+Notation dummy_edge := (generic_trajectories.dummy_edge R 1 edge unsafe_Bedge).
+Notation dummy_cell := (dummy_cell R 1 edge unsafe_Bedge).
+
+Definition head_cell (s : seq cell) := head dummy_cell s.
+Definition last_cell (s : seq cell) := last dummy_cell s.
+
+Definition contains_point :=
+  contains_point R eq_op le +%R (fun x y => x - y) *%R 1 edge
+  (@left_pt R) (@right_pt R).
+
+Lemma contains_pointE p c :
+  contains_point p c = (p >>= low c) && (p <<= high c).
+Proof. by []. Qed.
+
+Definition contains_point' (p : pt) (c : cell)  : bool :=
+   (p >>> low c) && (p <<= (high c)).
+
+Lemma contains_point'W p c :
+  contains_point' p c -> contains_point p c.
+by move=> /andP[] /underWC A B; rewrite contains_pointE A B.
+Qed.
+
+Definition open_limit c :=
+  min (p_x (right_pt (low c))) (p_x (right_pt (high c))).
+
+Definition bottom_left_corner (c : cell) := last dummy_pt (left_pts c).
+
+Definition bottom_left_cells_lex (open : seq cell) p :=
+  {in open, forall c, lexPt (bottom_left_corner c) p}.
+
+(* TODO: these should be at the head. *)
+Definition left_limit (c : cell) :=
+  p_x (last dummy_pt (left_pts c)).
+
+Definition right_limit c := p_x (last dummy_pt (right_pts c)).
+
+Lemma add_point_left_limit (c : cell) (p : pt) :
+  (1 < size (left_pts c))%N ->
+  left_limit (set_left_pts _ _ c
+    (head dummy_pt (left_pts c) :: p :: behead (left_pts c))) =
+  left_limit c.
+Proof.
+rewrite /left_limit.
+by case lptsq : (left_pts c) => [ | p1 [ | p2 ps]].
+Qed.
+
+Definition inside_open_cell p c :=
+  [&& contains_point p c & left_limit c <= p_x p <= open_limit c].
+
+Definition inside_open' p c :=
+  [&& inside_open_cell p c,  p >>> low c & left_limit c < p_x p] .
+
+Lemma inside_open'E p c :
+  inside_open' p c =
+  [&& p <<= high c, p >>> low c, left_limit c < p_x p &
+   p_x p <= open_limit c].
+Proof.
+rewrite /inside_open' /inside_open_cell contains_pointE.
+rewrite strictE -leNgt !le_eqVlt.
+rewrite [in _ >>> low c]/point_under_edge -ltNge subrr.
+by case: (0 < _); case: (_ < p_x p); rewrite ?andbF ?orbT ?andbT.
+Qed.
+
+Definition inside_closed_cell p c :=
+  contains_point p c && (left_limit c <= p_x p <= right_limit c).
+
+Definition inside_closed' p c :=
+  [&& inside_closed_cell p c, p >>> low c & left_limit c < p_x p].
+
+Lemma inside_closed'E p c :
+  inside_closed' p c =
+  [&& p <<= high c, p >>> low c, left_limit c < p_x p &
+     p_x p <= right_limit c].
+Proof.
+rewrite /inside_closed' /inside_closed_cell contains_pointE.
+rewrite strictE -leNgt !le_eqVlt.
+rewrite [in _ >>> low c]/point_under_edge -ltNge subrr.
+by case: (0 < _); case: (_ < p_x p); rewrite ?andbF ?orbT ?andbT.
+Qed.
+
+Definition in_safe_side_left p c :=
+  [&& p_x p == left_limit c, p <<< high c, p >>> low c &
+      p \notin (left_pts c : seq pt)].
+
+Definition in_safe_side_right p c :=
+  [&& p_x p == right_limit c, p <<< high c, p >>> low c &
+      p \notin (right_pts c : seq pt)].
+
+Section proof_environment.
+Variable bottom top : edge.
+
+Definition between_edges (l h : edge) (p : pt) :=
+  (p >>> l) && (p <<< h).
+
+Definition inside_box p :=
+(~~ (p <<= bottom)  && (p <<< top) ) &&
+  ((p_x (left_pt bottom) < p_x p < p_x (right_pt bottom)) &&
+  (p_x (left_pt top) < p_x p < p_x (right_pt top))).
+
+(* this function removes consecutives duplicates, meaning the seq needs
+ to be sorted first if we want to remove all duplicates *)
+Fixpoint no_dup_seq (A : eqType) (s : seq A) : (seq A) :=
+  match s with
+  | [::] => [::]
+  | a::q => match q with
+            | [::] => s
+            | b::r => if a == b then no_dup_seq q else a::(no_dup_seq q)
+            end
+    end.
+
+Lemma no_dup_seq_aux_eq {A : eqType} (s : seq A) :
+  no_dup_seq s = no_dup_seq_aux eq_op s.
+Proof. by elim: s => [ | a s /= ->]. Qed.
+
+(* TODO : remove duplication with generic_trajectories *)
+Definition close_cell (p : pt) (c : cell) :=
+  match vertical_intersection_point p (low c),
+        vertical_intersection_point p (high c) with
+  | None, _ | _, None => c
+  | Some p1, Some p2 => 
+    Bcell (left_pts c) (no_dup_seq [:: p2; p; p1]) (low c) (high c)
+  end.
+
+Definition closing_cells (p : pt) (contact_cells: seq cell) : seq cell :=
+  [seq close_cell p c | c <- contact_cells].
+
+Lemma close_cell_preserve_3sides p c :
+  [/\ low (close_cell p c) = low c,
+      high (close_cell p c) = high c &
+      left_pts (close_cell p c) = left_pts c].
+Proof.
+rewrite /close_cell.
+case: (vertical_intersection_point p (low c))=> [p1 | ] //.
+by case: (vertical_intersection_point p (high c))=> [p2 | ].
+Qed.
+
+Lemma right_limit_close_cell p1 c :
+  valid_edge (low c) p1 -> valid_edge (high c) p1 ->
+  right_limit (close_cell p1 c) = p_x p1.
+Proof.
+move=> vlc vhc; rewrite /close_cell /right_limit.
+rewrite !pvertE //=.
+by case: ifP; case: ifP.
+Qed.
+
+Lemma left_limit_close_cell p1 c :
+   left_limit (close_cell p1 c) = left_limit c.
+Proof.
+rewrite /close_cell.
+by do 2 (case: (vertical_intersection_point _ _) => //).
+Qed.
+
+Lemma inside_box_between p : inside_box p -> between_edges bottom top p.
+Proof.  by move=> /andP[]. Qed.
+
+Lemma inside_box_valid_bottom_top p g :
+  inside_box p ->
+  g \in [:: bottom; top] -> valid_edge g p.
+Proof.
+move=>/andP[] _ /andP[] /andP[] /ltW a /ltW b /andP[] /ltW c /ltW d.
+rewrite /valid_edge/generic_trajectories.valid_edge. 
+by rewrite !inE=> /orP[] /eqP ->; rewrite ?(a, b, c, d).
+Qed.
+
+Definition end_edge_ext (g : edge) (evs : seq event) :=
+  (g \in [:: bottom; top]) || end_edge g evs.
+
+Lemma end_edgeW g evs : end_edge g evs -> end_edge_ext g evs.
+Proof. by rewrite /end_edge_ext=> ->; rewrite orbT. Qed.
+
+Definition close_alive_edges open future_events : bool :=
+all (fun c => (end_edge_ext (low c) future_events) &&
+    (end_edge_ext (high c) future_events)) open.
+
+Lemma insert_opening_all (first_cells  new_open_cells last_cells : seq cell) p :
+all p first_cells  -> all p new_open_cells  ->
+  all p last_cells  -> all p (first_cells++new_open_cells++ last_cells).
+Proof.
+move => C_first C_new C_last.
+ rewrite  all_cat all_cat.
+apply /andP.
+split.
+  by [].
+apply /andP.
+split.
+  by [].
+by [].
+Qed.
+
+Lemma insert_opening_closeness first_cells new_open_cells last_cells events :
+  close_alive_edges first_cells events -> close_alive_edges new_open_cells events ->
+  close_alive_edges last_cells events -> close_alive_edges (first_cells++new_open_cells++ last_cells) events.
+Proof.
+apply insert_opening_all.
+Qed.
+
+Definition adj_rel := [rel x y : cell | high x == low y].
+
+Definition adjacent_cells := sorted adj_rel.
+
+Lemma adjacent_catW s1 s2 : 
+  adjacent_cells (s1 ++ s2) -> adjacent_cells s1 /\ adjacent_cells s2.
+Proof.
+case: s1 => [ // | cs1  s1 /=]; rewrite /adjacent_cells.
+rewrite cat_path => /andP[] -> ps2; split=> //.
+by move/path_sorted: ps2.
+Qed.
+
+Lemma adjacent_cut l2 a lc :
+l2 != nil ->
+((high (last dummy_cell l2) == low a) &&
+adjacent_cells l2 &&
+adjacent_cells (a::lc) ) =
+adjacent_cells (l2 ++ a::lc).
+Proof.
+case : l2 => [//= | c2 q2 _].
+elim : q2 c2 => [ | c3 q3 IH]  c2 //=.
+by rewrite andbT.
+have /= IH' := IH c3.
+rewrite andbCA.
+rewrite -IH'.
+by rewrite !andbA.
+Qed.
+
+Definition bottom_edge_seq_above (s : seq cell) (p : pt) :=
+  if s is c :: _ then (p) <<= (low c) else true.
+
+Definition bottom_edge_seq_below (s : seq cell) (p : pt) :=
+  if s is c :: _ then ~~ (p <<< low c) else true.
+
+Lemma strict_under_cell (c : cell) (p : pt) :
+  valid_cell c p ->
+  low c <| high c -> p <<= (low c) -> ~~ contains_point p c ->
+  p <<< (low c).
+Proof.
+move=> valcp rfc.
+move: (valcp)=> [vallp valhp].
+rewrite (under_onVstrict vallp) => /orP [] //.
+move=> ponl; rewrite /contains_point negb_and negbK=> /orP[] //.
+case/negP.
+apply: (order_edges_viz_point vallp) => //.
+by rewrite under_onVstrict // ponl.
+Qed.
+
+Definition s_right_form (s : seq cell)  : bool :=
+  all (fun c => low c <| high c ) s.
+
+Definition seq_valid (s : seq cell) (p : pt) : bool :=
+    all (fun c => (valid_edge (low c) p) && (valid_edge (high c) p)) s.
+
+Lemma seq_valid_high (s : seq cell) (p : pt) :
+  seq_valid s p -> {in [seq high i | i <- s], forall g, valid_edge g p}.
+Proof.
+by move=> sval g /mapP [c cin ->]; move: (allP sval c cin)=> /andP[].
+Qed.
+
+Lemma seq_valid_low (s : seq cell) (p : pt) :
+  seq_valid s p -> {in [seq low i | i <- s], forall g, valid_edge g p}.
+Proof.
+by move=> sval g /mapP [c cin ->]; move: (allP sval c cin)=> /andP[].
+Qed.
+
+Lemma insert_opening_valid fc nc lc p :
+  [&& seq_valid fc p, seq_valid nc p & seq_valid lc p] =
+  seq_valid (fc ++ nc ++ lc) p.
+Proof.
+by rewrite /seq_valid !all_cat.
+Qed.
+
+Lemma strict_under_seq p c q :
+  adjacent_cells (c :: q) ->
+  seq_valid (c :: q) p ->
+  s_right_form (c :: q) ->
+  p <<< (low c) ->
+  forall c1, c1 \in q -> p <<< (low c1).
+Proof.
+elim: q c => [// | c' q Ih] c adj vals rfs plow c1 c1in.
+move: adj; rewrite /adjacent_cells /= => /andP[/eqP eq_edges adj'].
+move: vals; rewrite /seq_valid /= => /andP[/andP[vallc valhc] valc'q].
+move: rfs; rewrite /s_right_form /= => /andP[lowhigh rfc'q].
+have pc' : p <<< (low c').
+  by rewrite -eq_edges; apply: (order_edges_strict_viz_point vallc).
+have [/eqP c1c' | c1nc'] := boolP (c1 == c').
+  by rewrite c1c'.
+apply: (Ih c')=> //.
+  by move: c1in; rewrite !inE (negbTE c1nc').
+Qed.
+
+Lemma strict_under_seq' p c q :
+  adjacent_cells (c :: q) ->
+  seq_valid (c :: q) p ->
+  s_right_form (c :: q) ->
+  p <<< (low c) ->
+  forall c1, c1 \in (c :: q) -> p <<< (low c1).
+Proof.
+move=> adj sv rf pl c1; rewrite inE=> /orP[/eqP -> // | ].
+by apply: (strict_under_seq adj sv rf pl).
+Qed.
+
+Lemma close_imp_cont c e :
+low c <| high c ->
+valid_edge (low c) (point e) /\ valid_edge (high c) (point e) ->
+event_close_edge (low c) e \/  event_close_edge (high c) e ->
+contains_point (point e) c.
+Proof.
+rewrite contains_pointE /event_close_edge .
+move =>  rf val [/eqP rlc | /eqP rhc].
+move : rf val.
+  rewrite !strictE -rlc {rlc e}.
+  have := area3_two_points (right_pt (low c)) (left_pt (low c)) => [][] _ [] -> _.
+  rewrite ltxx /= /edge_below.
+  move => /orP [] /andP [] //= => pablhlow pabrhlow [] _ validrlhigh.
+  apply: not_strictly_above pablhlow pabrhlow validrlhigh.
+  move : rf val.
+rewrite underE -rhc {rhc}.
+have := area3_two_points (right_pt (high c)) (left_pt (high c)) => [] [] _ [] -> _ /=.
+rewrite le_refl /edge_below /= andbT=> /orP [] /andP [] //= => pablhlow pabrhlow [] valrhlow _ .
+apply : not_strictly_under pablhlow pabrhlow valrhlow.
+Qed.
+
+Lemma contrapositive_close_imp_cont c e :
+low c <| high c->
+valid_edge (low c) (point e) /\ valid_edge (high c) (point e) ->
+~ contains_point (point e) c ->
+~ event_close_edge (low c) e /\ ~ event_close_edge (high c) e.
+Proof.
+  move => rf val ev.
+have aimpb := (close_imp_cont rf val).
+have  := (@contra_not  ( contains_point (point e) c) (event_close_edge (low c) e \/ event_close_edge (high c) e) aimpb ev) .
+move => /orP /= .
+rewrite negb_or.
+by move => /andP [] /negP a /negP.
+Qed.
+
+Lemma adjacent_cons a q : adjacent_cells (a :: q) -> adjacent_cells q.
+Proof.
+by rewrite /=; case: q => [// | b q]; rewrite /= => /andP[].
+Qed.
+
+
+(* this lemma below is not true, see the counter example below.
+Lemma lowest_above_all_above (s : seq cell) p :
+s != [::] ->
+adjacent_cells s ->
+s_right_form s ->
+ p <<< (low (head dummy_cell s)) ->
+forall c, (c \in s) ->   p<<< (low c) /\  p <<< (high c) .
+Proof.
+case: s => [// | c q].
+*)
+
+Lemma lowest_above_all_above_counterexample :
+  ~(forall (s : seq cell) p,
+       s != [::] -> adjacent_cells s ->
+       s_right_form s -> p <<< (low (head dummy_cell s)) ->
+      forall c, (c \in s) ->   p<<< (low c) /\  p <<< (high c)).
+Proof.
+move=> abs.
+set e1 := @Bedge R (Bpt 0 1) (Bpt 1 1) ltr01.
+set e2 := @Bedge R (Bpt 0 2) (Bpt 1 1) ltr01.
+set p := (Bpt 3%:R 0).
+set c := Bcell [::] [::] e1 e2.
+have exrf : s_right_form [:: c].
+  rewrite /= andbT /e1 /e2 /edge_below /=.
+  rewrite /generic_trajectories.point_under_edge !underE /=.
+  rewrite /generic_trajectories.point_under_edge !strictE /=.
+  rewrite !(mul0r, subrr, mul1r, subr0, add0r, addr0, oppr0, opprK, addrK).
+  rewrite le_refl lt_irreflexive /= !andbT.
+  rewrite -[X in X - 2%:R]/(1%:R) -opprB -natrB //  -[(2-1)%N]/1%N.
+  by rewrite lerN10.
+have plow : p <<< low (head dummy_cell [:: c]).
+  rewrite strictE /=.
+  by rewrite !(mul0r, subrr, mul1r, subr0, add0r, addr0, oppr0, opprK) ltrN10.
+have := abs [::c] p isT isT exrf  plow c.
+rewrite inE=> /(_ (eqxx _))=> [][] _.
+rewrite strictE /=.
+rewrite
+  !(mul0r, subrr, mul1r, subr0, add0r, addr0, oppr0, opprK, mulr1, addrK).
+rewrite -natrM -!natrB // -[X in X%:R]/(1%N).
+by rewrite ltNge ler0n.
+Qed.
+
+Definition cells_low_e_top cells low_e : bool :=
+  (cells != nil) && (low (head dummy_cell cells) == low_e) && (high (last dummy_cell cells) == top).
+
+Definition cells_bottom_top cells : bool :=
+  cells_low_e_top cells bottom.
+
+Lemma bottom_imp_seq_below s p :
+cells_bottom_top s -> inside_box p -> bottom_edge_seq_below s p.
+Proof.
+case s=> [// | c q].
+rewrite /cells_bottom_top /cells_low_e_top => /andP []/andP [] _ /eqP /= loweq _.
+rewrite /bottom_edge_seq_below  /inside_box loweq => /andP [] /andP []  /negP nsab _ _ /=.
+by apply /underWC/negP.
+Qed.
+
+Lemma exists_cell_aux low_e p open :
+cells_low_e_top open low_e -> adjacent_cells open ->
+p >>> low_e ->  p <<< top ->
+exists2 c : cell, c \in open & contains_point' p c.
+Proof.
+elim : open low_e => [//= | c0 q IH ].
+case cont : (contains_point' p c0).
+  by exists c0; rewrite ?cont ?inE ?eqxx.
+have := (IH (high c0)).
+move => IH' low_e {IH}.
+rewrite /cells_low_e_top => /andP[] /andP [] _ /= /eqP <- hightop.
+move=> adj lowunder topabove.
+  have : cells_low_e_top q (high c0).
+  rewrite /cells_low_e_top /=.
+  have qnnil: q!= nil.
+    move : hightop lowunder topabove  cont {IH'} adj.
+    case : q => //=.
+    rewrite  /contains_point' /=.
+    by move=> /eqP -> -> /underW ->.
+  rewrite qnnil /=.
+  move : hightop qnnil adj IH'.
+  case : q => [ // | a q /=].
+  move => hightop.
+  by rewrite hightop eq_sym => _ /andP [] ->.
+move => lowtop /=.
+rewrite /contains_point' in cont.
+move : lowunder cont  => -> /= /negbT phc.
+have := (IH' lowtop (path_sorted adj) phc topabove) .
+move => [] x xinq cpx.
+by exists x; rewrite ?in_cons ?xinq /= ?orbT ?cpx.
+Qed.
+
+Lemma exists_cell  p open :
+cells_bottom_top open -> adjacent_cells open  ->
+between_edges bottom top p ->
+exists2 c : cell, c \in open & contains_point' p c.
+Proof.
+move=> cbtom adj /[dup] inbox_e /andP[] pa pu.
+by apply:  (exists_cell_aux cbtom adj).
+Qed.
+
+Definition cell_edges cells := map low cells ++ map high cells.
+
+Lemma head_not_end q e future_events :
+close_alive_edges q (e :: future_events) ->
+(forall c, (c \in q) ->
+~ event_close_edge (low c) e /\ ~ event_close_edge (high c) e) ->
+close_alive_edges q (future_events).
+Proof.
+elim q => [//| c' q' IH cae].
+have cae': close_alive_edges q' (e :: future_events).
+  move : cae.
+  by rewrite /close_alive_edges /all => /andP [] /andP [] _ _.
+move=> condition.
+rewrite /=.
+apply/andP; split; last first.
+  apply: IH=> //.
+  by move=> c cin; apply condition; rewrite inE cin orbT.
+move: cae; rewrite /= /end_edge_ext /= => /andP[] /andP[] /orP[].
+  move=> -> +; rewrite orTb=> /orP[].
+    by move=> ->.
+  move=> /orP [abs | ].
+  case: (condition c').
+    by rewrite inE eqxx.
+  by rewrite abs.
+  by move=> ->; rewrite orbT.
+  move=> /orP [abs | ].
+  case: (condition c').
+    by rewrite inE eqxx.
+  by rewrite abs.
+move=> ->; rewrite orbT.
+move=> /orP[] .
+    by move=> ->.
+  move=> /orP [abs | ].
+  case: (condition c').
+    by rewrite inE eqxx.
+  by rewrite abs.
+by move=> ->; rewrite orbT.
+Qed.
+
+Lemma valid_between_events g e p future :
+lexePt e p ->
+(forall e', e' \in future -> lexePt p (point e')) ->
+valid_edge g e -> inside_box p -> end_edge_ext g future ->
+valid_edge g p.
+Proof.
+move => einfp pinffut vale.
+rewrite /inside_box => /andP [] _ /andP [] botv topv.
+rewrite /end_edge => /orP [].
+  rewrite !inE /valid_edge/generic_trajectories.valid_edge.
+  by move=> /orP [] /eqP ->; rewrite !ltW;
+    move: botv topv=> /andP[] a b /andP[] c d; rewrite ?(a,b,c,d).
+move => /hasP [] e' e'in e'c.
+have pinfe' := pinffut e' e'in.
+rewrite /valid_edge; apply /andP; split.
+  move : vale.
+  rewrite /valid_edge => /andP [] ginfe _.
+  move : einfp.
+  rewrite /lexPt => /orP [esinfp | /andP [] /eqP <- //].
+  by rewrite ltW // (le_lt_trans ginfe esinfp).
+move : e'c.
+rewrite /event_close_edge => /eqP ->.
+move : pinfe'.
+rewrite /lexPt => /orP [ | /andP [] /eqP -> //].
+apply ltW .
+Qed.
+
+Lemma replacing_seq_adjacent l1 l2 fc lc :
+l1 != nil -> l2 != nil ->
+low (head dummy_cell l1) = low (head dummy_cell l2) ->
+high (last dummy_cell l1) = high (last dummy_cell l2) ->
+adjacent_cells (fc ++ l1 ++ lc) ->
+adjacent_cells l2 ->
+adjacent_cells (fc ++ l2 ++ lc).
+Proof.
+rewrite /adjacent_cells; case: fc => [ | a0 fc] /=; case: l1 => //=;
+   case: l2 => //=; move=> a2 l2 a1 l1 _ _ a1a2 l1l2.
+  rewrite cat_path => /andP[] pl1 plc pl2; rewrite cat_path pl2.
+  by move: plc; case: lc => [// | a3 l3 /=]; rewrite -l1l2.
+rewrite cat_path /= cat_path => /andP[] pfc /andP[] jfca1 /andP[] pl1 plc pl2.
+rewrite cat_path /= cat_path; rewrite pfc -a1a2 jfca1 pl2.
+by move: plc; case: lc => [// | a3 l3 /=]; rewrite -l1l2.
+Qed.
+
+Lemma replacing_seq_cells_bottom_top l1 l2 fc lc :
+  l1 != nil -> l2 != nil ->
+  low (head dummy_cell l1) = low (head dummy_cell l2) ->
+  high (last dummy_cell l1) = high (last dummy_cell l2) ->
+  cells_bottom_top (fc ++ l1 ++ lc) = cells_bottom_top (fc ++ l2 ++ lc).
+Proof.
+move=> l1n0 l2n0 hds tls.
+case: fc => [ | c1 fc]; case: lc => [ | c2 lc];
+   rewrite /cells_bottom_top /cells_low_e_top /= ?cats0.
+-  by rewrite l1n0 l2n0 hds tls.
+-  case : l1 l1n0 hds tls => [ // | c1 l1] _; case: l2 l2n0 => [ | c3 l2] //= _.
+   by move=> -> lts; rewrite !last_cat /=.
+- case: l1 l1n0 tls {hds} => [ | c1' l1] //= _; case: l2 l2n0 => [ | c2' l2] //.
+  by move=> _ /=; rewrite !last_cat /= => ->.
+by rewrite !last_cat /=.
+Qed.
+
+Definition all_edges cells events :=
+  cell_edges cells ++ events_to_edges events.
+
+Lemma mono_cell_edges s1 s2 : {subset s1 <= s2} ->
+  {subset cell_edges s1 <= cell_edges s2}.
+Proof.
+by move=> Sub g; rewrite mem_cat => /orP[] /mapP[c cin geq];
+  rewrite /cell_edges geq mem_cat map_f ?orbT // Sub.
+Qed.
+
+Lemma cell_edges_catC s1 s2 :
+  cell_edges (s1 ++ s2) =i cell_edges (s2 ++ s1).
+Proof.
+move=> g.
+by apply/idP/idP; apply: mono_cell_edges => {}g; rewrite !mem_cat orbC.
+Qed.
+
+Lemma cell_edges_cat (s1 s2 : seq cell) :
+  cell_edges (s1 ++ s2) =i cell_edges s1 ++ cell_edges s2.
+Proof.
+move=> g; rewrite /cell_edges !(mem_cat, map_cat) !orbA; congr (_ || _).
+by rewrite -!orbA; congr (_ || _); rewrite orbC.
+Qed.
+
+Lemma cell_edges_cons c s : cell_edges (c :: s) =i
+    (low c :: high c :: cell_edges s).
+Proof. by move=> g; rewrite -[c :: s]/([:: c] ++ s) cell_edges_cat. Qed.
+
+Lemma cell_edges_catCA s1 s2 s3 :
+  cell_edges (s1 ++ s2 ++ s3) =i cell_edges (s2 ++ s1 ++ s3).
+Proof.
+move=> g; rewrite 2!catA [in LHS]cell_edges_cat [in RHS]cell_edges_cat.
+rewrite [in LHS]mem_cat [in RHS]mem_cat; congr (_ || _).
+by rewrite cell_edges_catC.
+Qed.
+
+Definition cover_left_of p s1 s2 :=
+  forall q, inside_box q -> lexePt q p ->
+  has (inside_open' q) s1 || has (inside_closed' q) s2.
+
+Lemma contains_to_inside_open' open evs c p :
+  seq_valid open p -> close_alive_edges open evs ->
+  inside_box p ->
+  p_x (last dummy_pt (left_pts c)) < p_x p ->
+  all (lexePt p) [seq point e | e <- evs] ->
+  c \in open -> contains_point' p c -> inside_open' p c.
+Proof.
+rewrite inside_open'E /contains_point'.
+move=> val clae inbox_p leftb rightb cin /andP[] -> ->.
+rewrite leftb.
+have cledge g : (g \in [:: bottom; top]) || end_edge g evs ->
+        p_x p <= p_x (right_pt g).
+  have [/ltW pbot /ltW ptop] : p_x p < p_x (right_pt bottom) /\
+             p_x p < p_x (right_pt top).
+    by apply/andP; move:inbox_p=> /andP[] _ /andP[] /andP[] _ -> /andP[] _ ->.
+  move=>/orP[]; [by rewrite !inE => /orP[]/eqP -> | ].
+  move/hasP=> [ev' ev'in /eqP ->].
+  apply: lexePt_xW.
+  by apply/(allP rightb)/map_f.
+have /andP [cmp1 cmp2] : (p_x p <= p_x (right_pt (low c))) &&
+                (p_x p <= p_x (right_pt (high c))).
+  by apply/andP; split; apply/cledge; move/allP: clae=> /(_ _ cin)/andP[].
+rewrite /open_limit.
+by case: (ltrP (p_x (right_pt (low c))) (p_x (right_pt (high c))))=> //.
+Qed.
+
+Lemma contact_middle_at_point p cc s1 s2 c :
+  adjacent_cells cc ->
+  seq_valid cc p ->
+  all (contains_point p) cc ->
+  cc = s1 ++ c :: s2 ->
+  (s1 != nil -> p === low c) /\ (s2 != nil -> p === high c).
+Proof.
+move=> adj sv ctps dec.
+have cin : c \in cc by rewrite dec !(inE, mem_cat) eqxx ?orbT.
+have [vlc vhc] : valid_cell c p by move: (allP sv _ cin) => /andP.
+have /andP[plc phc] := (allP ctps _ cin).
+split.
+elim/last_ind: s1 dec => [// | s1 a _] dec _.
+  have /eqP ac : high a == low c.
+    case: s1 dec adj => [ | b s1] -> /=; first by move => /andP[] ->.
+    by rewrite cat_path last_rcons /= => /andP[] _ /andP[].
+  have ain : a \in cc by rewrite dec -cats1 !(mem_cat, inE) eqxx ?orbT.
+  apply: (under_above_on vlc _ plc).
+  by rewrite -ac; move: (allP ctps _ ain)=> /andP[].
+case: s2 dec => [// | a s2] + _.
+rewrite -[ c :: _]/([:: c] ++ _) catA => dec.
+have /eqP ca : high c == low a.
+  case: s1 dec adj => [ | b s1] -> /=; first by move=> /andP[] ->.
+  by rewrite cats1 cat_path last_rcons /= => /andP[] _/andP[].
+have ain : a \in cc by rewrite dec !(mem_cat, inE) eqxx ?orbT.
+apply: (under_above_on vhc phc).
+by rewrite ca; move: (allP ctps _ ain)=> /andP[].
+Qed.
+
+Definition strict_inside_open (p : pt) (c : cell) :=
+  (p <<< high c) && (~~(p <<= low c)) &&
+  (left_limit c < p_x p < open_limit c).
+
+Definition strict_inside_closed (p : pt) (c : cell) :=
+  (p <<< high c) && (~~(p <<= low c)) &&
+  (left_limit c < p_x p < right_limit c).
+
+Definition o_disjoint (c1 c2 : cell) :=
+  forall p, ~~(inside_open' p c1 && inside_open' p c2).
+
+Definition o_disjoint_e (c1 c2 : cell) :=
+  c1 = c2 \/ o_disjoint c1 c2.
+
+Lemma o_disjointC c1 c2 : o_disjoint c1 c2 -> o_disjoint c2 c1.
+Proof. by move=> c1c2 p; rewrite andbC; apply: c1c2. Qed.
+
+Definition disjoint_open_cells :=
+  forall c1 c2 : cell, o_disjoint_e c1 c2.
+
+
+Lemma seq_edge_below s c :
+  adjacent_cells (rcons s c) -> s_right_form (rcons s c) ->
+  path (@edge_below R) (head dummy_edge [seq low i | i <- rcons s c])
+     [seq high i | i <- rcons s c].
+Proof.
+elim: s => [ | c0 s Ih] // /[dup]/= /adjacent_cons adj' adj /andP[] rfc rfo.
+apply/andP;split;[exact: rfc | ].
+have -> : high c0 = head dummy_edge [seq low i | i <- rcons s c].
+  by move: adj; case: (s) => [ | c1 q]; rewrite //= => /andP[] /eqP -> _.
+by apply: Ih.
+Qed.
+
+Lemma seq_edge_below' s :
+  adjacent_cells s -> s_right_form s ->
+  path (@edge_below R) (head dummy_edge [seq low i | i <- s])
+     [seq high i | i <- s].
+Proof.
+elim: s => [ | c0 s Ih] // /[dup]/= /adjacent_cons adj' adj /andP[] rfc rfo.
+apply/andP;split;[exact: rfc | ].
+case sq : s => [// | c1 s'].
+have -> : high c0 = head dummy_edge [seq low i | i <- c1 :: s'].
+  by move: adj; rewrite sq /= => /andP[] /eqP.
+by rewrite -sq; apply: Ih.
+Qed.
+
+Lemma below_seq_higher_edge_aux s g e p  :
+  {in rcons s g & &, transitive (@edge_below R)} ->
+  all (fun g' => valid_edge g' p) (rcons s g) ->
+  sorted (@edge_below R) (rcons s g) ->
+  all (fun g' => valid_edge g' e) (rcons s g) ->
+  {in rcons s g &, no_crossing R} ->
+  {in rcons s g, forall g', p <<< g' -> p <<< g}.
+Proof.
+elim: s => [ | g0 s Ih].
+  rewrite /=?andbT => /= _ _ _ sval noc g1.
+  by rewrite inE=> /eqP ->.
+rewrite -[rcons _ _]/(g0 :: rcons s g)=> e_trans svp.
+move/[dup]/path_sorted=> adj' adj /= sval noc.
+move=> g1 g1in puc1.
+have v0p : valid_edge g0 p by apply: (allP svp); rewrite inE eqxx.
+have vedge g2 : g2 \in rcons s g -> valid_edge g2 p.
+  by move=> g2in; apply: (allP svp); rewrite inE g2in orbT.
+have vgp : valid_edge g p by apply: vedge; rewrite mem_rcons inE eqxx.
+have g0below : g0 <| g.
+  move: adj; rewrite /= (path_sorted_inE e_trans); last by apply/allP.
+  by move=> /andP[]/allP + _; apply; rewrite mem_rcons inE eqxx.
+move:g1in; rewrite /= inE => /orP[/eqP g1g0 | intail].
+  by apply: (order_edges_strict_viz_point' v0p vgp g0below); rewrite -g1g0.
+have tr' : {in rcons s g & &, transitive (@edge_below R)}.
+  move=> g1' g2' g3' g1in g2in g3in.
+  by apply: e_trans; rewrite inE ?g1in ?g2in ?g3in orbT.
+have svp' : all (fun x => valid_edge x p) (rcons s g) by case/andP: svp.
+have sval' : all (fun x => valid_edge x e) (rcons s g) by case/andP: sval.
+have noc' : {in rcons s g &, no_crossing R}.
+  by move=> g1' g2' g1in g2in; apply: noc; rewrite !inE ?g1in ?g2in orbT.
+by apply: (Ih tr' svp' adj' sval' noc' g1 intail puc1).
+Qed.
+
+Definition open_cell_side_limit_ok c :=
+  [&& left_pts c != [::] :> seq pt,
+   all (fun (p : pt) => p_x p == left_limit c) (left_pts c),
+  sorted >%R [seq p_y p | p <- left_pts c],
+  (head dummy_pt (left_pts c) === high c) &
+  (last dummy_pt (left_pts c) === low c)].
+
+Lemma strict_inside_open_valid c (p : pt) :
+  open_cell_side_limit_ok c ->
+  strict_inside_open p  c ->
+  valid_edge (low c) p && valid_edge (high c) p.
+Proof.
+move=> /andP[]; rewrite /strict_inside_open /left_limit /open_limit.
+case: (left_pts c) => [// | w tl _] /andP[] allxl /andP[] _ /andP[].
+rewrite /=; move=> /andP[] _ /andP[] lh _ /andP[] _ /andP[] ll _.
+move=> /andP[] _ /andP[] ls rs.
+rewrite /valid_edge/generic_trajectories.valid_edge ltW; last first.
+  by apply: (le_lt_trans ll).
+rewrite ltW; last first.
+  apply: (lt_le_trans rs).
+  by case: (lerP (p_x (right_pt (low c))) (p_x (right_pt (high c)))) => // /ltW.
+rewrite ltW; last first.
+  apply: (le_lt_trans lh).
+  by rewrite (eqP (allP allxl w _)) //= inE eqxx.
+apply: ltW.
+apply: (lt_le_trans rs).
+by case: (lerP (p_x (right_pt (low c))) (p_x (right_pt (high c)))) => // /ltW.
+Qed.
+
+Lemma valid_high_limits c p :
+  open_cell_side_limit_ok c ->
+  left_limit c < p_x p <= open_limit c -> valid_edge (high c) p.
+Proof.
+move=>/andP[] wn0 /andP[] /allP allx /andP[] _ /andP[] /andP[] _ /andP[] + _ _.
+rewrite (eqP (allx _ (head_in_not_nil _ wn0))) // => onh.
+rewrite /left_limit=> /andP[] /ltW llim.
+rewrite /valid_edge/generic_trajectories.valid_edge (le_trans onh llim) /=.
+rewrite /open_limit.
+case: (lerP (p_x (right_pt (low c))) (p_x (right_pt (high c))))=> // /[swap].
+by apply: le_trans.
+Qed.
+
+Lemma valid_low_limits c p :
+  open_cell_side_limit_ok c ->
+  left_limit c < p_x p <= open_limit c -> valid_edge (low c) p.
+Proof.
+move=>/andP[] wn0 /andP[] /allP ax /andP[] _ /andP[] _ /andP[] _ /andP[] onl _.
+rewrite /left_limit=> /andP[] /ltW llim.
+rewrite /valid_edge/generic_trajectories.valid_edge (le_trans onl llim) /=.
+rewrite /open_limit.
+case: (lerP (p_x (right_pt (low c))) (p_x (right_pt (high c))))=> // /[swap].
+by move=> ph hl; apply/ltW/(le_lt_trans ph hl).
+Qed.
+
+Lemma inside_openP p c :
+  open_cell_side_limit_ok c ->
+  strict_inside_open p c =
+  [&& inside_open' p c, p_x p < open_limit c & p <<< high c].
+Proof.
+move=> cok.
+rewrite /strict_inside_open/inside_open'/inside_open_cell contains_pointE.
+have [pin | ] := boolP (left_limit c < p_x p <= open_limit c); last first.
+  rewrite (lt_neqAle _ (open_limit _)).
+  by rewrite negb_and => /orP[] /negbTE /[dup] A ->; rewrite !andbF.
+have vh : valid_edge (high c) p.
+  by move: (pin) => /(valid_high_limits cok).
+have vl : valid_edge (low c) p.
+  by move: (pin) => /(valid_low_limits cok).
+rewrite [in RHS](under_onVstrict) // [in RHS] strict_nonAunder // negb_and.
+rewrite !le_eqVlt !negbK.
+by have [uh //= | nuh] := boolP(p <<< high c);
+  have [al //= | nal] := boolP(p >>> low c);
+  have [lfp | nlfp] := boolP (left_limit c < p_x p);
+  have [rhp | nrhp] := boolP (p_x p < open_limit c);
+      rewrite ?orbT ?andbT ?orbF ?andbF.
+Qed.
+
+Lemma below_seq_higher_edge s c e p :
+  {in [seq high i | i <- rcons s c] & & ,transitive (@edge_below R)} ->
+  adjacent_cells (rcons s c) -> s_right_form (rcons s c) -> 
+  seq_valid (rcons s c) e -> 
+  {in [seq high i | i <- rcons s c] &, no_crossing R} ->
+  {in rcons s c, forall g, open_cell_side_limit_ok g} ->
+  {in rcons s c, forall c1, strict_inside_open p c1 ->
+                 valid_edge (high c) p-> p <<< high c}.
+Proof.
+move=> e_trans adj rf sval noc csok c1 c1in /[dup]/andP[] /andP[] puc1 _ pp2.
+move=> inpc1.
+set g := high c => vgp.
+set sg := [seq high i | i <- s & valid_edge (high i) p].
+have subp : {subset rcons sg g <= [seq high i | i <- rcons s c]}.
+  move=> g1; rewrite map_rcons 2!mem_rcons 2!inE=>/orP[-> //| ].
+  rewrite /sg=> /mapP[c1' + c1'eq]; rewrite mem_filter=>/andP[] _ c1'in.
+  by apply/orP; right; apply/mapP; exists c1'.
+have e_trans' : {in rcons sg g & &, transitive (@edge_below R)}.
+  move=> g1 g2 g3 g1in g2in g3in.
+  by apply: e_trans; apply: subp.
+have svp : all (fun g' => valid_edge g' p) (rcons sg g).
+  apply/allP=> g'; rewrite -map_rcons => /mapP [c' + ->].
+  by rewrite mem_rcons inE mem_filter => /orP[/eqP -> |  /andP[] + _].
+have adj' : sorted (@edge_below R) (rcons sg g).
+  have sggq : rcons sg g =
+             [seq i  <- [seq high j | j <- rcons s c] | valid_edge i p].
+     by rewrite (@filter_map _ _ high) filter_rcons /= vgp map_rcons.
+  rewrite sggq.
+  apply: (sorted_filter_in e_trans).
+    apply/allP=> g1 /mapP[c' + g'eq]. 
+    rewrite topredE !mem_rcons !inE.
+    rewrite /g=>/orP[/eqP <- | c'in].
+      by rewrite map_rcons mem_rcons inE g'eq eqxx.
+    by rewrite map_rcons mem_rcons inE; apply/orP/or_intror/mapP; exists c'.
+  have := seq_edge_below' adj rf.
+  by case s_eq : s => [ // | a s' /=] /andP[] _.
+have noc' : {in rcons sg g &, no_crossing R}.
+  by move=> g1 g2 /subp g1in /subp g2in;  apply: noc.
+apply: (below_seq_higher_edge_aux e_trans' svp adj' svp noc' _ puc1).
+rewrite -map_rcons; apply/mapP; exists c1 => //.
+move: c1in; rewrite !mem_rcons !inE=>/orP[-> // | c1in].
+rewrite mem_filter c1in andbT; apply/orP/or_intror.
+apply: (proj2 (andP (strict_inside_open_valid _ inpc1))).
+by apply: csok; rewrite mem_rcons inE c1in orbT.
+Qed.
+
+Lemma left_side_below_seq_higher_edge s c e p :
+  adjacent_cells (rcons s c) -> s_right_form (rcons s c) ->
+  seq_valid (rcons s c) e ->
+  {in [seq high i | i <- rcons s c], forall g, p_x (left_pt g) < p_x e} ->
+  {in [seq high i | i <- rcons s c] &, no_crossing R} ->
+  {in rcons s c, forall c1, open_cell_side_limit_ok c1} ->
+  {in rcons s c, forall c1, strict_inside_open p c1 ->
+        valid_edge (high c) p -> p <<< high c}.
+Proof.
+move => adj rfs svals llim noc csok.
+apply: (below_seq_higher_edge _ adj rfs svals) => //.
+have vale' : {in [seq high i | i <- rcons s c], forall g, valid_edge g e}.
+  by apply: seq_valid_high.
+apply: (edge_below_trans _ vale' noc); right; exact: llim.
+Qed.
+
+Lemma right_side_below_seq_higher_edge s c e p :
+  adjacent_cells (rcons s c) -> s_right_form (rcons s c) -> 
+  seq_valid (rcons s c) e ->
+  {in [seq high i | i <- rcons s c], forall g, p_x e < p_x (right_pt g)} ->
+  {in [seq high i | i <- rcons s c] &, no_crossing R} ->
+  {in rcons s c, forall c1, open_cell_side_limit_ok c1} ->
+  {in rcons s c, forall c1, strict_inside_open p c1 -> 
+      valid_edge (high c) p -> p <<< high c}.
+Proof.
+move => adj rfs svals rlim noc csok.
+apply: (below_seq_higher_edge _  adj rfs svals) => //.
+have vale' : {in [seq high i | i <- rcons s c], forall g, valid_edge g e}.
+  by apply: seq_valid_high.
+apply: (edge_below_trans _ vale' noc); left; exact: rlim.
+Qed.
+
+Lemma o_disjoint_eC (c1 c2 : cell) :
+  o_disjoint_e c1 c2 -> o_disjoint_e c2 c1.
+Proof.
+move=> [-> // |]; first by left.
+by move=> disj; right=> p; rewrite andbC; apply: disj.
+Qed.
+
+Definition closed_cell_side_limit_ok c :=
+ [&& left_pts c != [::] :> seq pt,
+   all (fun p : pt => p_x p == left_limit c) (left_pts c),
+   sorted >%R [seq p_y p | p <- left_pts c],
+   head dummy_pt (left_pts c) === high c,
+   last dummy_pt (left_pts c) === low c,
+    right_pts c != [::] :> seq pt,
+   all (fun p : pt => p_x p == right_limit c) (right_pts c),
+   sorted >%R [seq p_y p | p <- right_pts c],
+   head dummy_pt (right_pts c) === high c &
+   last dummy_pt (right_pts c) === low c].
+
+Lemma closed_right_imp_open c:
+  closed_cell_side_limit_ok c -> right_limit c <= open_limit c.
+Proof.
+move=> /andP[] _ /andP[] _ /andP[] _ /andP[] _ /andP[] _.
+move=> /andP[] ln0 /andP[] eqs /andP[] _ /andP[] /andP[] _ /andP[] _ /[swap].
+move=> /andP[] _ /andP[] _.
+rewrite (eqP (allP eqs (head dummy_pt (right_pts c)) (head_in_not_nil _ ln0))).
+rewrite /right_limit /open_limit.
+by case : (lerP (p_x (right_pt (low c))) (p_x (right_pt (high c)))).
+Qed.
+
+Definition any_edge (b : bool) (c : cell) : edge :=
+  if b then low c else high c.
+
+(* This is not used (yet?) *)
+Lemma fc_lc_right_pt s ev events :
+  close_alive_edges s events ->
+  inside_box (point ev) ->
+  all (fun x => lexPtEv  ev x) events ->
+  {in s, forall c b, lexPt (point ev) (right_pt (any_edge b c))}.
+Proof.
+move=> /allP clae inbox_e /allP lexev c cin b.
+have : ((any_edge b c) \in [:: bottom; top]) || end_edge (any_edge b c) events.
+  by have := clae _ cin; rewrite /end_edge /any_edge; case: b=> /= /andP[].
+move=> /orP[ | ].
+  move: inbox_e => /andP[] _ /andP[]/andP[] _ botP /andP[] _ topP.
+  by rewrite !inE => /orP[]/eqP ->; rewrite /lexPt ?botP ?topP.
+by move=>/hasP[ev' ev'in /eqP ->]; apply: lexev.
+Qed.
+
+Lemma seq_low_high_shift s :
+  s != nil ->  adjacent_cells s ->
+  rcons [seq low i | i <- s] (high (last dummy_cell s)) =
+  (low (head dummy_cell s) :: [seq high i | i <- s]).
+Proof.
+elim: s => [ // | c s +] _ /=.
+  case: s => [// | c' s].
+rewrite /=; move=> /(_ isT) Ih => /andP[] /eqP -> adj; congr (_ :: _).
+by apply: Ih.
+Qed.
+
+Lemma cell_edges_high s :
+  s != [::] -> adjacent_cells s ->
+  cell_edges s =i low (head dummy_cell s) :: [seq high i | i <- s].
+Proof.
+move=> sn0 adj g; rewrite mem_cat; apply/idP/idP.
+  move=>/orP[].
+    by rewrite -(seq_low_high_shift sn0 adj) mem_rcons inE orbC => ->.
+  by rewrite inE orbC => ->.
+rewrite inE => /orP[/eqP -> | ].
+  by rewrite map_f // head_in_not_nil.
+by move=> ->; rewrite orbT.
+Qed.
+
+Lemma pvert_y_bottom p : inside_box p -> pvert_y p bottom < p_y p.
+Proof.
+have tmp : bottom \in [:: bottom; top] by rewrite inE eqxx.
+move=> /[dup]/inside_box_valid_bottom_top=> /(_ _ tmp) val. 
+move=> /andP[] /andP[] + _ _.
+by rewrite (under_pvert_y val) -ltNge.
+Qed.
+
+Lemma adjacent_right_form_sorted_le_y s p :
+    seq_valid s p ->
+    adjacent_cells s ->
+    s_right_form s ->
+    sorted <=%R [seq pvert_y p (high c) | c <- s].
+Proof.
+elim: s => [ // | a s Ih] /=.
+move=> /andP[] _ vs /[dup]/adjacent_cons adj + /andP[] _ rfs.
+case s_eq : s => [ // | b s'] /= /andP[]/eqP hl _.
+rewrite hl.
+have bin : b \in s by rewrite s_eq inE eqxx.
+have rfb := (allP rfs b bin).
+have := (allP vs b bin)=> /andP[] vl vh.
+have := order_below_viz_vertical vl vh.
+rewrite (pvertE vl) (pvertE vh) => /(_ _ _ erefl erefl rfb) /= => -> /=.
+by move: Ih; rewrite s_eq; apply; rewrite -s_eq.
+Qed.
+
+Definition edge_side_prop (ev : event) (g : edge) :=
+        if valid_edge g (point ev) then
+          if pvert_y (point ev) g < p_y (point ev) then
+             p_x (point ev) < p_x (right_pt g)
+          else
+             if p_y (point ev) < pvert_y (point ev) g then
+             p_x (left_pt g) < p_x (point ev)
+             else
+           true
+        else
+          true.
+
+Definition edge_side (evs : seq event) (open : seq cell) :=
+  if evs is ev :: _ then
+    all (edge_side_prop ev) [seq high c | c <- open]
+  else true.
+
+Definition extra_bot := Bcell nil nil bottom bottom.
+
+Definition oc_disjoint (c1 c2 : cell) :=
+  forall p, ~~ (inside_open' p c1 && inside_closed' p c2).
+
+Definition disjoint_open_closed_cells :=
+  forall c1 c2, oc_disjoint c1 c2.
+
+Definition c_disjoint (c1 c2 : cell) :=
+  forall p, ~~ (inside_closed' p c1 && inside_closed' p c2).
+
+Lemma c_disjointC (c1 c2 : cell) :
+  c_disjoint c1 c2 -> c_disjoint c2 c1.
+Proof. by move=> cnd p; rewrite andbC; apply: cnd. Qed.
+
+Definition c_disjoint_e (c1 c2 : cell) :=
+  c1 = c2 \/ c_disjoint c1 c2.
+
+Lemma c_disjoint_eC (c1 c2 : cell) :
+  c_disjoint_e c1 c2 -> c_disjoint_e c2 c1.
+Proof.
+move=> cnd; have [/eqP -> | c1nc2] := boolP(c1 == c2).
+  by left.
+case: cnd => [/eqP | cnd ]; first by rewrite (negbTE c1nc2).
+by right; apply: c_disjointC.
+Qed.
+
+Definition disjoint_closed_cells :=
+  forall c1 c2, c_disjoint_e c1 c2.
+
+Definition pt_at_end (p : pt) (e : edge) :=
+  p === e -> p \in [:: left_pt e; right_pt e].
+
+Definition connect_limits (s : seq cell) :=
+  sorted [rel c1 c2 | right_limit c1 == left_limit c2] s.
+
+Definition edge_covered (e : edge) (os : seq cell) (cs : seq cell) :=
+  (exists (opc : cell) (pcc : seq cell), {subset pcc <= cs} /\
+    {in rcons pcc opc, forall c, high c = e} /\
+    connect_limits (rcons pcc opc) /\
+    opc \in os /\
+    left_limit (head_cell (rcons pcc opc)) = p_x (left_pt e)) \/
+  (exists pcc, pcc != [::] /\ 
+    {subset pcc <= cs} /\
+    {in pcc, forall c, high c = e} /\
+    connect_limits pcc /\
+    left_limit (head_cell pcc) = p_x (left_pt e) /\
+    right_limit (last_cell pcc) = p_x (right_pt e)).
+
+Lemma connect_limits_rcons (s : seq cell) (lc : cell) :
+  s != nil -> connect_limits (rcons s lc) =
+   connect_limits s && (right_limit (last dummy_cell s) == left_limit lc).
+Proof.
+elim: s => [// | c0 s Ih] _ /=.
+by rewrite rcons_path.
+Qed.
+
+Lemma left_limit_max c:
+  open_cell_side_limit_ok c ->
+  max (p_x (left_pt (high c))) (p_x (left_pt (low c))) <= left_limit c.
+Proof.
+move=>/andP[] + /andP[] + /andP[] _ /andP[] /andP[] _ + /andP[] _ +.
+rewrite /left_limit ge_max.
+case: (left_pts c) => [ // | p tl] /=.
+by move => _ /andP[] /eqP +  _ /andP[] + _ /andP[] + _ => <- -> ->.
+Qed.
+
+Lemma bottom_left_x c : left_limit c = p_x (bottom_left_corner c).
+Proof. by[]. Qed.
+
+Lemma bottom_left_lex_to_high s p:
+cells_bottom_top s ->
+adjacent_cells s ->
+s_right_form s ->
+all open_cell_side_limit_ok s ->
+inside_box p ->
+bottom_left_cells_lex s p ->
+{in s, forall c, lexPt (left_pt (high c)) p}.
+Proof.
+move=> cbtom adj rfo sok inboxp btm_left c cin.
+have /mem_seq_split [s1 [s2 s12q]] := cin.
+case s2q : s2 => [ | c' s2'].
+   move: cbtom=> /andP[] /andP[] _ _; rewrite s12q s2q last_cat /=.
+   move=> /eqP ctop.
+   move: inboxp=> /andP[] _ /andP[] _ /andP[] + _.
+   by rewrite /lexPt ctop=> ->.
+have c'in : c' \in s.
+  by rewrite s12q s2q !mem_cat !inE eqxx ?orbT.
+move: adj; rewrite s12q s2q=> /adjacent_catW[] _ /= /andP[] /eqP cc' _.
+have c'ok : open_cell_side_limit_ok c'.
+  by apply: (allP sok c').
+have lexbtme := btm_left c' c'in.
+have btmon : bottom_left_corner c' === low c'.
+  by move: c'ok=> /andP[] _ /andP[] _ /andP[] _ /andP[] _.
+have := lexePt_lexPt_trans (on_edge_lexePt_left_pt btmon) lexbtme.
+by rewrite cc'.
+Qed.
+
+Lemma inside_box_valid_bottom x : inside_box x -> valid_edge bottom x.
+Proof.
+move=> /andP[] _ /andP[] /andP[] /ltW + /ltW + _.
+rewrite /valid_edge/generic_trajectories.valid_edge.
+by move=> -> ->.
+Qed.
+
+Section open_cells_decomposition.
+
+Variables open fc cc : seq cell.
+Variable lcc : cell.
+Variable lc : seq cell.
+Variable p : pt.
+
+Hypothesis cbtom : cells_bottom_top open.
+Hypothesis adj : adjacent_cells open.
+Hypothesis rfo : s_right_form open.
+Hypothesis sval : seq_valid open p.
+Hypothesis inbox_p : between_edges bottom top p.
+
+Hypothesis ocd : open = fc ++ cc ++ lcc :: lc.
+Hypothesis allnct : {in fc, forall c, ~~ contains_point p c}.
+Hypothesis allct : {in cc, forall c, contains_point p c}.
+Hypothesis lcc_ctn : contains_point p lcc.
+Hypothesis head_nct : lc != [::] -> ~~ contains_point p (head lcc lc).
+Hypothesis noc : {in cell_edges open &, no_crossing R}.
+
+Let le := low (head lcc cc).
+Let he := high lcc.
+
+#[clearbody]
+Let headin : head lcc cc \in open.
+Proof.
+by rewrite ocd; case: cc => [ | a cc'] /=; rewrite !(mem_cat, inE) eqxx ?orbT.
+Defined.
+
+#[clearbody]
+Let vle : valid_edge le p.  
+Proof. by have /andP[] := (allP sval _ headin). Defined.
+
+#[clearbody]
+Let lccin : lcc \in open.
+Proof. by rewrite ocd !(mem_cat, inE) eqxx !orbT. Defined.
+
+#[clearbody]
+Let lein : le \in cell_edges open.
+Proof. by rewrite mem_cat /le map_f // headin. Defined.
+
+#[clearbody]
+Let hein : he \in cell_edges open.
+Proof. by rewrite mem_cat /he map_f ?orbT // lccin. Defined.
+
+#[clearbody]
+Let vhe : valid_edge he p.
+Proof. by have /andP[] := (allP sval _ lccin). Defined.
+
+#[clearbody]
+Let pal : p >>> le.
+Proof.
+elim/last_ind : {-1}(fc) (erefl fc) => [ | fc' c1 _] fc_eq.
+  suff -> : le = bottom.
+    by move: inbox_p=> /andP[].
+  move: cbtom=> /andP[] /andP[] _ /eqP <- _; rewrite ocd fc_eq /le.
+  by case: (cc).
+have c1in : c1 \in open.
+  by rewrite ocd fc_eq !(mem_cat, mem_rcons, inE) eqxx.
+have /andP[vlc1 vhc1] : valid_edge (low c1) p && valid_edge (high c1) p.
+  by apply: (allP sval).
+have /order_edges_strict_viz_point' : low c1 <| high c1 by apply: (allP rfo).
+move=> /(_ _ vlc1 vhc1) oc1.
+have ctfc : contains_point p (head lcc cc).
+  case cc_eq : (cc) => [ // | c2 cc'].
+  by apply: allct; rewrite /= cc_eq inE eqxx.
+have hc1q : high c1 = low (head lcc cc).
+  move: adj; rewrite ocd fc_eq -cats1 -!catA=> /adjacent_catW[] _ /=.
+  by case: (cc) => [ | ? ?] /= /andP[] /eqP.
+have palc1 : p >>= low c1.
+  apply/negP=> /oc1 abs.  
+  by move: ctfc; rewrite contains_pointE -hc1q abs.
+have nctc1 : ~~ contains_point p c1.
+  by apply: allnct; rewrite fc_eq mem_rcons inE eqxx.
+by move: nctc1; rewrite contains_pointE palc1 /= hc1q.
+Defined.
+
+#[clearbody]
+Let puh : p <<< he.
+Proof.
+case lc_eq : lc => [ | c1 lc'].
+  move: inbox_p => /andP[] _ +.
+  by case/andP : cbtom=> _; rewrite ocd lc_eq !last_cat /= /he => /eqP ->.
+have c1in : c1 \in open.
+  by rewrite ocd lc_eq /= !(mem_cat, inE) eqxx !orbT.
+have /andP[vlc1 vhc1] : valid_edge (low c1) p && valid_edge (high c1) p.
+  by apply: (allP sval).
+have /order_edges_viz_point' := allP rfo _ c1in => /(_ _ vlc1 vhc1) oc1.
+have hlcclc1 : high lcc = low c1.
+  move: adj; rewrite ocd lc_eq=> /adjacent_catW[] _ /adjacent_catW[] _.
+  by move=> /andP[] /eqP.
+have pulc1 : p <<= low c1.
+  by rewrite -hlcclc1; move: lcc_ctn => /andP[].
+move: head_nct; rewrite lc_eq /= contains_pointE negb_and.
+rewrite (oc1 pulc1) orbF negbK -hlcclc1.
+by apply.
+Defined.
+
+Lemma fclc_not_contain c : (c \in fc) || (c \in lc) ->
+  ~~ contains_point p c.
+Proof.
+move=> /orP[ | cl]; first by apply: allnct.
+case lc_eq : lc => [ | c2 lc']; first by move: cl; rewrite lc_eq.
+have adjlc : adjacent_cells (lcc :: lc).
+  by move: adj; rewrite ocd => /adjacent_catW[] _ /adjacent_catW[].
+have adjlc' : adjacent_cells (c2 :: lc').
+  by move: adjlc; rewrite lc_eq=> /andP[] _.
+have sval' : seq_valid (c2 :: lc') p.
+  apply/allP=> x xin; apply: (allP sval); rewrite ocd !(mem_cat, inE).
+  by rewrite lc_eq xin !orbT.
+have lc2_eq : low c2 = he.
+  by move: adjlc; rewrite lc_eq /= /he => /andP[] /eqP ->.
+have rfolc : s_right_form (c2 :: lc').
+  apply/allP=> x xin; apply: (allP rfo).
+  by  rewrite ocd !mem_cat inE lc_eq xin ?orbT.
+have pulc2 : p <<< low c2 by rewrite lc2_eq.
+move: cl; rewrite lc_eq inE => /orP[/eqP -> | cinlc' ].
+  by apply/negP; rewrite contains_pointE pulc2.
+have pulc : p <<< low c.
+  by apply: (strict_under_seq adjlc' sval' rfolc pulc2 cinlc').
+by apply/negP; rewrite contains_pointE pulc.
+Qed.
+
+Lemma above_all_cells (s : seq cell) :
+  seq_valid s p ->
+  adjacent_cells s ->
+  s_right_form s ->
+  p >>> high (last dummy_cell s) ->
+  p >>> low (head dummy_cell s) /\ {in s, forall c, p >>> high c}.
+Proof.
+elim: s => [ | c0 s Ih]; first by move=> _ _ _ ->.
+move=> /= /andP[] /andP[] vl0 vh0 svals adjs /andP[] lbh rfos pah.
+have pal0 : p >>> high c0 -> p >>> low c0.
+  move=> {}pah.
+  rewrite under_pvert_y // -ltNge.
+  apply: (le_lt_trans (edge_below_pvert_y vl0 vh0 lbh)).
+  by rewrite ltNge -under_pvert_y.
+elim/last_ind : {-1}s (erefl s) svals adjs rfos pah => [ | s' c1 _]
+  /= s_eq svals adjs rfos pah.
+  split; last by move=> x; rewrite inE => /eqP ->.
+  by apply: pal0.
+have adjs1 : adjacent_cells (rcons s' c1) by apply: (path_sorted adjs).
+rewrite last_rcons in pah.
+rewrite s_eq last_rcons in Ih; have := Ih svals adjs1 rfos pah.
+move=> [] palh {}Ih.
+have hc0q : high c0 = low (head dummy_cell (rcons s' c1)).
+  by move: adjs; case: (s') => [ | ? ?] /= /andP[] /eqP.
+split; first by apply pal0; rewrite hc0q.
+move=> x; rewrite inE=> /orP[ /eqP -> |]; last by apply: Ih.
+by rewrite hc0q.
+Qed.
+
+Lemma below_all_cells (s : seq cell) :
+  seq_valid s p ->
+  adjacent_cells s ->
+  s_right_form s ->
+  p <<< low (head dummy_cell s) -> {in s, forall c, p <<< high c}.
+Proof.
+elim: s => [ | c0 s Ih]; first by [].
+move=> /= /andP[] /andP[] vl0 vh0 svals adjs /andP[] lbh rfos pah.
+have puh0 : p <<< low c0 -> p <<< high c0.
+  move=> {}pul.
+  rewrite strict_under_pvert_y //.
+  apply: (lt_le_trans _ (edge_below_pvert_y vl0 vh0 lbh)).
+  by rewrite -strict_under_pvert_y.
+have adjs1 : adjacent_cells s by apply: (path_sorted adjs).
+move=> x; rewrite inE => /orP[/eqP -> | ]; first by apply: puh0.
+case s_eq: s => [ // | c1 s'].
+have h0lc1 : high c0 = low c1 by move: adjs; rewrite s_eq /= => /andP[] /eqP.
+by rewrite -s_eq; apply: (Ih) => //; rewrite s_eq /= -h0lc1 (puh0 pah).
+Qed.
+
+Lemma connect_properties :
+  [/\ p >>> le, p <<< he, valid_edge le p, valid_edge he p &
+    forall c, (c \in fc) || (c \in lc) -> ~~contains_point p c].
+Proof. by split; last exact fclc_not_contain. Qed.
+
+Lemma fclc_not_end_aux c e :
+  point e = p ->
+  (c \in fc) || (c \in lc) -> 
+  (~ event_close_edge (low c) e) /\ (~ event_close_edge (high c) e).
+Proof.
+move=> pq /[dup] cin /fclc_not_contain/negP.
+have cino : c \in open.
+  by rewrite ocd !(mem_cat, inE); move:cin=> /orP[] ->; rewrite ?orbT.
+rewrite -pq=>/contrapositive_close_imp_cont; apply.
+  by apply: (allP rfo).
+by rewrite pq; apply/andP/(allP sval).
+Qed.
+
+Lemma low_under_high : le <| he.
+Proof.
+have [// | abs_he_under_le] := noc lein hein; case/negP: pal.
+by have /underW := (order_edges_strict_viz_point' vhe vle abs_he_under_le puh).
+Qed.
+
+Lemma in_cc_on_high c : c \in cc -> p === high c.
+Proof.
+move=> cin.
+have cino : c \in open by rewrite ocd !mem_cat cin !orbT.
+have vhc : valid_edge (high c) p by apply/(seq_valid_high sval)/map_f.
+apply: under_above_on => //; first by apply: (proj2 (andP (allct cin))).
+have [s1 [[ | c2 s2] cceq]] := mem_seq_split cin.
+  move: adj; rewrite ocd cceq -catA /= => /adjacent_catW[] _ /adjacent_catW[].
+  move=> _ /= /andP[] /eqP -> _.
+  by move: lcc_ctn=> /andP[].
+have c2in : c2 \in cc by rewrite cceq !(mem_cat, inE) eqxx !orbT.
+move: adj; rewrite ocd cceq -!catA; do 2 move => /adjacent_catW[] _.
+rewrite /= => /andP[] /eqP -> _.
+by apply: (proj1 (andP (allct c2in))).
+Qed.
+
+End open_cells_decomposition.
+
+Lemma inside_open_cell_valid c p1 :
+  open_cell_side_limit_ok c ->
+  inside_open_cell p1 c ->
+  valid_edge (low c) p1 && valid_edge (high c) p1.
+Proof.
+move=> /andP[] ne /andP[] sxl /andP[] _ /andP[] /andP[] _ onh /andP[] _ onl.
+move=> /andP[] _; rewrite /left_limit /open_limit=> /andP[] ge lemin.
+apply/andP; split.
+  apply/andP; split.
+    by apply: le_trans ge; move: onl=> /andP[].
+  apply: (le_trans lemin).
+  by rewrite ge_min lexx.
+apply/andP; split.
+ apply: le_trans ge; move: onh=> /andP[].
+ rewrite (eqP (allP sxl (head dummy_pt (left_pts c))_)) //.
+ by apply: head_in_not_nil.
+by rewrite le_min in lemin; move: lemin=>/andP[].
+Qed.
+
+End proof_environment.
+
+
+End working_environment.
diff --git a/theories/cells_alg.v b/theories/cells_alg.v
new file mode 100644
index 0000000..d6dbd89
--- /dev/null
+++ b/theories/cells_alg.v
@@ -0,0 +1,7448 @@
+From mathcomp Require Import all_ssreflect all_algebra.
+Require Export Field.
+Require Import generic_trajectories.
+Require Import math_comp_complements points_and_edges events cells.
+Require Import opening_cells.
+
+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.
+
+Section working_environment.
+
+Variable R : realFieldType.
+
+Notation pt := (pt R).
+Notation p_x := (p_x R).
+Notation p_y := (p_y R).
+Notation Bpt := (Bpt R).
+Notation edge := (edge R).
+Notation event' := (event R edge).
+Notation outgoing := (outgoing R edge).
+Notation point := (point R edge).
+
+Notation cell := (cell R edge).
+
+Notation dummy_pt := (dummy_pt R 1).
+Notation dummy_edge := (dummy_edge R 1 edge (@unsafe_Bedge R)).
+Notation dummy_cell := (dummy_cell R 1 edge (@unsafe_Bedge _)).
+Notation dummy_event := (dummy_event R 1 edge).
+
+Definition open_cells_decomposition_contact :=
+  open_cells_decomposition_contact R eq_op le +%R (fun x y => x - y) *%R 1
+    edge (@left_pt R) (@right_pt R).
+
+Definition open_cells_decomposition_rec :=
+  open_cells_decomposition_rec R eq_op le +%R (fun x y => x - y) *%R 1
+  edge (@unsafe_Bedge R) (@left_pt R) (@right_pt R).
+
+Definition open_cells_decomposition :=
+  open_cells_decomposition R eq_op le +%R (fun x y => x - y) *%R 1
+  edge (@unsafe_Bedge R) (@left_pt R) (@right_pt R).
+
+Notation scan_state := (scan_state R edge).
+Notation sc_open1 := (sc_open1 R edge).
+Notation lst_open := (lst_open R edge).
+Notation sc_open2 := (sc_open2 R edge).
+Notation sc_closed := (sc_closed R edge).
+Notation lst_closed := (lst_closed R edge).
+
+
+Definition update_closed_cell :=
+  update_closed_cell R 1 edge.
+
+Definition set_left_pts :=
+  set_left_pts R.
+
+Notation low := (low R edge).
+Notation high := (high R edge).
+Notation left_pts := (left_pts R edge).
+Notation right_pts := (right_pts R edge).
+Notation Bcell := (Bcell R edge).
+
+(* TODO : these should probably be in cell.v *)
+Lemma high_set_left_pts (c : cell) l : high (set_left_pts c l) = high c.
+Proof. by case: c. Qed.
+
+Lemma low_set_left_pts (c : cell) l : low (set_left_pts c l) = low c.
+Proof. by case: c. Qed.
+
+Definition set_pts := set_pts R edge.
+
+(* This function is to be called only when the event is in the middle
+  of the last opening 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 :=
+  update_open_cell R eq_op le +%R (fun x y => x - y) *%R (fun x y => x / y) 1
+  edge (@unsafe_Bedge R) (@left_pt R) (@right_pt R).
+
+Definition update_open_cell_top :=
+  update_open_cell_top R eq_op le +%R (fun x y => x - y) *%R (fun x y => x / y) 1
+  edge (@unsafe_Bedge R) (@left_pt R) (@right_pt R).
+
+Notation Bscan := (Bscan _ _).
+
+Definition simple_step :=
+  simple_step R eq_op le +%R (fun x y => x - y) *%R (fun x y => x / y)
+  1 edge (@unsafe_Bedge R) (@left_pt R) (@right_pt R).
+
+Definition step :=
+  step R eq_op le +%R (fun x y => x - y) *%R (fun x y => x / y)
+  1 edge (@unsafe_Bedge R) (@left_pt R) (@right_pt R).
+
+Definition scan events st : seq cell * seq cell :=
+  let final_state := foldl step st events in
+  (sc_open1 final_state ++ lst_open final_state :: sc_open2 final_state,
+   lst_closed final_state :: sc_closed final_state).
+
+Definition start_open_cell :=
+  start_open_cell R eq_op le +%R (fun x y => x - y)
+  *%R (fun x y => x / y) edge (@left_pt R) (@right_pt R).
+
+(*
+Definition start (events : seq event) (bottom : edge) (top : edge) :
+  seq cell * seq cell :=
+  match events with
+  | nil => ([:: start_open_cell bottom top], nil)
+  | ev0 :: events =>
+    let (newcells, lastopen) :=
+      opening_cells_aux (point ev0) (sort (@edge_below _) (outgoing ev0))
+            bottom top in
+      scan events (Bscan newcells lastopen nil nil
+         (close_cell (point ev0) (start_open_cell bottom top))
+         top (p_x (point ev0)))
+  end.
+
+*)
+
+Lemma cell_edges_sub_high bottom top (s : seq cell) :
+  cells_bottom_top bottom top s ->
+  adjacent_cells s -> cell_edges s =i bottom::[seq high c | c <- s].
+Proof.
+case: s bottom => [ | c0 s] /= bottom; first by [].
+rewrite /cells_bottom_top /cells_low_e_top=> /= /andP[] /eqP lc0 A lowhigh.
+rewrite /cell_edges=> g; rewrite mem_cat.
+have main : [seq high c | c <- c0 :: s] =
+            rcons [seq low c | c <- s] (high (last c0 s)).
+  elim: s c0 lowhigh {lc0 A} => [ | c1 s Ih] c0 lowhigh; first by [].
+  rewrite /=.
+  move: lowhigh=> /= /andP[/eqP -> lowhigh]; congr (_ :: _).
+  by apply: Ih.
+rewrite main mem_rcons inE orbC map_cons inE -!orbA.
+rewrite !(orbCA _ (g == low _)) orbb.
+rewrite inE lc0; congr (_ || _).
+by rewrite -map_cons main mem_rcons inE.
+Qed.
+
+Lemma not_bottom_or_top bottom top (ev : event') :
+  inside_box bottom top (point ev) ->
+  out_left_event ev ->
+  {in outgoing ev, forall g, g \notin [:: bottom; top]}.
+Proof.
+move=> inbox oute g gin; apply/negP=> abs.
+have lgq : left_pt g = point ev by apply/eqP/oute.
+move: inbox=> /andP[]; rewrite -lgq; move: abs; rewrite !inE=> /orP[] /eqP ->.
+  by rewrite left_pt_below.
+by rewrite (negbTE (left_pt_above _)) !andbF.
+Qed.
+
+Section proof_environment.
+Variables bottom top : edge.
+
+Notation extra_bot := (extra_bot bottom).
+Notation close_alive_edges := (close_alive_edges bottom top).
+Notation cells_bottom_top := (cells_bottom_top bottom top).
+Notation inside_box := (inside_box bottom top).
+Notation open_cell_side_limit_ok := (@open_cell_side_limit_ok R).
+Notation seq_low_high_shift := (@seq_low_high_shift R).
+Notation cover_left_of := (@cover_left_of _ bottom top).
+
+Section open_cells_decomposition.
+
+Lemma open_cells_decomposition_contact_none open_cells p :
+  open_cells_decomposition_contact open_cells p = None ->
+  open_cells != [::] -> ~~contains_point p (head dummy_cell open_cells).
+Proof.
+rewrite /contains_point.
+case: open_cells => [// | /= c0 q].
+by case : ifP=> ? //;
+  case: (open_cells_decomposition_contact q p)=> // [] [] [].
+Qed.
+
+Lemma open_cells_decomposition_contact_main_properties open_cells p cc c' lc:
+  open_cells_decomposition_contact open_cells p = Some (cc, lc, c') ->
+  cc ++ c' :: lc = open_cells /\
+  contains_point p c' /\
+  {in cc, forall c, contains_point p c} /\
+  (lc != [::] -> ~~ contains_point p (head c' lc)).
+Proof.
+elim: open_cells cc c' lc => [ // | c q Ih] cc c' lc.
+rewrite /=; case: ifP => [ctpcc | nctpcc] //.
+case occ_eq : (open_cells_decomposition_contact _ _)
+       (@open_cells_decomposition_contact_none q p)
+    => [[[cc1 lc1] c1] | ] nonecase [] <- <- <-; last first.
+  split;[ by [] | split; [by [] | split; [by [] | ] ]].
+  by case: (q) nonecase => [// | c2 q2] ; apply.
+have [eqls [ctc1 [allct nctlc1]]] := Ih _ _  _ occ_eq.
+split; first by rewrite /=; congr (_ :: _).
+split; first by [].
+split; last by [].
+by move=> w; rewrite inE => /orP[/eqP -> // | ]; apply: allct.
+Qed.
+
+Lemma decomposition_main_properties open_cells p fc cc lcc lc le he:
+  open_cells_decomposition open_cells p = (fc, cc, lcc, lc, le, he) ->
+  (exists2 w, w \in open_cells & contains_point' p w) ->
+  open_cells = fc ++ cc ++ lcc :: lc /\
+  contains_point p lcc /\
+  {in cc, forall c, contains_point p c} /\
+  {in fc, forall c, ~~contains_point p c} /\
+  (lc != [::] -> ~~ contains_point p (head lcc lc)) /\
+  he = high lcc /\
+  le = low (head lcc cc) /\
+  le \in cell_edges open_cells /\
+  he \in cell_edges open_cells.
+Proof.
+rewrite /open_cells_decomposition/generic_trajectories.open_cells_decomposition.
+elim : open_cells fc cc lcc lc le he => [ | c q Ih] fc cc lcc lc le he.
+  by rewrite /= => _ [] w.
+rewrite /=; case: ifP=> ctc.
+  rewrite -[generic_trajectories.open_cells_decomposition_contact _ _ _ _ _
+              _ _ _ _ _ _ _]/(open_cells_decomposition_contact q p).
+  case ocdc_eq : (open_cells_decomposition_contact q p) => [[[cc0 lc0] c0]|].
+    move=> [] <- <- <- <- <- <- _.
+    have [qeq [ctc0 [allct nct]] ]:=
+     open_cells_decomposition_contact_main_properties ocdc_eq.
+    split; first by rewrite /= qeq.
+    split; first by [].
+    split; first by move=> c1 /orP[/eqP -> | ] //; apply: allct.
+    repeat (split; first by []).
+    by rewrite -qeq !mem_cat !map_f ?orbT // !(mem_cat, inE) eqxx ?orbT.
+  move=> [] <- <- <- <- <- <- _.
+  repeat (split; first by []).
+  split.
+    by move: (open_cells_decomposition_contact_none ocdc_eq); case: (q).
+  split; first by [].
+  split; first by [].
+  by rewrite !mem_cat !map_f ?orbT // inE eqxx.
+rewrite -[generic_trajectories.open_cells_decomposition_rec _ _ _ _ _
+              _ _ _ _ _ _ _ _]/(open_cells_decomposition_rec q p).
+case ocdr_eq : (open_cells_decomposition_rec q p) => [[[fc1 cc1] lcc1] lc1].
+move=> [] <- <- <- <- <- <- [] w win ctw.
+have ex2 :exists2 w, w \in q & contains_point' p w.
+  exists w; last by [].
+  move: win ctw; rewrite inE => /orP[/eqP -> | //].
+  by move=> /contains_point'W; rewrite /contains_point ctc.
+have := Ih fc1 cc1 lcc1 lc1 (low (head lcc1 cc1)) (high lcc1).
+rewrite /open_cells_decomposition_rec in ocdr_eq.
+rewrite ocdr_eq => /(_ erefl ex2).
+move=> [qeq [ctplcc1 [allct [allnct [nctlc [leeq heq]]]]]].
+split; first by rewrite /= qeq.
+split; first by [].
+split; first by [].
+split.
+  move=> c0; rewrite inE=> /orP[/eqP -> // | c0in]; last first.
+    by rewrite ?allnct.
+  by rewrite /contains_point ctc.
+repeat (split; first by []).
+by rewrite qeq !mem_cat !map_f ?orbT //; case:(cc1) => [| a b] /=; subset_tac.
+Qed.
+
+Lemma decomposition_connect_properties open_cells p
+  first_cells contact last_contact last_cells low_f high_f:
+s_right_form open_cells ->
+seq_valid open_cells p ->
+adjacent_cells open_cells ->
+cells_bottom_top open_cells ->
+between_edges bottom top p ->
+open_cells_decomposition open_cells p  =
+  (first_cells, contact, last_contact, last_cells, low_f, high_f) ->
+[/\ p >>> low_f, p <<< high_f, valid_edge low_f p, valid_edge high_f p &
+forall c, (c \in first_cells) || (c \in last_cells) -> ~ contains_point p c].
+Proof.
+move=> rfo sval adj cbtom inbox_p oe.
+have [w win ctw'] := exists_cell cbtom adj inbox_p.
+have [ocd [ctpl [allct [allnct [nctlc [-> [-> _]]]]]]]:=
+   decomposition_main_properties oe (exists_cell cbtom adj inbox_p).
+have [A B C D E] :=
+  connect_properties cbtom adj rfo sval inbox_p ocd allnct allct ctpl nctlc.
+by split => // c cin; apply/negP/E.
+Qed.
+
+Lemma decomposition_not_end open_cells e :
+forall first_cells contact last_contact last_cells low_f high_f,
+s_right_form open_cells ->
+seq_valid open_cells (point e) ->
+adjacent_cells open_cells ->
+cells_bottom_top open_cells ->
+between_edges bottom top (point e) ->
+open_cells_decomposition open_cells (point e) =
+ (first_cells, contact, last_contact, last_cells, low_f, high_f) ->
+forall c, (c \in first_cells) || (c \in last_cells) ->
+ ( ~ event_close_edge (low c) e) /\ ( ~ event_close_edge (high c) e).
+Proof.
+move=> fc cc lcc lc low_f high_f rfo sval adj cbtom inbox_p oe c cold.
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq leq]]]]]]:=
+   decomposition_main_properties oe (exists_cell cbtom adj inbox_p).
+by apply: (fclc_not_end_aux cbtom adj _ sval inbox_p ocd _ lcc_ctn flcnct).
+Qed.
+
+Lemma open_cells_decomposition_point_on open p fc cc lcc lc le he c:
+  cells_bottom_top open ->
+  adjacent_cells open ->
+  between_edges bottom top p ->
+  seq_valid open p ->
+  open_cells_decomposition open p = (fc, cc, lcc, lc, le, he) ->
+  c \in cc -> p === high c.
+Proof.
+
+move=> cbtom adj inbox_p sval oe ccc.
+have [ocd [lcc_ctn [allctn _]]]:= decomposition_main_properties oe
+           (exists_cell cbtom adj inbox_p).
+by have := in_cc_on_high adj sval ocd allctn lcc_ctn ccc.
+Qed.
+
+Lemma last_first_cells_high open p fc cc lcc lc le he :
+  cells_bottom_top open ->
+  adjacent_cells open ->
+  between_edges bottom top p ->
+  open_cells_decomposition open p = (fc, cc, lcc, lc, le, he) ->
+  last bottom [seq high i | i <- fc] = le.
+Proof.
+move=> cbtom adj inbox_p oe.
+have exi := exists_cell cbtom adj inbox_p.
+have [ocd [_ [_ [_ [_ [heq [leq _]]]]]]] :=
+   decomposition_main_properties oe exi.
+suff -> : last bottom [seq high i | i <- fc] = low (head lcc cc).
+  by rewrite leq.
+move: cbtom=> /andP[] /andP[] _ /eqP + _.
+move : adj; rewrite ocd.
+  elim/last_ind: {-1}(fc) (erefl fc) => [//= | fc' c1 _].
+    by case: (cc) => [ | c2 cc'].
+rewrite -cats1 -catA=> fceq /adjacent_catW /= [] _ + _.
+rewrite cats1 map_rcons last_rcons.
+by case: (cc) => [ | c2 cc'] /andP[] + _; rewrite /adj_rel /= => /eqP.
+Qed.
+
+Lemma head_last_cells_low open p fc cc lcc lc le he :
+  cells_bottom_top open ->
+  adjacent_cells open ->
+  between_edges bottom top p ->
+  open_cells_decomposition open p = (fc, cc, lcc, lc, le, he) ->
+  head top [seq low i | i <- lc] = he.
+Proof.
+move=> cbtom adj inbox_p oe.
+have exi := exists_cell cbtom adj inbox_p.
+have [ocd [_ [_ [_ [_ [-> _]]]]]] :=
+   decomposition_main_properties oe exi.
+move: cbtom=> /andP[] _ /eqP.
+move: adj; rewrite ocd => /adjacent_catW [] _ /adjacent_catW [] _ /=.
+  rewrite !last_cat /=.
+case : (lc) => [ | c2 lc'] //=.
+by move=> /andP[] /eqP ->.
+Qed.
+
+(* Temporary trial, but this lemma might be better placed in
+  points_and_edges. *)
+Lemma decomposition_above_high_fc p open fc cc lcc lc le he c1:
+  open_cells_decomposition open p = (fc, cc, lcc, lc, le, he) ->
+  cells_bottom_top open ->
+  adjacent_cells open ->
+  between_edges bottom top p ->
+  s_right_form open ->
+  seq_valid open p ->
+  c1 \in fc -> p >>> high c1.
+Proof.
+move=> oe cbtom adj inbox_e rfo sval c1in.
+have exi := exists_cell cbtom adj inbox_e.
+have [ocd [_ [_ [_ [_ [heq leq]]]]]] := decomposition_main_properties oe exi.
+have [pal puh vl vp _]:=
+  decomposition_connect_properties rfo sval adj cbtom inbox_e oe.
+rewrite under_pvert_y; last first.
+  apply: (seq_valid_high sval).
+  by rewrite map_f //; rewrite ocd; subset_tac.
+rewrite -ltNge.
+have : pvert_y p le < p_y p.
+  by move: pal; rewrite under_pvert_y // -ltNge.
+apply: le_lt_trans.
+move: c1in.
+have [fceq |[fc' [lfc fceq]]]: fc = nil \/ exists fc' lfc, fc = rcons fc' lfc.
+    by elim/last_ind : (fc) => [ | fc' lfc _];[left | right; exists fc', lfc].
+  by rewrite fceq.
+have := last_first_cells_high cbtom adj inbox_e oe.
+rewrite fceq map_rcons last_rcons => <-.
+rewrite mem_rcons inE => /orP[/eqP c1lfc | c1o]; first  by rewrite c1lfc.
+have [a [b pab]] := mem_seq_split c1o.
+move: fceq; rewrite pab -cats1 -catA /= => fceq.
+(* requirement for path_edge_below_pvert_y *)
+have req1 : all (valid_edge (R := _) ^~ p)
+    [seq high i | i <- c1 :: b ++ [:: lfc]].
+  apply/allP; apply: (sub_in1 _ (seq_valid_high sval)); apply: sub_map.
+  by rewrite ocd fceq; subset_tac.
+have req2 : path (@edge_below R) (high c1) [seq high i | i <- b ++ [:: lfc]].
+  have := seq_edge_below' adj rfo.
+  rewrite ocd (_ : fc = rcons a c1 ++ rcons b lfc); last first.
+     by move: fceq; rewrite -!cats1 !catA /= -!catA /=.
+  rewrite -!catA [X in path _ _ X]map_cat cat_path=> /andP[] _.
+  rewrite !map_rcons last_rcons map_cat cat_path => /andP[] + _.
+  by rewrite -cats1.
+have : path (<=%R) (pvert_y p (high c1))
+  [seq pvert_y p (high i) | i <- b ++ [:: lfc]].
+  by have := path_edge_below_pvert_y req1 req2; rewrite -map_comp.
+rewrite le_path_sortedE => /andP[] /allP + _.
+move=> /(_ (pvert_y p (high lfc))); apply.
+by rewrite (map_f (fun c => pvert_y p (high c))) //; subset_tac.
+Qed.
+
+Lemma decomposition_under_low_lc p open fc cc lcc lc le he c1:
+  open_cells_decomposition open p = (fc, cc, lcc, lc, le, he) ->
+  cells_bottom_top open ->
+  adjacent_cells open ->
+  between_edges bottom top p ->
+  s_right_form open ->
+  seq_valid open p ->
+  c1 \in lc -> p <<< low c1.
+Proof.
+move=> oe cbtom adj inbox_e rfo sval c1in.
+have exi := exists_cell cbtom adj inbox_e.
+have [ocd _] := decomposition_main_properties oe exi.
+rewrite strict_under_pvert_y; last first.
+  by apply/(seq_valid_low sval)/map_f; rewrite ocd; subset_tac.
+have [pal puh vl vp _]:=
+  decomposition_connect_properties rfo sval adj cbtom inbox_e oe.
+have puhe : p_y p < pvert_y p he.
+  by move: puh; rewrite strict_under_pvert_y.
+apply: (lt_le_trans puhe).
+move: c1in; case lceq : lc => [ // | flc lc'] c1in.
+have := head_last_cells_low cbtom adj inbox_e oe.
+rewrite lceq /= => <-.
+move: c1in; rewrite inE => /orP[/eqP c1flc | c1o]; first by rewrite c1flc.
+have [a [b Pab]] := mem_seq_split c1o.
+(* requirement for path_edge_below_pvert_y *)
+have req1 : all (@valid_edge R ^~ p)
+  [seq low i | i <- flc :: a ++ c1 :: b].
+  apply/allP; apply: (sub_in1 _ (seq_valid_low sval)); apply: sub_map.
+  by rewrite ocd lceq Pab; subset_tac.
+have req2 : path (@edge_below R) (low flc) [seq low i | i <- a ++ c1 :: b].
+  have := seq_edge_below' adj rfo.
+  have [on0 headq] : open != [::] /\ low (head dummy_cell open) = bottom.
+    by move: cbtom=> /andP[] /andP[] + /eqP + _.
+  have headq' : head dummy_edge [seq low i | i <- open] = bottom.
+      by move: on0 headq; case: (open)=> [ // | ? ?] /=.
+  rewrite headq' => pathoh.
+  have : path (@edge_below R) bottom (bottom :: [seq high i | i <- open]).
+      by rewrite /= edge_below_refl.
+  have  := seq_low_high_shift on0 adj; rewrite headq => <-.
+  rewrite -cats1 cat_path => /andP[] + _.
+  rewrite ocd lceq Pab.
+  by rewrite 2!map_cat 2!cat_path /= => /andP[] _ /andP[] _ /andP[] _ /andP[].
+have : path (<=%R) (pvert_y p (low flc))
+  [seq pvert_y p (low i) | i <- a ++ c1 :: b].
+  by have := path_edge_below_pvert_y req1 req2; rewrite -map_comp.
+rewrite le_path_sortedE => /andP[] /allP + _.
+move=> /(_ (pvert_y p (low c1))); apply.
+by rewrite (map_f (fun c => pvert_y p (low c))); subset_tac.
+Qed.
+
+End open_cells_decomposition.
+
+Lemma open_cells_decomposition_cat f l p :
+   adjacent_cells (f ++ l) ->
+   s_right_form (f ++ l) ->
+   seq_valid (f ++ l) p ->
+   (exists2 c, c \in l & contains_point' p c) ->
+   p >>> low (head dummy_cell l) ->
+   let '(fc', cc, lcc, lc, le, he) :=
+     open_cells_decomposition l p in
+   open_cells_decomposition (f ++ l) p =
+     (f ++ fc', cc, lcc, lc, le, he).
+Proof.
+move=> + + + exi pal.
+elim: f => [ | c0 f Ih].
+  move=> adj rfo sval.
+ by case: (open_cells_decomposition l p) => [[[[[fc cc] lcc] lc] le] he].
+rewrite /= => adj /andP[] lbh0 rfo /andP[] /andP[] vlc0 vhc0 sval.
+case ocal_eq : (open_cells_decomposition l p) =>
+  [[[[[fc' cc'] lcc'] lc'] le'] he'].
+case oca_eq : (open_cells_decomposition _ _) =>
+  [[[[[fc1 cc1] lcc1] lc1] le1] he1].
+have exi0 : exists2 c, c \in c0 :: f ++ l & contains_point' p c.
+  by case: exi => c cin A; exists c=> //; subset_tac.
+have := decomposition_main_properties oca_eq exi0 =>
+  -[ocd [lcc_ctn [allct [allnct [flnct [heq [leq [lein hein]]]]]]]].
+have := decomposition_main_properties ocal_eq exi =>
+  -[ocd' [lcc_ctn' [allct' [allnct' [flnct' [heq' [leq' [lein' hein']]]]]]]].
+have svalf : seq_valid f p.
+  by apply/allP=> x xin; apply: (allP sval); subset_tac.
+have rfof : s_right_form f.
+  by apply/allP=> x xin; apply: (allP rfo); subset_tac.
+have adjf : adjacent_cells f.
+  by move: adj; rewrite cat_path=> /andP[] /path_sorted.
+have hfq : high (last c0 f) = low (head dummy_cell l).
+  case: (l) adj exi => [ | c1 l']; first by move => _ [].
+  by rewrite cat_path /==> /andP[] _ /andP[] /eqP.
+move: oca_eq; rewrite /open_cells_decomposition/generic_trajectories.open_cells_decomposition /=.
+case: ifP=> [c0ctn | c0nctn].
+  move: c0ctn; rewrite /generic_trajectories.contains_point -[X in _ && X]negbK.
+  have [/eqP f0 | fn0] := boolP (f == nil).
+    by move: hfq; rewrite f0 /= => ->; rewrite pal andbF.
+  have := above_all_cells svalf adjf rfof.
+  have -> : high (last dummy_cell f) = high (last c0 f).
+    by case: (f) fn0.
+  rewrite hfq pal=> /(_ isT) [] palf _.
+  have -> : high c0 = low (head dummy_cell f).
+    by move: adj fn0; case: (f) => [// | ? ?] /= /andP[] /eqP.
+  by rewrite palf andbF.
+move: ocal_eq; rewrite /open_cells_decomposition/generic_trajectories.open_cells_decomposition.
+rewrite -/(open_cells_decomposition_rec _ _).
+case ocal_eq: (open_cells_decomposition_rec _ _) =>
+  [[[fc2 cc2] lcc2] lc2] [] <- <- <- <- <- <-.
+have adj' : adjacent_cells (f ++ l).
+  by move: adj=> /path_sorted.
+have := Ih adj' rfo sval; rewrite /open_cells_decomposition.
+rewrite /generic_trajectories.open_cells_decomposition.
+rewrite /open_cells_decomposition_rec in ocal_eq. rewrite ocal_eq.
+rewrite -/(open_cells_decomposition_rec _ _).
+case: (open_cells_decomposition_rec (f ++ l) p) => [[[fc4 cc4] lcc4] lc4].
+by move=> -[] -> -> -> -> _ _ [] <- <- <- <- <- <-.
+Qed.
+
+Lemma open_cells_decomposition_cat' f l p :
+  adjacent_cells (f ++ l) ->
+  s_right_form (f ++ l) ->
+  seq_valid (f ++ l) p ->
+  (exists2 c, c \in (f ++ l) & contains_point' p c) ->
+  f != nil ->
+  p >>> high (last dummy_cell f) ->
+   let '(fc', cc, lcc, lc, le, he) :=
+     open_cells_decomposition l p in
+   open_cells_decomposition (f ++ l) p =
+     (f ++ fc', cc, lcc, lc, le, he).
+Proof.
+move=> adj rfo sval [w win wctn] fnnil paf.
+have adjf : adjacent_cells f by move: adj=> /adjacent_catW[].
+have rfof : s_right_form f.
+  by apply/allP=> x xin; apply: (allP rfo); subset_tac.
+have svalf : seq_valid f p.
+  by apply/allP=> x xin; apply: (allP sval); subset_tac.
+have winl : w \in l.
+  have [_ abaf] := above_all_cells svalf adjf rfof paf.
+  have wnf : w \notin f.
+    apply/negP=> abs.
+    by move: wctn; rewrite /contains_point' -[X in _ && X]negbK abaf ?andbF //.
+  by move: win; rewrite mem_cat (negbTE wnf).
+have exi' : exists2 c, c \in l & contains_point' p c by exists w.
+have hfq : high (last dummy_cell f) = low (head dummy_cell l).
+  move: adj fnnil.
+  case:(f) => [ // | c0 f']; rewrite /= cat_path=> /andP[] _ + _.
+  by move: winl; case: (l) => [ // | c1 l'] _ /= /andP[] /eqP.
+by apply: open_cells_decomposition_cat; rewrite // -hfq.
+Qed.
+
+Lemma open_cells_decomposition_single f l c p :
+  adjacent_cells (f ++ c :: l) ->
+  s_right_form (f ++ c :: l) ->
+  seq_valid (f ++ c :: l) p ->
+  p >>> low c ->
+  p <<< high c ->
+  open_cells_decomposition (f ++ c :: l) p =
+    (f, nil, c, l, low c, high c).
+Proof.
+move=> adj srf sv pal puh.
+have exi : exists2 c', c' \in (c :: l) & contains_point' p c'.
+  by exists c;[ rewrite inE eqxx // | rewrite /contains_point' pal underW].
+have := open_cells_decomposition_cat adj srf sv exi pal.
+case ocl : (open_cells_decomposition (c :: l) p) =>
+        [[[[[fc cc] lcc] lc] le] he].
+move: ocl; rewrite /open_cells_decomposition /=.
+rewrite /generic_trajectories.open_cells_decomposition /=.
+rewrite -/(contains_point _ _).
+have -> : contains_point p c.
+  by rewrite contains_pointE underWC // underW.
+case lq : l => [ | c1 l'] /=.
+  by move=> [] <- <- <- <- <- <-; rewrite cats0.
+rewrite -/(contains_point _ _).
+suff -> : contains_point p c1 = false.
+  by move=> [] <- <- <- <- <- <-; rewrite cats0.
+move: adj=> /adjacent_catW[] _; rewrite lq /= => /andP[] /eqP lc1q  _.
+by rewrite contains_pointE -lc1q puh.
+Qed.
+
+Section step.
+
+
+Variable e : event'.
+Variable fop : seq cell.
+Variable lsto : cell.
+Variable lop : seq cell.
+Variable cls : seq cell.
+Variable lstc :  cell.
+Variable lsthe : edge.
+Variable lstx : R.
+Variable future_events : seq event'.
+Variable p : pt.
+
+Let open := (fop ++ lsto :: lop).
+
+(* lsto is only guaranteed to be the highest of the last created cells. *)
+(* It might be the case that the next event is in the left side of this *)
+(* cell *)
+#[clearbody]
+Let lstoin : lsto \in open.
+Proof.  by rewrite /open; subset_tac. Defined.
+
+
+Hypothesis inbox_all_edges :
+  all (fun g => (g \in [:: bottom; top]) ||
+        (inside_box (left_pt g) && inside_box (right_pt g)))
+      (cell_edges open).
+Hypothesis inbox_all_events :
+  all inside_box [seq point x | x <- (e :: future_events)].
+
+#[clearbody]
+Let inbox_e : inside_box (point e).
+Proof. by have /andP[] := inbox_all_events. Defined.
+
+#[clearbody]
+Let inbox_es : all inside_box [seq point x | x <- future_events].
+Proof. by have /andP[] := inbox_all_events. Defined.
+
+Hypothesis oute : out_left_event e.
+Hypothesis rfo : s_right_form open.
+Hypothesis cbtom : cells_bottom_top open.
+Hypothesis adj : adjacent_cells open.
+Hypothesis sval : seq_valid open (point e).
+Hypothesis cle : close_edges_from_events (e :: future_events).
+Hypothesis clae : close_alive_edges open (e :: future_events).
+Hypothesis lstheq : lsthe = high lsto.
+Hypothesis lstheqc : lsthe = high lstc.
+Hypothesis lstxq : lstx = left_limit lsto.
+Hypothesis abovelstle :
+  p_x (point e) = lstx -> (point e) >>> low lsto.
+Hypothesis elexp : lexePt (point e) p.
+Hypothesis plexfut : {in future_events, forall e', lexePt p (point e')}.
+Hypothesis inbox_p : inside_box p.
+Hypothesis noc : {in all_edges open (e :: future_events) &, no_crossing R}.
+Hypothesis sort_evs : path (@lexPtEv _) e future_events.
+Hypothesis pwo : pairwise (@edge_below _) (bottom :: [seq high c | c <- open]).
+Hypothesis btom_left_corners :
+  {in open, forall c, lexPt (bottom_left_corner c) (point e)}.
+Hypothesis open_side_limit : all open_cell_side_limit_ok open.
+Hypothesis close_side_limit : all (@closed_cell_side_limit_ok _)
+   (rcons cls lstc).
+Hypothesis lex_left_limit :
+  all (fun x => lexPt x (point e)) (behead (left_pts lsto)).
+Hypothesis disjoint_open_closed :
+  {in open & rcons cls lstc, disjoint_open_closed_cells R}.
+Hypothesis disjoint_closed : {in rcons cls lstc &, disjoint_closed_cells R}.
+Hypothesis closed_right_limit :
+ {in rcons cls lstc, forall c, right_limit c <= p_x (point e)}.
+Hypothesis uniq_closed : uniq (rcons cls lstc).
+Hypothesis non_empty_closed :
+  {in rcons cls lstc, forall c, exists p, inside_closed' p c}.
+Hypothesis non_empty_right : (1 < size (right_pts lstc))%N.
+Hypothesis uniq_out : uniq (outgoing e).
+Hypothesis high_inj : {in open &, injective high}.
+Hypothesis btm_left : bottom_left_cells_lex open (point e).
+Hypothesis uniq_open : uniq open.
+Hypothesis open_non_inner :
+    {in open, forall c, non_inner (high c) (point e)}.
+Hypothesis lex_open_edges :
+   {in [seq high c | c <- open], forall g, lexPt (left_pt g) (point e) &&
+          lexePt (point e) (right_pt g)}.
+Hypothesis left_limit_has_right_limit :
+  {in open, forall c p, inside_box p -> left_limit c = p_x p ->
+    contains_point' p c -> has (inside_closed' p) (rcons cls lstc)}.
+Hypothesis cover_left_of_e : cover_left_of (point e) open (rcons cls lstc).
+
+(* Thanks to the disoc lemma, we only need to prove that the high edges
+  of all open cells satisfy the pairwise property for edge_below to
+  obtain disjointness of cells. *)
+
+Lemma disoc_i i j s : (i < j < size s)%N ->
+  adjacent_cells s ->
+  pairwise (@edge_below _) [seq high c | c <- s] ->
+  all open_cell_side_limit_ok s ->
+  o_disjoint_e (nth dummy_cell s i) (nth dummy_cell s j).
+Proof.
+move=> + adjs pws open_side_limit_s.
+move=> /andP[] iltj jlts.
+have ilts : (i < size s)%N by apply: ltn_trans jlts.
+set x := nth dummy_cell s i.
+set y := nth dummy_cell s j.
+have iin : x \in s by apply: mem_nth.
+have jin : y \in s by apply: mem_nth.
+have xok : open_cell_side_limit_ok x by apply: (allP open_side_limit_s).
+have yok : open_cell_side_limit_ok y by apply: (allP open_side_limit_s).
+right=> q; apply/negP=> /andP[].
+move=> /andP[] /[dup] inx /(inside_open_cell_valid xok) /andP[] _ vhx _.
+move=> /andP[] /[dup] iny /(inside_open_cell_valid yok) /andP[] vly _.
+move=> /andP[] qay _.
+move: inx=> /andP[] /andP[] _ quhx _.
+case/negP:qay.
+move: iltj; rewrite leq_eqVlt=> /orP[/eqP/esym jq | ].
+  move: adjs.
+  rewrite -(cat_take_drop j.+1 s)=> /adjacent_catW[] + _.
+  rewrite (take_nth dummy_cell jlts) -/y jq (take_nth dummy_cell ilts) -/x.
+  rewrite -2!cats1 -catA /= =>/adjacent_catW[] _ /=.
+  by rewrite andbT=> /eqP <-.
+move=> i1ltj.
+set j' := j.-1.
+have jj : j = j'.+1 by rewrite (ltn_predK i1ltj).
+have j'lts : (j' < size s)%N.
+  by apply: ltn_trans jlts; rewrite jj.
+have iltj' : (i < j')%N by rewrite -ltnS -jj.
+move: adjs.
+rewrite -(cat_take_drop j.+1 s)=> /adjacent_catW[] + _.
+rewrite (take_nth dummy_cell jlts) -/y jj (take_nth dummy_cell j'lts).
+rewrite -2!cats1 -catA /= =>/adjacent_catW[] _ /= /andP[] /eqP lyq _.
+apply: (order_edges_viz_point' vhx) => //.
+rewrite -lyq.
+move: pws => /(pairwiseP dummy_edge) /(_ i j') /=; rewrite size_map 2!inE.
+move=> /(_ ilts j'lts iltj').
+by rewrite -[dummy_edge]/(high dummy_cell) !(nth_map dummy_cell).
+Qed.
+
+Lemma disoc s:
+  adjacent_cells s ->
+  pairwise (@edge_below _) [seq high c | c <- s] ->
+  all open_cell_side_limit_ok s ->
+ {in s &, disjoint_open_cells R}.
+Proof.
+move=> adjs pws sok.
+move=> x y xin yin.
+set i := find (pred1 x) s.
+set j := find (pred1 y) s.
+case : (leqP i j) => [ | jlti]; last first.
+  have ilts : (i < size s)%N by rewrite -has_find has_pred1.
+  have jint : (j < i < size s)%N by rewrite jlti ilts.
+  move: xin; rewrite -has_pred1=> /(nth_find dummy_cell) => /eqP <-.
+  move: yin; rewrite -has_pred1=> /(nth_find dummy_cell) => /eqP <-.
+  by apply/o_disjoint_eC/disoc_i.
+rewrite leq_eqVlt=> /orP[/eqP ij | iltj].
+  move: xin; rewrite -has_pred1=> /(nth_find dummy_cell) /= /eqP.
+  rewrite -/i ij /j.
+  move: yin; rewrite -has_pred1=> /(nth_find dummy_cell) /= /eqP -> ->.
+  by left.
+have jlto : (j < size s)%N by rewrite -has_find has_pred1.
+have jint : (i < j < size s)%N by rewrite iltj jlto.
+move: xin; rewrite -has_pred1=> /(nth_find dummy_cell) => /eqP <-.
+move: yin; rewrite -has_pred1=> /(nth_find dummy_cell) => /eqP <-.
+by apply/disoc_i.
+Qed.
+
+#[clearbody]
+Let bet_e : between_edges bottom top (point e).
+Proof. by apply inside_box_between. Defined.
+
+#[clearbody]
+Let exi : exists2 c, c \in open & contains_point' (point e) c.
+Proof. by apply: (exists_cell cbtom adj bet_e). Defined.
+
+Lemma close_cell_ok c :
+  contains_point (point e) c ->
+  valid_edge (low c) (point e) -> valid_edge (high c) (point e) ->
+  open_cell_side_limit_ok c ->
+  closed_cell_side_limit_ok (close_cell (point e) c).
+Proof.
+move=> ctp vl vh.
+rewrite /open_cell_side_limit_ok/closed_cell_side_limit_ok.
+rewrite /close_cell /=; have /exists_point_valid [p1 /[dup] vip1 ->] := vl.
+have /exists_point_valid [p2 /[dup] vip2 -> /=] := vh.
+move=> /andP[] -> /andP[]-> /andP[]-> /andP[] -> -> /=.
+have [o1 /esym/eqP x1]:=intersection_on_edge vip1.
+have [o2 /eqP x2]:=intersection_on_edge vip2.
+rewrite -?(eq_sym (point e)).
+(* TODO : this line performs a lot of complicated things, but they mostly
+   failed at porting time. *)
+case:ifP (o1) (o2) =>[/eqP q1 |enp1];case:ifP=>[/eqP q2 |enp2];
+  rewrite ?q1 ?q2;
+  rewrite -?q1 -?q2 /= ?eqxx ?x2 ?x1 /= => -> -> //=; rewrite ?andbT.
+- move: x1 x2 ctp=> /eqP/esym x1 /eqP x2 /andP[] el _.
+  have := (above_edge_strict_higher_y x1 (negbT enp2) el).
+  by rewrite /right_limit /= x1 eqxx /=; apply.
+- move: x1 x2 ctp=> /eqP/esym x1 /eqP x2 /andP[] _ eh.
+  have := (under_edge_strict_lower_y x2 (negbT enp1) eh o2).
+  rewrite /right_limit /= x2 eqxx /=; apply.
+move: x1 x2 ctp=> /eqP/esym x1 /eqP x2 /andP[] el eh.
+rewrite (above_edge_strict_higher_y x1 _ el) //; last first.
+  exact: negbT.
+rewrite  (under_edge_strict_lower_y x2 (negbT enp1) eh) //.
+by rewrite !andbT /right_limit /= -x1 -x2 eqxx.
+Qed.
+
+Lemma closing_cells_side_limit' cc :
+  s_right_form cc ->
+  seq_valid cc (point e) ->
+  adjacent_cells cc ->
+  all open_cell_side_limit_ok cc ->
+  all (contains_point (point e)) cc ->
+  point e >>> low (head dummy_cell cc) ->
+  point e <<< high (last dummy_cell cc) ->
+  all (@closed_cell_side_limit_ok _) (closing_cells (point e) cc).
+Proof.
+move=> rfc valc adjc oks ctps abovelow belowhigh.
+rewrite /closing_cells.
+rewrite all_map.
+apply/allP=> //= c cin.
+have vlc: valid_edge (low c) (point e) by have:= (allP valc c cin) => /andP[].
+have vhc : valid_edge (high c) (point e)
+   by have := (allP valc c cin) => /andP[].
+apply: close_cell_ok=> //.
+  by apply: (allP ctps).
+by apply: (allP oks).
+Qed.
+
+Lemma close'_subset_contact q c :
+  valid_cell c (point e) ->
+  closed_cell_side_limit_ok (close_cell (point e) c) ->
+  inside_closed' q (close_cell (point e) c) -> inside_open' q c.
+Proof.
+move=>[] vl vh.
+move=>/closed_right_imp_open.
+rewrite inside_open'E // inside_closed'E /close_cell.
+have [p1 vip1] := exists_point_valid vl.
+have [p2 vip2] := exists_point_valid vh.
+rewrite vip1 vip2 /= => cok /andP[] -> /andP[] -> /andP[] -> rlim /=.
+by apply: (le_trans rlim cok).
+Qed.
+
+Lemma close_cell_right_limit c :
+  valid_cell c (point e) ->
+  right_limit (close_cell (point e) c) = p_x (point e).
+Proof.
+move=> [vl vh].
+rewrite /close_cell; rewrite !pvertE // /right_limit /=.
+by case: ifP=> cnd1 //; case: ifP=> cnd2.
+Qed.
+
+Definition state_open_seq (s : scan_state) :=
+  sc_open1 s ++ lst_open s :: sc_open2 s.
+
+Definition inv1_seq (s : seq cell) :=
+  close_alive_edges s future_events /\
+  (future_events = [::] \/
+    seq_valid s (point (head dummy_event future_events))) /\
+  adjacent_cells s /\ cells_bottom_top s /\ s_right_form s.
+
+Definition invariant1 (s : scan_state) :=
+  inv1_seq (state_open_seq s).
+
+(* Let val_between g (h : valid_edge g (point e)) :=
+  valid_between_events elexp plexfut h inbox_p. *)
+
+#[clearbody]
+Let subo : {subset outgoing e <= all_edges open (e :: future_events)}.
+Proof. by rewrite /all_edges; subset_tac. Defined.
+
+#[clearbody]
+Let subo' : {subset sort (@edge_below _) (outgoing e)
+                 <= all_edges open (e :: future_events)}.
+Proof.
+by move=> x; rewrite mem_sort=> xo; apply: subo.
+Defined.
+
+#[clearbody]
+Let oute' : {in sort (@edge_below _) (outgoing e),
+    forall g, left_pt g == (point e)}.
+Proof. by move=> x; rewrite mem_sort; apply: oute. Defined.
+
+(* This was a temporary movement section for objects
+  transferred to the opening_cells section, but now it seems
+  opening_cells_pairwise has to stay in this part of the world. *)
+
+Lemma opening_cells_pairwise le he :
+   point e >>> le ->
+   point e <<< he ->
+   le \in all_edges open (e :: future_events) ->
+   he \in all_edges open (e :: future_events) ->
+   valid_edge le (point e) ->
+   valid_edge he (point e) ->
+   pairwise (@edge_below _)
+         [seq high x | x <- (opening_cells (point e) (outgoing e) le he)].
+Proof.
+move=> pal puh lein hein vle vhe.
+apply: opening_cells_pairwise'=> //.
+have sub : {subset [:: le, he & outgoing e] <=
+               all_edges open (e :: future_events)}.
+  move=> g1; rewrite !inE=> /orP[/eqP -> | /orP[/eqP -> | gin]] //.
+  by rewrite mem_cat events_to_edges_cons !mem_cat gin !orbT.
+by move=> g1 g2 /sub g1in /sub g2in; apply: noc.
+Qed.
+
+(* end of temporary moving area. *)
+Lemma invariant1_default_case :
+  let '(fc, cc, lcc, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+    let '(nos, lno) :=
+      opening_cells_aux (point e)
+       (sort (@edge_below _) (outgoing e)) le he in
+  inv1_seq ((fc ++ nos) ++ lno :: lc).
+Proof.
+case oe : (open_cells_decomposition open (point e)) =>
+ [[[[[fc cc] lcc] lc] le] he].
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe ncont] :=
+    decomposition_connect_properties rfo sval adj cbtom bet_e oe.
+case oca_eq:(opening_cells_aux _ _ _ _) => [nos nlsto].
+rewrite /invariant1 /state_open_seq /=.
+have dec_not_end :=
+    decomposition_not_end rfo sval adj cbtom bet_e oe.
+have close_fc : close_alive_edges fc future_events.
+  suff/head_not_end : close_alive_edges fc (e :: future_events).
+    by apply=> c0 cin; apply: dec_not_end; rewrite cin.
+  by apply/allP=> c0 cin; apply: (allP clae); rewrite ocd; subset_tac.
+have close_lc : close_alive_edges lc future_events.
+  suff/head_not_end : close_alive_edges lc (e :: future_events).
+    by apply=> c0 cin; apply: dec_not_end; rewrite cin orbT.
+  by apply/allP=> c0 cin; apply: (allP clae); rewrite ocd; subset_tac.
+have endle : end_edge_ext bottom top le future_events.
+  suff  : end_edge_ext bottom top le (e :: future_events).
+    rewrite /end_edge_ext; move=> /orP[-> // | ] /= /orP[ | ->]; last first.
+      by rewrite orbT.
+    by move: pal=> /[swap] /eqP <-; rewrite right_pt_below.
+  have := (proj1 (andP (allP clae (head lcc cc) _))); rewrite leq; apply.
+  by rewrite ocd; subset_tac.
+have endhe : end_edge_ext bottom top he future_events.
+  suff  : end_edge_ext bottom top he (e :: future_events).
+    rewrite /end_edge_ext; move=> /orP[-> // | ] /= /orP[ | ->]; last first.
+      by rewrite orbT.
+    move: puh=> /[swap] /eqP <-; rewrite strict_nonAunder; last first.
+      by apply: valid_edge_right.
+    by rewrite right_on_edge.
+  have := (proj2 (andP (allP clae lcc _))); rewrite ?heq; apply.
+  by rewrite ocd; subset_tac.
+move: cle => /= /andP[] cloe _.
+have clan := opening_cells_close vle vhe oute endle endhe cloe.
+have main := (insert_opening_closeness close_fc clan close_lc).
+split.
+  by move: main; rewrite /opening_cells oca_eq -cats1 -!catA.
+have subfc : {subset fc <= open} by rewrite ocd; subset_tac.
+have sublc : {subset lc <= open} by rewrite ocd; subset_tac.
+(* TODO : redo this as it is overkill for what follows. *)
+have svaln :
+  forall q, inside_box q -> lexePt (point e) q ->
+   {in future_events, forall e', lexePt q (point e')} ->
+   seq_valid ((fc ++ nos) ++ nlsto :: lc) q.
+  move=> q inbox_q elexq qlexfut.
+  apply/allP=> x; rewrite !(mem_cat, inE) -orbA => /orP[xf | ].
+    have /andP [vlx vhx] := allP sval x (subfc _ xf).
+    have := (allP main x); rewrite mem_cat xf => /(_ isT) /andP claex.
+    by rewrite (valid_between_events elexq qlexfut vlx inbox_q)
+     ?(valid_between_events elexq qlexfut vhx inbox_q); case: claex.
+  rewrite orbA=> /orP[ | xl]; last first.
+    have /andP [vlx vhx] := allP sval x (sublc _ xl).
+    move: (elexq);rewrite lexePt_eqVlt => /orP[/eqP <- | elexp'].
+      by rewrite vlx vhx.
+    have := (allP main x).
+    rewrite 2!mem_cat xl !orbT => /(_ isT) /andP claex.
+    by rewrite (valid_between_events elexq qlexfut vlx inbox_q)
+    ?(valid_between_events elexq qlexfut vhx inbox_q); case: claex.
+  move=> xin; have xin' : x \in opening_cells (point e) (outgoing e) le he.
+    by rewrite /opening_cells oca_eq mem_rcons inE orbC.
+  have [vlx vhx] := andP (allP (opening_valid oute vle vhe) _ xin').
+  have [eelx eehx] := andP (allP clan _ xin').
+  by rewrite (valid_between_events elexq qlexfut vlx inbox_q)
+    ?(valid_between_events elexq qlexfut vhx inbox_q).
+split.
+  case futq : future_events => [ | ev2 fut']; first by left.
+  right; rewrite /=.
+  apply: svaln.
+      by apply: (@allP pt _ _ inbox_es); rewrite map_f // futq inE eqxx.
+    apply: lexPtW.
+    by move: sort_evs; rewrite futq /= => /andP[].
+  move=> e'; rewrite futq inE => /orP[/eqP -> | ].
+    by apply: lexePt_refl.
+  move=> e'in; apply/lexPtW.
+  move: sort_evs; rewrite futq /= => /andP[] _.
+  rewrite path_sortedE; last by move=> x y z; apply: lexPt_trans.
+  by move=> /andP[] /allP /(_ e' e'in).
+have [adjnew lownew] := adjacent_opening_aux vle vhe oute' oca_eq.
+have := opening_cells_aux_high_last vle vhe oute'; rewrite oca_eq heq /=.
+move=> hnlsto.
+split.
+  suff : adjacent_cells ((fc ++ nos) ++ nlsto :: lc) by [].
+  rewrite -catA.
+  have oldnnil : rcons cc lcc != nil.
+    by apply/eqP/rcons_neq0.
+  rewrite -cat_rcons; apply: (replacing_seq_adjacent oldnnil).
+  - by apply/eqP/rcons_neq0.
+  - by rewrite lownew; move: leq; case: (cc) => [ | ? ?].
+  - by rewrite !last_rcons.
+  - by move: adj; rewrite ocd cat_rcons.
+  by apply: adjnew.
+have nn0 : rcons nos nlsto != nil by apply/eqP/rcons_neq0.
+have on0 : rcons cc lcc != nil by apply/eqP/rcons_neq0.
+move: cbtom; rewrite ocd -cat_rcons => cbtom'.
+have hds: low (head dummy_cell (rcons cc lcc)) =
+  low (head dummy_cell (rcons nos nlsto)).
+  by rewrite head_rcons -leq -lownew head_rcons.
+have tls : high (last dummy_cell (rcons cc lcc)) =
+          high (last dummy_cell (rcons nos nlsto)).
+  by rewrite !last_rcons.
+split.
+  move: cbtom';
+  rewrite (replacing_seq_cells_bottom_top _ _ _ _ on0 nn0) //.
+  by rewrite -catA cat_rcons.
+rewrite -catA -cat_rcons.
+have lein' : le \in all_edges open (e :: future_events).
+  by rewrite /all_edges; subset_tac.
+have hein' : he \in all_edges open (e :: future_events).
+  by rewrite /all_edges; subset_tac.
+have lebhe : le <| he.
+  by apply: (edge_below_from_point_above (noc _ _) vle vhe (underWC _)).
+have noc2 : {in [:: le, he & outgoing e] &, no_crossing R}.
+  by apply: (sub_in2 _ noc); rewrite /all_edges; subset_tac.
+have subso : {subset sort (@edge_below _) (outgoing e)
+                <= all_edges open (e :: future_events)}.
+  by move=> x; rewrite mem_sort; apply: subo.
+apply/allP=> x; rewrite 2!mem_cat orbCA => /orP[xin | xold]; last first.
+  by apply: (allP rfo); rewrite ocd; move: xold => /orP[] ?; subset_tac.
+have srt : path (@edge_below _) le (sort (@edge_below _) (outgoing e)).
+  by have := sorted_outgoing vle vhe pal puh oute noc2.
+have := (opening_cells_aux_right_form (underWC pal) puh vle vhe
+               lein' hein' lebhe oute' noc subso srt oca_eq).
+by move=> /allP /(_ x xin).
+Qed.
+
+#[clearbody]
+Let exi' : point e >>> lsthe ->
+  exists2 c, c \in lop & contains_point' (point e) c.
+Proof.
+rewrite lstheq; move=> pa.
+suff abf : {in fop, forall c, point e >>> high c}.
+have [wc wcin wcct] := exi; exists wc => //.
+  move: wcin; rewrite /open !(mem_cat, inE) => /orP[wf | /orP[/eqP wl | //]].
+    by move: wcct; rewrite /contains_point' (negbTE (abf _ wf)) andbF.
+  by move: wcct; rewrite /contains_point' wl (negbTE pa) andbF.
+have vfop1 : seq_valid (rcons fop lsto) (point e).
+  apply/allP=> x; rewrite mem_rcons=> xin; apply: (allP sval).
+  by move: x xin; rewrite /open; change {subset lsto::fop <= open}; subset_tac.
+have vfop : {in rcons fop lsto, forall c, valid_edge (high c) (point e)}.
+  move=> c cin.
+  have cin' : high c \in [seq high i | i <- open].
+    by apply: map_f; rewrite /open -cat_rcons; subset_tac.
+  by apply: (seq_valid_high sval cin').
+have rfop : s_right_form (rcons fop lsto).
+  by apply: all_sub rfo; rewrite /open -cat_rcons; subset_tac.
+have afop : adjacent_cells (rcons fop lsto).
+  by move: adj; rewrite /open -cat_rcons => /adjacent_catW [].
+have vh : valid_edge (low (head lsto fop)) (point e).
+  by move: sval; rewrite /open; case: (fop) => [ | ? ?] /= /andP[] /andP[].
+suff [] : point e >>> low (head lsto fop) /\
+       {in fop, forall c, point e >>> high c} by [].
+have := above_all_cells vfop1 afop rfop; rewrite last_rcons=> /(_ pa).
+have hq : head dummy_cell (rcons fop lsto) = head lsto fop.
+  by case: (fop) => [ | ? ?].
+rewrite hq => -[-> others]; split=> // x xin.
+by apply: others; rewrite mem_rcons inE xin orbT.
+Defined.
+
+Lemma inv1_seq_set_pts s1 s2 c1 lpts1 lpts2 :
+  inv1_seq (s1 ++ set_pts c1 lpts1 lpts2 :: s2) <->
+  inv1_seq (s1 ++ c1 :: s2).
+Proof.
+rewrite /inv1_seq.
+have -> : close_alive_edges (s1 ++ set_pts c1 lpts1 lpts2 :: s2)
+ future_events =
+  close_alive_edges (s1 ++ c1 :: s2) future_events.
+  by rewrite /close_alive_edges !all_cat /=.
+have -> : adjacent_cells (s1 ++ set_pts c1 lpts1 lpts2 :: s2) =
+  adjacent_cells (s1 ++ c1 :: s2).
+  elim/last_ind : s1 => [ | [ | c0 s1] c0' _]; case: s2 => [ | c2 s2] //=;
+  by rewrite /adjacent_cells ?cat_rcons ?cat_path //.
+have -> : cells_bottom_top (s1 ++ set_pts c1 lpts1 lpts2 :: s2) =
+  cells_bottom_top (s1 ++ c1 :: s2).
+  rewrite /cells_bottom_top /cells_low_e_top.
+  by case: s1 => [ | c0 s1]; elim/last_ind: s2 => [ | s2 c2 _];
+   rewrite /= -?cat_rcons ?(last_rcons, cats0, last_cat).
+have -> : s_right_form (s1 ++ set_pts c1 lpts1 lpts2 :: s2) =
+  s_right_form (s1 ++ c1 :: s2).
+  by rewrite /s_right_form !all_cat /=.
+split; move=> [-> [B [-> [-> -> ]]]]; split=> //; split=> //.
+  case: B; first by left.
+  by rewrite /seq_valid !all_cat /=; right.
+case: B; first by left.
+by rewrite /seq_valid !all_cat /=; right.
+Qed.
+
+Lemma inv1_seq_set_left_pts s1 s2 c1 lpts :
+  inv1_seq (s1 ++ set_left_pts c1 lpts :: s2) <->
+  inv1_seq (s1 ++ c1 :: s2).
+Proof. exact (inv1_seq_set_pts s1 s2 c1 lpts (right_pts c1)). Qed.
+
+#[clearbody]
+Let vlo : valid_edge (low lsto) (point e).
+Proof. by apply: (proj1 (andP (allP sval lsto lstoin))). Defined.
+
+#[clearbody]
+Let vho : valid_edge (high lsto) (point e).
+Proof. by apply: (proj2 (andP (allP sval lsto lstoin))). Defined.
+
+Lemma last_step_situation fc' cc lcc lc le he:
+  open_cells_decomposition (lsto :: lop) (point e) =
+    (fc', cc, lcc, lc, le, he) ->
+  p_x (point e) = lstx ->
+  ~~ (point e <<< lsthe) ->
+  point e <<= lsthe ->
+  fc' = [::] /\ le = low lsto /\ exists cc', cc = lsto :: cc'.
+Proof.
+move=> oe pxhere eabove ebelow.
+have lsto_ctn : contains_point' (point e) lsto.
+  by rewrite /contains_point' -lstheq ebelow abovelstle.
+have exi2 : exists2 c, c \in (lsto :: lop) & contains_point' (point e) c.
+  by exists lsto; rewrite // inE eqxx.
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]]
+  := decomposition_main_properties oe exi2.
+have fc'0 : fc' = [::].
+  case fc'q : fc' => [// | fc'i fc2].
+  move: ocd; rewrite fc'q /= => - [] lstoisfc'i _.
+  move: (all_nct lsto).
+  by rewrite (contains_point'W lsto_ctn) fc'q lstoisfc'i inE eqxx =>/(_ isT).
+split; first by [].
+case ccq: cc => [ | cc0 cc'].
+  move: ocd; rewrite fc'0 ccq /= => -[] lstoq.
+  move: heq; rewrite -lstoq.
+  have := open_cells_decomposition_cat adj rfo sval exi2 (abovelstle pxhere).
+  rewrite oe => oe'.
+  have [ocd' [lcc_ctn' [all_ct' [all_nct' [flcnct' [heq' [leq' [_ _]]]]]]]]
+    := decomposition_main_properties oe exi2.
+  have [pal puh vle vhe]:=
+    decomposition_connect_properties rfo sval adj cbtom bet_e oe'.
+  by move: puh; rewrite heq' -lstoq -lstheq (negbTE eabove).
+have [ fopq | [fop' [lfop fopq]]] :
+  fop = nil \/ exists fop' lfop, fop = rcons fop' lfop.
+    elim/last_ind: (fop) => [| fop' lfop]; first by left.
+    by right; exists fop', lfop.
+  move: ocd; rewrite -cat_rcons fc'0 /= => lstohead.
+  split.
+    suff : lsto = head lcc cc by move=> ->.
+    by rewrite -[LHS]/(head lsto (lsto :: lop)) lstohead; case: (cc).
+  by exists cc'; move: lstohead; rewrite ccq /= => -[] ->.
+move: adj; rewrite /open ocd fopq fc'0 cat_rcons /=.
+move=> /adjacent_catW[] _ it.
+move: (ocd); rewrite fc'0 /=; move: it=> /[swap] <- /andP[] /eqP <- _.
+split.
+  apply/esym; rewrite leq.
+  move: adj; rewrite /open ocd fc'0 /= fopq cat_rcons=>/adjacent_catW[] _.
+  by rewrite ccq /= => /andP[] /eqP ->.
+by exists cc'; move: ocd; rewrite fc'0 ccq /= => -[] ->.
+Qed.
+
+#[clearbody]
+Let loin : low lsto \in all_edges open (e :: future_events).
+Proof. by rewrite 2!mem_cat map_f. Defined.
+
+#[clearbody]
+Let hoin : high lsto \in all_edges open (e :: future_events).
+Proof. by rewrite 2!mem_cat map_f // orbT. Defined.
+
+Arguments pt_eqb : simpl never.
+
+Lemma step_keeps_invariant1 :
+  invariant1 (step (Bscan fop lsto lop cls lstc lsthe lstx) e).
+Proof.
+case step_eq : (step _ _) => [fop' lsto' lop' cls' lstc' lsthe' lstx'].
+rewrite /state_open_seq /=; move: step_eq.
+rewrite /step/generic_trajectories.step -/open.
+(* have val_bet := valid_between_events elexp plexfut _ inbox_p. *)
+case: ifP=> [pxaway | /negbFE/eqP/[dup] pxhere /abovelstle palstol].
+  move: invariant1_default_case.
+  rewrite -/(open_cells_decomposition _ _).
+  case oe: (open_cells_decomposition _ _) => [[[[[fc cc ] lcc] lc] le] he].
+  rewrite /generic_trajectories.simple_step.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno] def_case.
+  rewrite /inv1_seq /= in def_case.
+  move=> [] <- <- <- _ _ _ _.
+  by apply: def_case.
+have infop : {subset fop <= open} by rewrite /open; subset_tac.
+have sval1 : seq_valid fop (point e).
+  by apply/allP=> x xin; apply: (allP sval); apply: infop.
+have rfo1 : s_right_form fop.
+  by apply/allP=> x xin; apply: (allP rfo); apply: infop.
+have adj1 : adjacent_cells fop.
+  by move: adj; rewrite /open => /adjacent_catW[].
+have allnct1 : {in fop, forall c, ~contains_point (point e) c}.
+  case fop_eq : fop => [// | c1 fop1].
+  have := above_all_cells sval1 adj1 rfo1.
+  have hfopq : high (last dummy_cell fop) = low lsto.
+    move: adj.
+    by rewrite /open fop_eq /= cat_path => /andP[] _ /= /andP[] /eqP.
+  move: palstol; rewrite hfopq=> -> /(_ isT) [] _ M.
+  by rewrite -fop_eq=> x xin; rewrite contains_pointE (negbTE (M x xin)) andbF.
+have inlop : {subset lop <= open} by rewrite /open; subset_tac.
+have lopclae : close_alive_edges lop (e :: future_events).
+  by apply/allP=> x xin; apply: (allP clae x); apply inlop.
+have fop_note x : x \in fop ->
+  ~ event_close_edge (low x) e /\ ~ event_close_edge (high x) e.
+  move=> xin; apply: contrapositive_close_imp_cont.
+  - by apply: (allP rfo); rewrite /open; subset_tac.
+  - by apply/andP; apply: (allP sval); rewrite /open; subset_tac.
+  by apply: allnct1.
+have fopclae : close_alive_edges fop (e :: future_events).
+  by apply/allP=> x xin; apply: (allP clae); rewrite /open; subset_tac.
+move: (cle) => /= /andP[] cloe _.
+case: ifP=> [eabove | ebelow].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe: (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  rewrite /generic_trajectories.simple_step.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  have eabove' : point e >>> low (head dummy_cell lop).
+    have llopq : low (head dummy_cell lop) = lsthe.
+      apply: esym; rewrite lstheq.
+      move: (exi' eabove)=> [w + _].
+      move: adj=> /adjacent_catW[] _.
+      by case: (lop) => [ // | ? ?] /andP[] /eqP.
+    by rewrite llopq.
+  have oe' :
+    open_cells_decomposition open (point e) =
+     (rcons fop lsto ++ fc', cc, lcc, lc, le, he).
+    move: adj rfo sval; rewrite /open -cat_rcons=> adj' rfo' sval'.
+    move: (open_cells_decomposition_cat adj' rfo' sval' (exi' eabove)).
+    by rewrite oe; apply.
+  move=> [] <- <- <- _ _ _ _.
+  have := invariant1_default_case.
+  by rewrite oe' oca_eq  /= cat_rcons.
+have /andP [vllsto vhlsto] : valid_edge (low lsto) (point e) &&
+                       valid_edge (high lsto) (point e).
+  by move: sval=> /allP/(_ lsto); rewrite /open; apply; subset_tac.
+case: ifP => [ebelow_st {ebelow} | eonlsthe].
+  rewrite -/(update_open_cell lsto e).
+  case uoceq : (update_open_cell lsto e) => [ nos lno] <-.
+  rewrite /invariant1 /= /state_open_seq /= -catA -cat_rcons.
+  move: uoceq; rewrite /update_open_cell/generic_trajectories.update_open_cell.
+  case ogq : (outgoing e) => [ | fog ogs] /=.
+    move=> -[] <- <- /=; rewrite inv1_seq_set_left_pts.
+    have := invariant1_default_case.
+    rewrite open_cells_decomposition_single=> //; last by rewrite -lstheq.
+    rewrite ogq /=.
+    do 2 rewrite -/(vertical_intersection_point _ _).
+    rewrite pvertE // pvertE //=; rewrite cats0.
+    rewrite -[pt_eqb _ _ (point e) _]/((point e) == _:> pt).
+    rewrite -[pt_eqb _ _ _ (point e)]/(_ == (point e):> pt).
+    have /negbTE -> :
+         (Bpt (p_x (point e)) (pvert_y (point e) (high lsto)))
+           != point e :> pt.
+      rewrite pt_eqE /= eqxx /=.
+      move: ebelow_st; rewrite -/(_ <<< _).
+      rewrite strict_under_pvert_y lstheq // lt_neqAle eq_sym.
+      by move=> /andP[].
+    have /negbTE -> :
+     point e != Bpt (p_x (point e)) (pvert_y (point e) (low lsto)) :> pt.
+      rewrite pt_eqE /= eqxx /=.
+      by move: palstol; rewrite under_pvert_y // le_eqVlt negb_or=> /andP[].
+    set w := [:: _ ; _; _].
+    by rewrite (inv1_seq_set_pts fop lop lsto w nil).
+  have := invariant1_default_case.
+  rewrite open_cells_decomposition_single=> //; last by rewrite -lstheq.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  rewrite ogq; case oca_eq: opening_cells_aux => [[| no0 nos'] lno'].
+    have ognn : (outgoing e) != [::] by rewrite ogq.
+    have := opening_cells_aux_absurd_case vlo vho ognn oute.
+    by rewrite ogq oca_eq.
+  by move => + [] <- <- /=; rewrite inv1_seq_set_left_pts cat_rcons -!catA /=.
+have lsto_ctn : contains_point'(point e) lsto.
+  rewrite /contains_point'.
+  by rewrite -lstheq /point_under_edge (negbFE ebelow) abovelstle.
+have exi2 : exists2 c, c \in (lsto :: lop) & contains_point' (point e) c.
+  by exists lsto; rewrite // inE eqxx.
+case oe : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+have := open_cells_decomposition_cat adj rfo sval exi2 palstol.
+rewrite oe => oe'.
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+  decomposition_main_properties oe' exi.
+have [ocd' _] := decomposition_main_properties oe exi2.
+have [fc'0 [lelsto [cc' ccq]]] : fc' = [::] /\ le = low lsto /\
+          exists cc', cc = lsto :: cc'.
+  by have := last_step_situation oe pxhere (negbT eonlsthe) (negbFE ebelow).
+rewrite /generic_trajectories.update_open_cell_top.
+rewrite -/(open_cells_decomposition _ _).
+rewrite oe.
+case o_eq : (outgoing e) => [ | g l]; rewrite -?o_eq; last first.
+  rewrite -!/(open_cells_decomposition _ _).
+  have := invariant1_default_case; rewrite oe'.
+  rewrite -lelsto.
+  rewrite -!/(opening_cells_aux _ _ _ _).
+  case: (opening_cells_aux _ _ _ _) => [[ | fno nos] lno].
+    move=> + <-; rewrite /invariant1 /state_open_seq /=.
+    by rewrite !cats0 -!catA.
+  move=> + <-; rewrite /invariant1 /state_open_seq /=.
+  rewrite -!catA /= => it.
+  by rewrite (catA fop) inv1_seq_set_left_pts -catA.
+move=> [] <- <- <- _ _ _ _ /=.
+have subf : {subset (fop ++ fc') <= open} by rewrite /open ocd; subset_tac.
+have adjf : adjacent_cells (fop ++ fc').
+  by move: adj; rewrite /open ocd=> /adjacent_catW[].
+have claef : close_alive_edges (fop ++ fc') (e :: future_events).
+  by apply/allP=> x xin; apply: (allP clae); apply: subf.
+have rfof : s_right_form (fop ++ fc').
+  by apply/allP=> x xin; apply: (allP rfo); apply: subf.
+have svalf : seq_valid (fop ++ fc') (point e).
+  by apply/allP=> x xin; apply: (allP sval); apply: subf.
+have subl : {subset (lsto :: lop) <= open}.
+  by rewrite /open; subset_tac.
+have adjl : adjacent_cells (lsto :: lop).
+  by move: adj=> /adjacent_catW[].
+have rfol : s_right_form (lsto :: lop).
+  by apply/allP=> x xin; apply: (allP rfo); apply: subl.
+have svall : seq_valid (lsto :: lop) (point e).
+  by apply/allP=> x xin; apply: (allP sval); apply: subl.
+have cbtom' : cells.cells_bottom_top (low lsto) top (lsto :: lop).
+  move: cbtom; rewrite /open /cells.cells_bottom_top /cells_low_e_top eqxx //=.
+  by move=> /andP[] _; rewrite last_cat /=.
+have [pal puh vl vh not_ct] :=
+  decomposition_connect_properties rfo sval adj cbtom bet_e oe'.
+have claef' : close_alive_edges (fop ++ fc') future_events.
+  elim/last_ind: {-1}(fop ++ fc') (erefl (fop ++ fc')) => [// | fc2 c2 _] f_eq.
+  have hc2q : high c2 = low (head lcc cc).
+    move: adj; rewrite /open ocd catA f_eq -cats1 -!catA=> /adjacent_catW[] _.
+    by rewrite ccq /= => /andP[] /eqP.
+  have palst : point e >>> high (last dummy_cell (fop ++ fc')).
+    by rewrite f_eq last_rcons hc2q -leq.
+  have [above_l above_h] := above_all_cells svalf adjf rfof palst.
+  have {}allabove_l : {in fop ++ fc', forall c, point e >>> low c}.
+    move=> c /mem_seq_split [s1 [s2 s_q]].
+      elim/last_ind: {-1} (s1) (erefl s1) => [ | s1' c1 _] s1q.
+        by move: above_l; rewrite s_q s1q /=.
+      have : point e >>> high c1.
+        by rewrite above_h // s_q s1q cat_rcons; subset_tac.
+      have /eqP -> // : high c1 == low c.
+      move: adjf; rewrite s_q s1q -cats1 -catA /= => /adjacent_catW[] _.
+      by rewrite /= => /andP[].
+  have f_not_end : forall c, c \in fop ++ fc' ->
+  ~ event_close_edge (low c) e /\ ~ event_close_edge (high c) e.
+    move=> c cin; apply: contrapositive_close_imp_cont.
+    - by apply: (allP rfof).
+    - by apply/andP; apply: (allP svalf).
+    by apply/negP; rewrite contains_pointE (negbTE (above_h _ cin)) andbF.
+  apply/allP=> x; rewrite -f_eq => xin.
+  by apply: (allP (head_not_end claef f_not_end)).
+have clael : close_alive_edges lc (e :: future_events).
+  by apply/allP=> x xin; apply: (allP clae); rewrite /open ocd; subset_tac.
+have clael' : close_alive_edges lc future_events.
+  case lc_eq : (lc) => [ // | c2 lc2]; rewrite -lc_eq.
+  have [puhlcc adj2] : point e <<< low (head dummy_cell lc) /\
+                        adjacent_cells lc.
+    move: adj; rewrite /open ocd lc_eq.
+    move=> /adjacent_catW[] _ /adjacent_catW[] _ /=.
+    by move=> /andP[] /eqP <- ->; rewrite -heq.
+  have sub2 : {subset lc <= open} by rewrite /open ocd; subset_tac.
+  have sval2 : seq_valid lc (point e).
+    by apply/allP=> x xin; apply: (allP sval); apply: sub2.
+  have rfo2 : s_right_form lc.
+    by apply/allP=> x xin; apply: (allP rfo); apply: sub2.
+  have below_h : {in lc, forall c, point e <<< high c}.
+    exact: (below_all_cells sval2 adj2 rfo2 puhlcc).
+  have below_l : {in lc, forall c, point e <<< low c}.
+    move=> c /mem_seq_split [s1 [s2 s_q]].
+    elim/last_ind: {2}(s1) (erefl s1) => [ | s1' c1 _] s1_q.
+      by move: puhlcc; rewrite s_q s1_q /=.
+    move: adj2; rewrite s_q s1_q -cats1 -catA=> /adjacent_catW [] _ /=.
+    move=> /andP[]/eqP <- _; apply: below_h.
+    rewrite s_q s1_q cat_rcons; subset_tac.
+  have l_not_end : forall c, c \in lc ->
+  ~ event_close_edge (low c) e /\ ~ event_close_edge (high c) e.
+    move=> c cin; apply: contrapositive_close_imp_cont.
+    - by apply: (allP rfo2).
+    - by apply/andP; apply: (allP sval2).
+    by apply/negP; rewrite contains_pointE negb_and negbK (below_l _ cin).
+  apply/allP=> x xin.
+  by apply: (allP (head_not_end clael l_not_end)).
+rewrite cats0 /invariant1 /state_open_seq /=; set open' := (X in inv1_seq X).
+have clae_part : close_alive_edges open' future_events.
+  rewrite /close_alive_edges all_cat [all _ (fop ++ fc')]claef' /=.
+  rewrite [all _ lc]clael' andbT.
+  have le_end : end_edge_ext bottom top le future_events.
+    elim/last_ind: {-1} (fop ++ fc') (erefl (fop ++ fc')) => [ | fs c1 _] f_eq.
+      move: f_eq; case fop_eq: (fop) => [ | //].
+      move: cbtom; rewrite /open fop_eq /= => /andP[] /andP[] _ /= /eqP + _.
+      by rewrite /end_edge_ext lelsto !inE => -> _; rewrite eqxx.
+    have <- : high c1 = le.
+      rewrite fc'0 cats0 in f_eq.
+      move: adj; rewrite /open f_eq -cats1 -catA=>/adjacent_catW[] _ /=.
+      by rewrite lelsto; move=> /andP[] /eqP.
+    apply: (proj2 (andP (allP claef' c1 _))).
+    by rewrite f_eq mem_rcons inE eqxx.
+  have he_end : end_edge_ext bottom top he future_events.
+    case lc_eq : lc => [ | c1 lc'].
+      have hetop : he = top.
+        move: cbtom=> /andP[] /andP[] _ _.
+        by rewrite /open ocd lc_eq !last_cat -heq /= => /eqP.
+      by rewrite /end_edge_ext hetop !inE eqxx ?orbT.
+    have hlccq : high lcc = low c1.
+      move: adj; rewrite /open ocd lc_eq.
+      by move=> /adjacent_catW[] _ /adjacent_catW[] _ /andP[] /eqP.
+    have c1in : c1 \in lc by rewrite lc_eq inE eqxx.
+    by have := (allP clael' _ c1in) => /andP[] + _; rewrite -hlccq -heq.
+  by rewrite -lelsto le_end he_end.
+split=> //.
+have vhe : valid_edge he (point e).
+ by have []:= decomposition_connect_properties rfo sval adj cbtom bet_e oe'.
+split.
+  case futq : future_events => [ | e2 fut]; first by left.
+  have elexe2 : lexePt (point e) (point e2).
+    by apply/lexPtW; move: sort_evs; rewrite futq /= => /andP[].
+  rewrite /seq_valid all_cat /= all_cat andbCA.
+  have e2lexfut : {in future_events, forall e, lexePtEv e2 e}.
+    move=> e'; rewrite futq inE=> /orP[/eqP ->|]; first by apply: lexePt_refl.
+    move=> e'in; apply/lexPtW; move: sort_evs; rewrite futq=> /= /andP[] _.
+    rewrite path_sortedE; last by move=> x y z; apply: lexPt_trans.
+    by move=> /andP[] /allP /(_ e') + _; apply.
+  have inbox_e2 : inside_box (point e2).
+    by apply: (@allP pt _ _ inbox_es); rewrite futq /= inE eqxx.
+  right.
+  apply/andP; split; last first.
+    rewrite -!all_cat fc'0 cats0; apply/allP=> x xin.
+    have /andP[vlx vhx] :
+    valid_edge (low x) (point e) && valid_edge (high x) (point e).
+      apply: (allP sval); rewrite /open ocd.
+      by move: xin; rewrite mem_cat=> /orP[] ?; subset_tac.
+    have /andP[eelx eehx] :
+     end_edge_ext bottom top (low x) future_events &&
+     end_edge_ext bottom top (high x) future_events.
+      apply: (allP clae_part).
+      by rewrite /open'; move: xin; rewrite mem_cat=>/orP[] ?; subset_tac.
+    by rewrite !(valid_between_events elexe2 e2lexfut _ inbox_e2).
+  have eelo : end_edge_ext bottom top (low lsto) future_events.
+    have : end_edge_ext bottom top (low lsto) (e :: future_events).
+      by apply: (proj1 (andP (allP clae lsto _))).
+    rewrite /end_edge_ext /= => /orP[-> // | /orP[abs | ->]]; last first.
+      by rewrite !orbT.
+    by move: palstol; rewrite -(eqP abs) right_pt_below.
+  have eehe : end_edge_ext bottom top he future_events.
+    have : end_edge_ext bottom top (high lcc) (e :: future_events).
+      apply: (proj2 (andP (allP clae lcc _))).
+      by rewrite /open ocd; subset_tac.
+    rewrite /end_edge_ext heq /= => /orP[-> // | /orP[abs | ->]]; last first.
+      by rewrite orbT.
+    by move: puh; rewrite heq -(eqP abs) -[_ <<< _]negbK right_pt_above.
+  by rewrite !(valid_between_events elexe2 e2lexfut _ inbox_e2).
+split.
+  case feq : fop => [ | c0 f].
+    rewrite /open' feq fc'0 /=.
+    move: adj; rewrite /open ocd => /adjacent_catW[] _ /adjacent_catW[] _ /=.
+    by case: (lc)=> [ // | c2 lc'] /=; rewrite heq.
+  rewrite /open' -adjacent_cut /=; last by rewrite feq.
+  apply/andP; split.
+    apply/andP; split; last by move: adj; rewrite /open ocd=> /adjacent_catW.
+    rewrite fc'0 cats0; move: adj; rewrite /open feq /= cat_path /=.
+    by move=> /andP[] _ /andP[].
+  move: adj; rewrite /open ocd=> /adjacent_catW[] _ /adjacent_catW[] _ /=.
+  by case: (lc) => [// | c2 l'] /=; rewrite heq.
+have on0 : rcons cc lcc != nil by apply/eqP/rcons_neq0.
+rewrite /open'.
+set nc := Bcell _ _ _ _.
+have nn0 : [:: nc] != nil by [].
+split.
+  rewrite -(replacing_seq_cells_bottom_top _ _ _ _ on0 nn0).
+  - by rewrite cat_rcons -ocd.
+  - rewrite /nc /= head_rcons.
+    by rewrite -leq.
+  by rewrite /nc/= last_rcons.
+rewrite /s_right_form all_cat /=; apply/andP; split.
+  by apply/allP=> x xin; apply: (allP rfo); rewrite /open ocd; subset_tac.
+apply/andP; split; last first.
+  by apply/allP=> x xin; apply: (allP rfo); rewrite /open ocd; subset_tac.
+have noclstohe : below_alt he (low lsto).
+  by apply: noc; rewrite /all_edges; subset_tac.
+have := edge_below_from_point_under noclstohe vhe vlo (underW puh) palstol.
+by [].
+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.
+
+Lemma new_edges_above_first_old fc cc lcc lc le:
+  open = fc ++ cc ++ lcc :: lc ->
+  all (fun x => valid_edge x(point e))
+        [seq high x | x <- fc ++ cc ++ lcc :: lc] ->
+  pairwise (@edge_below _) [seq high x | x <- fc ++ cc ++ lcc :: lc] ->
+  all ((@edge_below _)^~ le) [seq high x | x <- fc] ->
+  point e >>> le ->
+  point e <<< high lcc ->
+  valid_edge le (point e) ->
+  allrel (@edge_below _)
+    [seq high c | c <- fc]
+    [seq high c | c <-
+      opening_cells (point e) (outgoing e) le (high lcc)].
+Proof.
+move=> ocd.
+rewrite !map_cat !all_cat => /andP[] vfc /andP[] _ /= /andP[] vhe _.
+move=> + fcbl pal puh vle.
+rewrite !pairwise_cat=> /andP[] fcbcc /andP[] _ /andP[] /=.
+rewrite allrel_consr=> /andP[] pw' _ /andP[] pw _.
+rewrite /opening_cells.
+case oca_eq : opening_cells_aux => [s c].
+have := opening_cells_aux_high vle vhe oute'; rewrite oca_eq /= => highsq.
+have := opening_cells_aux_high_last vle vhe oute'; rewrite oca_eq /= => highcq.
+rewrite -cats1 map_cat allrel_catr allrel_consr /=.
+have -> : all ((@edge_below _)^~ (high c)) [seq high x | x <- fc].
+  rewrite highcq; move: fcbcc; rewrite allrel_catr allrel_consr.
+  by move=> /andP[] _ /andP[].
+rewrite allrel0r.
+have -> //: allrel (@edge_below _) [seq high x | x <- fc][seq high y | y <- s].
+rewrite highsq.
+apply/allrelP=> x y xin yin.
+have vx : valid_edge x (point e) by apply: (allP vfc).
+have vy : valid_edge y (point e).
+  by apply: valid_edge_extremities; rewrite oute'.
+have puy : point e <<= y.
+  by rewrite -(eqP (oute' yin)); apply: left_pt_below.
+have xble : x <| le by apply: (allP fcbl).
+have pax : point e >>> x.
+  apply/negP=> pux; case/negP: pal.
+  by apply: (order_edges_viz_point' vx vle xble pux).
+have nocyx : below_alt y x.
+  apply: noc; rewrite ocd /all_edges/events_to_edges; last first.
+    by rewrite !(cell_edges_cat, mem_cat) ?xin ?orbT //.
+  rewrite /= mem_cat [X in (_ || X)]mem_cat.
+  by rewrite mem_sort in yin; rewrite yin !orbT.
+by have := edge_below_from_point_under nocyx vy vx puy pax.
+Qed.
+
+Lemma new_edges_below_last_old fc cc lcc lc le:
+  open = fc ++ cc ++ lcc :: lc ->
+  all (fun x => valid_edge x(point e))
+        [seq high x | x <- fc ++ cc ++ lcc :: lc] ->
+  pairwise (@edge_below _) [seq high x | x <- fc ++ cc ++ lcc :: lc] ->
+  point e >>= le ->
+  point e <<< high lcc ->
+  valid_edge le (point e) ->
+  allrel (@edge_below _)
+    [seq high c | c <-
+      opening_cells (point e) (outgoing e) le (high lcc)]
+        [seq high c | c <- lc].
+Proof.
+move=> ocd.
+rewrite !map_cat !all_cat => /andP[] _ /andP[] _ /= /andP[] vhe vlc.
+move=> + pal puh vle.
+rewrite !pairwise_cat=> /andP[] _ /andP[] _ /andP[] _ /andP[] _.
+rewrite /= => /andP[] heblc _.
+rewrite /opening_cells.
+case oca_eq : opening_cells_aux => [s c].
+have := opening_cells_aux_high vle vhe oute'; rewrite oca_eq /= => highsq.
+have := opening_cells_aux_high_last vle vhe oute'; rewrite oca_eq /= => highcq.
+rewrite -cats1 allrel_mapl allrel_catl /= allrel_consl allrel0l ?andbT.
+rewrite highcq heblc andbT.
+rewrite -allrel_mapl highsq; apply/allrelP=> x y /[dup] xin xin' yin.
+rewrite mem_sort in xin'.
+have vx: valid_edge x (point e) by apply valid_edge_extremities; rewrite oute'.
+have vy: valid_edge y (point e) by apply: (allP vlc).
+have highlccley : high lcc <| y by apply: (allP heblc).
+have puy : point e <<< y.
+  by have := order_edges_strict_viz_point' vhe vy highlccley puh.
+have pax : point e >>= x.
+  rewrite -(eqP (oute' xin)); apply left_pt_above.
+have nocxy : below_alt x y.
+  apply: noc; rewrite /all_edges/events_to_edges/= ocd !mem_cat ?xin' ?orbT //.
+  by rewrite !map_cat /= !mem_cat !inE yin !orbT.
+by have := edge_below_from_point_above nocxy vx vy pax puy.
+Qed.
+
+Lemma step_keeps_pw_default :
+  let '(fc, cc, lcc, lc, le, he) :=
+  open_cells_decomposition open (point e) in
+  let '(nos, lno) :=
+    opening_cells_aux (point e)
+        (sort (@edge_below _) (outgoing e)) le he in
+    pairwise (@edge_below _)
+       (bottom :: [seq high x | x <- fc ++ nos ++ lno :: lc]).
+Proof.
+case oe: (open_cells_decomposition open (point e)) =>
+  [[[[[fc cc] lcc] lc] le] he].
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]]
+  := decomposition_main_properties oe exi.
+have [pal puh vle vhe allnct] :=
+  decomposition_connect_properties rfo sval adj cbtom bet_e oe.
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+have oc_eq : opening_cells (point e) (outgoing e) le he = rcons nos lno.
+  by rewrite /opening_cells oca_eq.
+rewrite /=; apply/andP; split.
+  rewrite map_cat all_cat; apply/andP; split.
+    by move: pwo; rewrite ocd /= map_cat all_cat=> /andP[] /andP[] ->.
+  rewrite -cat_rcons map_cat all_cat; apply/andP; split; last first.
+    move: pwo; rewrite ocd /= !map_cat !all_cat /=.
+    by move=> /andP[] + _; do 3 move=> /andP[] _.
+  rewrite map_rcons all_rcons.
+  have := opening_cells_aux_high_last vle vhe oute'; rewrite oca_eq /= => ->.
+  have -> /= : bottom <| he.
+    have lcco : lcc \in open by rewrite ocd !mem_cat inE eqxx !orbT.
+    rewrite heq.
+    move: pwo=> /= /andP[] /allP /(_ (high lcc)) + _; rewrite map_f //.
+    by apply.
+  have := opening_cells_aux_high vle vhe oute'; rewrite oca_eq /= => ->.
+  apply/allP=> g; rewrite mem_sort=> gin.
+  have lgq : left_pt g = point e by apply/eqP/oute.
+  have vlg : valid_edge bottom (left_pt g).
+    by rewrite lgq; apply: (inside_box_valid_bottom inbox_e).
+(* TODO : this should be made a top level lemma *)
+  have /no_crossingE : below_alt g bottom.
+    apply: noc.
+      by rewrite mem_cat /events_to_edges /= !mem_cat gin !orbT.
+    rewrite 2!mem_cat -orbA; apply/orP; left.
+    move: cbtom=> /andP[]; case: (open) => [ // | o1 op'] /= /eqP -> _.
+    by rewrite inE eqxx.
+  move=> /(_ vlg) [] _; apply.
+  by move: inbox_e=> /andP[] /andP[] + _ _; rewrite lgq.
+rewrite -cat_rcons.
+rewrite pairwise_map.
+move: pwo; rewrite pairwise_cons ocd -cat_rcons pairwise_map=> /andP[] _ pwo'.
+have vhocd : all ((@valid_edge _)^~ (point e))
+     [seq high x | x <- fc ++ cc ++ lcc :: lc].
+  by rewrite -ocd; apply/allP; apply: seq_valid_high.
+move: (pwo'); rewrite cat_rcons -pairwise_map=> pwo2.
+have puh' : point e <<< high lcc by rewrite -heq.
+apply: (pairwise_subst pwo'); rewrite -?pairwise_map.
+- rewrite -oc_eq.
+  have lein' : le \in all_edges open (e :: future_events).
+    by rewrite mem_cat lein.
+  have hein' : he \in all_edges open (e :: future_events).
+    by rewrite mem_cat hein.
+  by apply: opening_cells_pairwise.
+- have : allrel (@edge_below _) [seq high x | x <- fc]
+          [seq high x | x <- rcons nos lno].
+    have fcle : all ((@edge_below _)^~ le) [seq high x | x <- fc].
+      apply/allP=> x /mapP[xc xcin xq].
+      elim/last_ind : {-1} (fc) (erefl fc) => [ | fc' lfc _] fcq.
+        by move: xcin; rewrite fcq.
+      have := last_first_cells_high cbtom adj bet_e oe => <-.
+      rewrite fcq map_rcons last_rcons xq.
+      move: xcin; rewrite fcq mem_rcons inE=> /orP[/eqP -> | xcin ].
+        by apply: edge_below_refl.
+      move: pwo'; rewrite pairwise_cat fcq pairwise_rcons=> /andP[] _ /andP[].
+      by move=> /andP[] + _ _ => /allP /(_ xc xcin) /=.
+    have := new_edges_above_first_old ocd vhocd pwo2 fcle pal puh' vle.
+    by rewrite -oc_eq heq.
+  by rewrite allrel_mapr allrel_mapl.
+have : allrel (@edge_below _) [seq high x | x <- rcons nos lno]
+            [seq high x | x <- lc].
+   have := new_edges_below_last_old ocd vhocd pwo2 (underWC pal) puh' vle.
+   by rewrite -heq oc_eq.
+by rewrite allrel_mapl allrel_mapr.
+Qed.
+
+#[clearbody]
+Let open_edge_valid x :
+   x \in cell_edges open -> valid_edge x (point e).
+Proof.
+by rewrite /cell_edges mem_cat => /orP[] /mapP [c /(allP sval) /andP[]+ + ->].
+Defined.
+
+Lemma step_keeps_pw :
+  pairwise (@edge_below _)
+     (bottom ::
+       [seq high x | x <- state_open_seq (step (Bscan fop lsto lop cls lstc
+           lsthe lstx) e)]).
+Proof.
+rewrite /step/=/generic_trajectories.simple_step.
+case: ifP=> [pxaway | /negbFE/eqP/[dup] pxhere/abovelstle palstol].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe : (open_cells_decomposition (fop ++ lsto :: lop) (point e))=>
+    [[[[[fc cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  move: step_keeps_pw_default; rewrite /open.
+  by rewrite oe oca_eq /state_open_seq /= catA.
+case: ifP=> [eabove | ebelow].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe: (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  have eabove' : point e >>> low (head dummy_cell lop).
+    have llopq : low (head dummy_cell lop) = lsthe.
+      apply: esym; rewrite lstheq.
+      move: (exi' eabove)=> [w + _].
+      move: adj=> /adjacent_catW[] _.
+      by case: (lop) => [ // | ? ?] /andP[] /eqP.
+    by rewrite llopq.
+  have oe' :
+    open_cells_decomposition open (point e) =
+     (rcons fop lsto ++ fc', cc, lcc, lc, le, he).
+    move: adj rfo sval; rewrite /open -cat_rcons=> adj' rfo' sval'.
+    move: (open_cells_decomposition_cat adj' rfo' sval' (exi' eabove)).
+    by rewrite oe; apply.
+  have := step_keeps_pw_default; rewrite oe' oca_eq.
+  rewrite [state_open_seq _]
+           (_ : _ = (rcons fop lsto ++ fc') ++ nos ++ lno :: lc); last first.
+    by rewrite /state_open_seq /= cat_rcons !catA.
+  by apply.
+case: ifP => [ebelow_st {ebelow} | eonlsthe].
+  rewrite /state_open_seq /=.
+  rewrite /generic_trajectories.update_open_cell.
+  case oq : (outgoing e) => [ | fog ogs] /=.
+    rewrite cats0 map_cat /=; apply/andP; split.
+      move: pwo; rewrite pairwise_cons /open => /andP[] + _.
+      by rewrite map_cat.
+    move: pwo; rewrite pairwise_cons /open=> /andP[] _.
+    by rewrite map_cat /=.
+  have ocd : open_cells_decomposition open (point e) =
+          (fop, [::], lsto, lop, low lsto, high lsto).
+    by rewrite open_cells_decomposition_single; rewrite // -lstheq.
+  have same_left cg lpts : (fun c' => (edge_below (high cg) (high c'))) =1
+      (fun c' => (edge_below (high (set_left_pts cg lpts))(high c'))).
+    by move=> c'; rewrite /set_left_pts /=.
+  have same_right cg lpts : (fun c' => edge_below (high c') (high cg)) =1
+      (fun c' => edge_below (high c') (high (set_left_pts cg lpts))).
+    by move=> c'; rewrite /set_left_pts /=.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [[ | f s] c] /=.
+    rewrite cats0 -cat_rcons.
+    have:= step_keeps_pw_default.
+    rewrite ocd oq oca_eq /= cat_rcons !pairwise_map => pw.
+    have onn : outgoing e != [::] by rewrite oq.
+    have := opening_cells_aux_absurd_case vlo vho onn oute.
+    by rewrite oq oca_eq.
+  have := step_keeps_pw_default.
+  rewrite ocd oq oca_eq /= !pairwise_map => pw.
+  rewrite -catA /=.
+  apply/andP; split.
+    by move: pw=> /andP[] + _; rewrite !map_cat !all_cat /=.
+  have := @pairwise_subst1 _
+                 (fun c1 c2 => edge_below (high c1) (high c2)) f
+      (set_left_pts f [:: point e & behead (left_pts lsto)]
+) fop (s ++ c :: lop)
+      (same_left f (point e :: behead (left_pts lsto)))
+      (same_right f (point e :: behead (left_pts lsto))) => <-.
+  by move: pw=> /andP[] _.
+(* Now the point is on lsthe *)
+(* Next12 lines duplicated from the end of step_keeps_invariant1 *)
+have lsto_ctn : contains_point'(point e) lsto.
+  rewrite /contains_point'.
+  by rewrite -lstheq /point_under_edge (negbFE ebelow) abovelstle.
+have exi2 : exists2 c, c \in (lsto :: lop) & contains_point' (point e) c.
+  by exists lsto; rewrite // inE eqxx.
+case oe : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+have := open_cells_decomposition_cat adj rfo sval exi2 palstol.
+  rewrite oe => oe'.
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+  decomposition_main_properties oe' exi.
+have [ocd' _] := decomposition_main_properties oe exi2.
+have [fc'0  [lelsto [cc' ccq]]] : fc' = [::] /\ le = low lsto /\
+  exists cc', cc = lsto :: cc'.
+  by have := last_step_situation oe pxhere (negbT eonlsthe) (negbFE ebelow).
+rewrite /generic_trajectories.update_open_cell_top.
+case o_eq : (outgoing e) => [ | g l]; rewrite -?o_eq; last first.
+(* If there are outgoing edges, this cell is treated as in the default case. *)
+  have := step_keeps_pw_default.
+  rewrite -/(open_cells_decomposition _ _) oe' -lelsto.
+  rewrite oe.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case: (opening_cells_aux _ _ _ _) => [nos lno].
+  case nosq : nos => [ | fno nos'] /=.
+    by rewrite /state_open_seq /= !cats0.
+  rewrite /state_open_seq /= catA -(catA (_ ++ _)) /= map_cat /= => it.
+  by rewrite map_cat /=.
+rewrite -/(open_cells_decomposition _ _) oe /=.
+have := step_keeps_pw_default; rewrite oe' -lelsto o_eq /=.
+have vle : valid_edge le (point e) by apply: open_edge_valid.
+have vhe : valid_edge he (point e) by apply: open_edge_valid.
+do 2 rewrite -/(vertical_intersection_point _ _).
+by rewrite pvertE // pvertE // !map_cat /= cats0.
+Qed.
+
+Lemma update_open_cell_side_limit_ok new_op new_lsto:
+  update_open_cell lsto e = (new_op, new_lsto) ->
+  p_x (point e) = left_limit lsto ->
+  point e <<< high lsto ->
+  point e >>> low lsto ->
+  all open_cell_side_limit_ok (rcons new_op new_lsto).
+Proof.
+rewrite /update_open_cell/generic_trajectories.update_open_cell.
+move=> + pxq puh pal /=.
+have := (allP open_side_limit lsto lstoin).
+rewrite /open_cell_side_limit_ok /= => /andP[] lptsno /andP[] alllpts.
+move=> /andP[] slpts /andP[] athigh atlow.
+case lptsq : (left_pts lsto) lptsno => [ // | p1 [ | p2 lpts']] _ /=.
+  rewrite lptsq /= in athigh atlow.
+  (* contradiction with puh pal *)
+  have pxe1 : p_x (point e) = p_x p1 by rewrite pxq /left_limit lptsq.
+  have := strict_under_edge_lower_y pxe1 athigh; rewrite puh=> /esym.
+  have := under_edge_lower_y pxe1 atlow; rewrite (negbTE pal)=>/esym.
+  move/negbT; rewrite -ltNge=> /lt_trans /[apply].
+  by rewrite lt_irreflexive.
+have pxe2 : p_x (point e) = p_x p2.
+  rewrite (eqP (allP alllpts p2 _)); last by rewrite lptsq !inE eqxx orbT.
+  exact pxq.
+have p2lte : p_y p2 < p_y (point e).
+  have := lex_left_limit; rewrite lptsq /= => /andP[] + _.
+  by rewrite /lexPt pxe2 lt_irreflexive eqxx.
+case ogq : (outgoing e) => [ | fog ogs].
+  move=> [] <- <-; rewrite /= andbT /open_cell_side_limit_ok /=.
+  have pxel : p_x (point e) = p_x (last p2 lpts').
+    by rewrite pxq /left_limit lptsq.
+  move: (alllpts); rewrite /left_limit.
+  rewrite lptsq /= => /andP[] -> /andP[] /[dup]/eqP p2x -> ->.
+  rewrite lptsq /= in athigh.
+  have pxe1 : p_x (point e) = p_x p1.
+    by have := alllpts; rewrite lptsq /= => /andP[] /eqP ->.
+  have := strict_under_edge_lower_y pxe1 athigh; rewrite puh=> /esym ye1.
+  move: (pxel) => /eqP ->; rewrite ye1.
+  move: slpts; rewrite lptsq /= => /andP[] _ ->.
+  by rewrite athigh; move: atlow; rewrite lptsq /= => ->; rewrite p2lte !andbT.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq: (opening_cells_aux _ _ _ _) => [[ | fno nos] lno].
+  have onn : outgoing e != [::] by rewrite ogq.
+  have := opening_cells_aux_absurd_case vlo vho onn oute.
+  by rewrite ogq oca_eq.
+move=> -[] <- <- /=.
+have ognn : outgoing e != [::] by rewrite ogq.
+have := opening_cells_last_left_pts vlo vho oute ognn puh; rewrite /=.
+rewrite ogq oca_eq /= => llnoq /=.
+move: (alllpts); rewrite /left_limit.
+rewrite lptsq /= => /andP[] _ /andP[] -> ->.
+move: pxq; rewrite /left_limit lptsq /= => ->; rewrite eqxx /=.
+rewrite p2lte /=.
+have := allP open_side_limit lsto lstoin => /andP[] _ /andP[] _.
+rewrite lptsq /= => /andP[] /andP[] _ -> /andP[] _ llo.
+have := opening_cells_seq_edge_shift _ vlo vho oca_eq.
+rewrite -ogq => /(_ oute') /= -[] <- _; rewrite llo andbT.
+have := opening_cells_aux_high vlo vho oute'; rewrite ogq oca_eq /= => highout.
+apply/andP; split.
+  have /oute'/eqP <- : high fno \in sort (@edge_below _) (outgoing e).
+    by rewrite ogq -highout inE eqxx.
+  by apply left_on_edge.
+have := opening_cells_aux_side_limit vlo vho (underWC pal) puh oute'.
+rewrite ogq oca_eq => /(_ _ _ erefl) allok.
+by apply/allP=> x xin; apply: (allP allok x); rewrite /= inE xin orbT.
+Qed.
+
+Lemma size_left_lsto :
+  p_x (point e) = lstx ->
+  point e >>> low lsto ->
+  point e <<= high lsto ->
+  (1 < size (left_pts lsto))%N.
+Proof.
+move=> pxhere pal puh.
+have lstok : open_cell_side_limit_ok lsto by apply: (allP open_side_limit).
+case lptsq : (left_pts lsto) => [ | p1 [ | p2 lpts]] //.
+  by move: lstok; rewrite /open_cell_side_limit_ok lptsq.
+have /andP[p1onh p1onl] : (p1 === high lsto) && (p1 === low lsto).
+  by move: lstok; rewrite /open_cell_side_limit_ok /left_limit lptsq /= eqxx /=.
+have samex : p_x (point e) = p_x p1.
+  by have := pxhere; rewrite lstxq /left_limit lptsq /=.
+suff : p_y (point e) < p_y (point e) by rewrite lt_irreflexive.
+have := same_pvert_y vho samex.
+rewrite (on_pvert p1onh).
+have := under_pvert_y vho; move: (puh)=> /[swap] -> /[swap] ->.
+move=> /le_lt_trans; apply.
+have := under_pvert_y vlo; move: (pal) => /[swap] ->.
+rewrite (same_pvert_y vlo samex).
+by rewrite -ltNge (on_pvert p1onl).
+Qed.
+
+Lemma step_keeps_open_side_limit_default :
+  let '(fc, cc, lcc, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+    let '(nos, lno) := opening_cells_aux (point e)
+       (sort (@edge_below _) (outgoing e)) le he in
+  all open_cell_side_limit_ok ((fc ++ nos) ++ lno :: lc).
+Proof.
+case oe: (open_cells_decomposition open (point e)) =>
+  [[[[[fc cc] lcc] lc] le] he].
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]]
+  := decomposition_main_properties oe exi.
+have [pal puh vle vhe allnct] :=
+  decomposition_connect_properties rfo sval adj cbtom bet_e oe.
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+have oc_eq : opening_cells (point e) (outgoing e) le he = rcons nos lno.
+  by rewrite /opening_cells oca_eq.
+have := opening_cells_side_limit vle vhe (underWC pal) puh oute.
+rewrite /opening_cells oca_eq => oknew.
+rewrite -catA -cat_rcons !all_cat andbCA; apply/andP; split; first by [].
+have := open_side_limit; rewrite ocd -cat_rcons all_cat=> /andP[] -> /=.
+by rewrite all_cat /= => /andP[].
+Qed.
+
+Lemma step_keeps_open_side_limit :
+  all open_cell_side_limit_ok
+    (state_open_seq (step (Bscan fop lsto lop cls lstc lsthe lstx) e)).
+Proof.
+rewrite /step/=/generic_trajectories.simple_step.
+case: ifP=> [pxaway | /negbFE/eqP/[dup] pxhere/abovelstle palstol].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe : (open_cells_decomposition (fop ++ lsto :: lop) (point e))=>
+    [[[[[fc cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  by move: step_keeps_open_side_limit_default; rewrite /open oe oca_eq.
+case: ifP=> [eabove | ebelow].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe: (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  have eabove' : point e >>> low (head dummy_cell lop).
+    have llopq : low (head dummy_cell lop) = lsthe.
+      apply: esym; rewrite lstheq.
+      move: (exi' eabove)=> [w + _].
+      move: adj=> /adjacent_catW[] _.
+      by case: (lop) => [ // | ? ?] /andP[] /eqP.
+    by rewrite llopq.
+  have oe' :
+    open_cells_decomposition open (point e) =
+     (rcons fop lsto ++ fc', cc, lcc, lc, le, he).
+    move: adj rfo sval; rewrite /open -cat_rcons=> adj' rfo' sval'.
+    move: (open_cells_decomposition_cat adj' rfo' sval' (exi' eabove)).
+    by rewrite oe; apply.
+  move: step_keeps_open_side_limit_default; rewrite /open oe' oca_eq.
+  by rewrite /state_open_seq /= cat_rcons.
+case: ifP => [ebelow_st {ebelow} | eonlsthe].
+  rewrite /state_open_seq /=.
+  rewrite -/(update_open_cell _ _).
+  case uoc_eq : (update_open_cell lsto e) => [nos lno] /=.
+  have pxhere' : p_x (point e) = left_limit lsto by rewrite pxhere.
+  have puh : point e <<< high lsto by rewrite -lstheq.
+  have nosok := update_open_cell_side_limit_ok uoc_eq pxhere' puh palstol.
+  rewrite -catA -cat_rcons !all_cat nosok /= -all_cat.
+  by apply: (all_sub _ open_side_limit); rewrite /open; subset_tac.
+move/negbFE:ebelow => ebelow.
+move/negbT: eonlsthe=> eonlsthe.
+rewrite -/(open_cells_decomposition _ _).
+case oe : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+have exi2 : exists2 c, c \in lsto :: lop & contains_point' (point e) c.
+  by exists lsto; [subset_tac | rewrite /contains_point' palstol -lstheq].
+have := open_cells_decomposition_cat adj rfo sval exi2 palstol.
+have [fc'0 [lelsto _]] :=
+   last_step_situation oe pxhere eonlsthe ebelow.
+rewrite oe fc'0 lelsto cats0=> oe'.
+rewrite /generic_trajectories.update_open_cell_top.
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe' exi.
+have lstok : open_cell_side_limit_ok lsto by apply: (allP open_side_limit).
+have slpts : (1 < size (left_pts lsto))%N.
+  by apply: size_left_lsto=> //; rewrite -lstheq.
+have [pal puh vle vhe ncont] :=
+    decomposition_connect_properties rfo sval adj cbtom bet_e oe'.
+case ogq : (outgoing e) => [ | fog ogs]; rewrite -?ogq; last first.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [[ | fno nos] lno].
+  have ognn : outgoing e != [::] by rewrite ogq.
+    have := opening_cells_aux_absurd_case vlo vhe ognn oute.
+    by rewrite oca_eq.
+  have := step_keeps_open_side_limit_default; rewrite /open oe' oca_eq.
+  rewrite /state_open_seq -!catA /= !all_cat /= !all_cat=> /andP[] ->.
+  move=> /andP[] _ -> /=; rewrite andbT.
+  rewrite /open_cell_side_limit_ok /set_left_pts /=.
+  move: lstok=> /andP[].
+  rewrite pxhere lstxq /left_limit.
+  case lptsq: (left_pts lsto) slpts=> [// | p1 [ // | p2 ps]] _ _ /=.
+  move=> /andP[] /andP[] _ /[dup] /andP[] x2q _ ->.
+  move=> /andP[] /andP[] + -> /andP[] _.
+  have := opening_cells_seq_edge_shift oute' vlo vhe oca_eq.
+  rewrite eqxx /= => -[] <- _.
+  move=> _ ->.
+  have := lex_left_limit; rewrite lptsq /= => /andP[] + _.
+  rewrite /lexPt lt_neqAle pxhere lstxq /left_limit lptsq /= x2q /= => ->.
+  have /oute/eqP <- : high fno \in outgoing e.
+    have := opening_cells_aux_high vlo vhe oute'; rewrite oca_eq /=.
+    by rewrite -(mem_sort (@edge_below _))=> <-; rewrite inE eqxx.
+  by rewrite !andbT /=; apply: left_on_edge.
+(* Finished the case where there are some elements in outgoing e *)
+rewrite /state_open_seq/= !cats0.
+rewrite all_cat /=.
+move: (open_side_limit); rewrite /open ocd !all_cat /=.
+move=> /andP[] -> /andP[] _ /andP[] _ ->; rewrite /= ?andbT.
+case lptsq : (left_pts lsto) slpts => [ | p1 [ | p2 lpts]] // _.
+rewrite /open_cell_side_limit_ok /=.
+have pxe : p_x (point e) = p_x (last p2 lpts).
+  by rewrite pxhere lstxq /left_limit lptsq /=.
+rewrite pxe eqxx /=.
+move: (lstok); rewrite /open_cell_side_limit_ok /left_limit lptsq /=.
+move=> /andP[] /andP[] /[dup] /eqP p1x -> /andP[] -> ->.
+move=> /andP[] /andP[] -> -> /andP[] p1on ->.
+rewrite /= !andbT.
+have p1e : p1 = (point e).
+  have samex : p_x (point e) = p_x p1.
+    by have := pxhere; rewrite lstxq /left_limit lptsq /= p1x.
+  have samey : p_y (point e) = p_y p1.
+    have eonlsthe' : point e === high lsto.
+      by apply: under_above_on=> //; rewrite -lstheq // ?underW.
+    exact: (on_edge_same_point eonlsthe' p1on samex).
+  by apply/esym/(@eqP pt); rewrite pt_eqE samex samey !eqxx.
+rewrite p1e /generic_trajectories.pvert_y subrr -strict_under_pvert_y //.
+by rewrite puh -pxe pvert_on.
+Qed.
+
+Lemma disjoint_open : {in open &, disjoint_open_cells R}.
+Proof.
+by apply: disoc=> //; have := pwo; rewrite /= => /andP[].
+Qed.
+
+Lemma step_keeps_open_disjoint :
+  {in state_open_seq (step (Bscan fop lsto lop cls lstc lsthe lstx) e) &,
+     disjoint_open_cells R}.
+Proof.
+have := step_keeps_invariant1; rewrite /invariant1/inv1_seq.
+set s' := (state_open_seq _) => -[clae' [sval' [adj' [cbtom' srf']]]].
+have := step_keeps_pw; rewrite -/s' => /= /andP[] _ pw'.
+have := step_keeps_open_side_limit; rewrite -/s'=> ok'.
+apply: disoc=>//.
+Qed.
+
+Section arbitrary_closed.
+
+Variable old_closed : seq cell.
+
+Hypothesis disjoint_open_old_closed :
+  {in open & old_closed, disjoint_open_closed_cells R}.
+
+Hypothesis disjoint_old_closed : {in old_closed &, disjoint_closed_cells R}.
+Hypothesis old_closed_right_limit :
+  {in old_closed, forall c, right_limit c <= p_x (point e)}.
+
+Lemma step_keeps_disjoint_default :
+  let '(fc, cc, lcc, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+    let '(nos, lno) :=
+      opening_cells_aux (point e)
+       (sort (@edge_below _) (outgoing e)) le he in
+    let closed := closing_cells (point e) cc in
+     let last_closed := close_cell (point e) lcc in
+     let closed_cells := old_closed ++ rcons closed last_closed in
+  {in closed_cells &, disjoint_closed_cells R} /\
+  {in fc ++ nos ++ lno :: lc & closed_cells,
+    disjoint_open_closed_cells R}.
+Proof.
+case oe : (open_cells_decomposition open (point e)) =>
+   [[[[[fc  cc] lcc] lc] le] he].
+  have [ocd [lcc_ctn [all_ct [all_nct [flcnct
+     [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe ncont]
+ := connect_properties cbtom adj rfo sval bet_e ocd all_nct all_ct
+  lcc_ctn flcnct.
+have allcont : all (contains_point (point e)) (rcons cc lcc).
+  by rewrite -cats1 all_cat /= lcc_ctn !andbT; apply/allP.
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+move=> closed last_closed closed_cells.
+have svalcc : seq_valid (rcons cc lcc) (point e).
+   apply/allP=> c cin; apply: (allP sval); rewrite ocd !mem_cat.
+   move: cin; rewrite mem_rcons inE.
+   by move=> /orP[/eqP |] ->; rewrite ?inE ?eqxx ?orbT //.
+have adjcc : adjacent_cells (rcons cc lcc).
+  by move: adj; rewrite ocd -cat_rcons =>/adjacent_catW[] _ /adjacent_catW[].
+have rfocc : s_right_form (rcons cc lcc).
+   apply/allP=> c cin; apply: (allP rfo); rewrite ocd !mem_cat.
+   move: cin; rewrite mem_rcons inE.
+   by move=> /orP[/eqP |] ->; rewrite ?inE ?eqxx ?orbT //.
+have closed_map : closing_cells (point e) (rcons cc lcc) =
+       rcons [seq close_cell (point e) c | c <- cc]
+          (close_cell (point e) lcc).
+  by rewrite /closing_cells map_rcons.
+have ccok : all open_cell_side_limit_ok (rcons cc lcc).
+    apply/allP=> c cin; apply: (allP open_side_limit); rewrite ocd !mem_cat.
+  move: cin; rewrite mem_rcons inE.
+   by move=> /orP[/eqP |] ->; rewrite ?inE ?eqxx ?orbT //.
+have := closing_cells_side_limit' rfocc svalcc adjcc ccok allcont.
+rewrite head_rcons pal last_rcons puh=> /(_ isT isT).
+rewrite [X in all _ X]closed_map=> /allP cl_sok.
+have oldcl_newcl :
+  {in old_closed & closing_cells (point e) (rcons cc lcc),
+     disjoint_closed_cells R}.
+  move=> c1 c2 c1in; rewrite closed_map -map_rcons=> /mapP[c2' c2'in c2eq].
+  have c2'open : c2' \in open.
+    by rewrite ocd -cat_rcons !mem_cat c2'in !orbT.
+    have vc2 : valid_cell c2' (point e) by apply/andP/(allP sval).
+  right; rewrite /c_disjoint=> q; apply/negP=> /andP[inc1 inc2].
+  rewrite c2eq in inc2.
+   case/negP:(disjoint_open_old_closed c2'open c1in q).
+   rewrite inc1 andbT.
+  apply:(close'_subset_contact vc2 _ inc2).
+  by move: (cl_sok c2); rewrite c2eq; apply; rewrite -map_rcons; apply: map_f.
+split.
+  move=> c1 c2; rewrite !mem_cat.
+  move=> /orP[c1old | c1new] /orP[c2old | c2new].
+         by apply: disjoint_old_closed.
+      by apply: oldcl_newcl; rewrite // closed_map.
+    apply: c_disjoint_eC; apply: oldcl_newcl; first by [].
+    by rewrite closed_map.
+  rewrite -map_rcons in c1new c2new.
+  move: c1new c2new => /mapP[c1' c1'in c1eq] /mapP[c2' c2'in c2eq].
+  have c1'open : c1' \in open by rewrite ocd -cat_rcons !mem_cat c1'in orbT.
+  have c2'open : c2' \in open by rewrite ocd -cat_rcons !mem_cat c2'in orbT.
+  have vc1 : valid_cell c1' (point e) by apply/andP/(allP sval).
+  have vc2 : valid_cell c2' (point e) by apply/andP/(allP sval).
+  have [/eqP c1c2 | c1nc2] := boolP(c1' == c2').
+    by left; rewrite c1eq c2eq c1c2.
+  right=> q; apply/negP=> /andP[inc1 inc2].
+  case: (disjoint_open c1'open c2'open)=> [/eqP | /(_ q)].
+    by rewrite (negbTE c1nc2).
+  move=> /negP[].
+  rewrite c1eq in inc1; rewrite c2eq in inc2.
+  rewrite (close'_subset_contact vc1 _ inc1); last first.
+    by apply: cl_sok; rewrite -map_rcons; apply: map_f.
+  rewrite (close'_subset_contact vc2 _ inc2) //.
+  by apply: cl_sok; rewrite -map_rcons; apply: map_f.
+rewrite -leq in vle; rewrite -heq in vhe.
+move=> c1 c2; rewrite -cat_rcons 2!mem_cat orbCA=> /orP[c1newo |c1old] c2in.
+  have rlc2 : right_limit c2 <= p_x (point e).
+    move: c2in; rewrite /closed_cells mem_cat.
+    move=> /orP[/old_closed_right_limit // |].
+    rewrite -map_rcons=> /mapP[c2' c2'in ->].
+    by rewrite close_cell_right_limit //; apply/andP/(allP svalcc).
+  move=> q; rewrite inside_open'E inside_closed'E; apply/negP.
+  move=> /andP[] /andP[] _ /andP[] _ /andP[] + _
+     /andP[] _ /andP[] _ /andP[] _ +.
+  have := opening_cells_left oute vle vhe.
+  rewrite /opening_cells oca_eq=> /(_ _ c1newo) => -> peq qrlc2.
+  by move: rlc2; rewrite leNgt=>/negP[]; apply: (lt_le_trans peq).
+have c1open : c1 \in open by rewrite ocd -cat_rcons !mem_cat orbCA c1old orbT.
+move: c2in; rewrite /closed_cells mem_cat=>/orP[c2old |].
+  by apply: disjoint_open_old_closed.
+rewrite -map_rcons=> /mapP[c2' c2'in c2eq] q; apply/negP=> /andP[] inc1 inc2.
+have c2'open : c2' \in open by rewrite ocd -cat_rcons !mem_cat c2'in !orbT.
+have [c1eqc2 | disjc1c2] := disjoint_open c1open c2'open.
+  case (negP (ncont _ c1old)).
+  rewrite c1eqc2.
+  by move: c2'in; rewrite mem_rcons inE=> /orP[/eqP -> | /all_ct].
+move: (disjc1c2 q); rewrite inc1 //=.
+have vc2 : valid_cell c2' (point e) by apply/andP/(allP sval).
+rewrite c2eq in inc2.
+rewrite (close'_subset_contact vc2 _ inc2) //.
+by apply: cl_sok; rewrite -map_rcons; apply: map_f.
+Qed.
+
+End arbitrary_closed.
+
+Lemma bottom_edge_below : {in cell_edges open, forall g, bottom <| g}.
+Proof.
+move: pwo=> /= /andP[] /allP pwo' _ g.
+rewrite (cell_edges_sub_high cbtom adj) inE=> /orP[/eqP -> | /pwo' //].
+by apply: edge_below_refl.
+Qed.
+
+Definition state_closed_seq (s : scan_state) :=
+  rcons (sc_closed s) (lst_closed s).
+
+Lemma adjacent_update_open_cell new_op new_lsto:
+  update_open_cell lsto e = (new_op, new_lsto) ->
+  low lsto = low (head dummy_cell (rcons new_op new_lsto)) /\
+  high lsto = high (last dummy_cell (rcons new_op new_lsto)) /\
+  adjacent_cells (rcons new_op new_lsto).
+Proof.
+rewrite /update_open_cell/generic_trajectories.update_open_cell.
+case o_eq : (outgoing e) => [ | g os].
+  by move=> [] <- <- /=.
+rewrite -o_eq.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [[ // | fno nos] lno] [] <- <-.
+  have onn : outgoing e != [::] by rewrite o_eq.
+  by have := opening_cells_aux_absurd_case vlo vho onn oute; rewrite oca_eq.
+rewrite /= last_rcons.
+have [/= A ->] := adjacent_opening_aux vlo vho oute' oca_eq.
+split;[ | split]=> //=.
+  have := opening_cells_aux_high_last vlo vho oute'.
+  by rewrite oca_eq /=.
+by move: A; case : (nos).
+Qed.
+
+Lemma low_all_edges c evs: c \in open -> low c \in all_edges open evs.
+Proof. by move=> cin; rewrite !mem_cat map_f ?orbT. Qed.
+
+Lemma high_all_edges c evs: c \in open -> high c \in all_edges open evs.
+Proof. by move=> cin; rewrite !mem_cat map_f ?orbT. Qed.
+
+Lemma update_open_cell_right_form  new_op new_lsto:
+  update_open_cell lsto e = (new_op, new_lsto) ->
+  point e <<< high lsto ->
+  point e >>> low lsto ->
+  s_right_form (rcons new_op new_lsto).
+Proof.
+move=> + puho palo.
+have noco : below_alt (low lsto) (high lsto).
+  apply: noc; first by apply: low_all_edges; rewrite /open; subset_tac.
+  by apply: high_all_edges; rewrite /open; subset_tac.
+have rflsto : low lsto <| high lsto.
+  by apply: (edge_below_from_point_above noco vlo vho (underWC _)).
+rewrite /update_open_cell/generic_trajectories.update_open_cell.
+have srt : path (@edge_below _) (low lsto) (sort (@edge_below _) (outgoing e)).
+  apply: (sorted_outgoing vlo vho palo puho oute).
+  apply: sub_in2 noc=> x; rewrite 2!inE => /orP[/eqP ->|/orP[/eqP ->|]] //.
+  by apply: subo.
+case ogeq : (outgoing e) => [ | g os].
+  move=> [] <- <- /=; rewrite andbT.
+  by apply: (edge_below_from_point_above noco vlo vho (underWC _)).
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [[ | fno nos] lno].
+  move=> [] <- <- /=; rewrite andbT.
+  rewrite -ogeq /= in oca_eq.
+  have /= := opening_cells_aux_right_form (underWC palo)
+  puho vlo vho loin hoin rflsto oute' noc subo' srt oca_eq.
+  by rewrite andbT.
+move=> [] <- <- /=.
+rewrite -ogeq /= in oca_eq.
+by have /= := opening_cells_aux_right_form (underWC palo)
+puho vlo vho loin hoin rflsto oute' noc subo' srt oca_eq.
+Qed.
+
+Lemma update_open_cell_end_edge new_op new_lsto :
+  end_edge_ext bottom top (low lsto) future_events ->
+  end_edge_ext bottom top (high lsto) future_events ->
+  valid_edge (low lsto) (point e) ->
+  valid_edge (high lsto) (point e) ->
+  update_open_cell lsto e = (new_op, new_lsto) ->
+  {in rcons new_op new_lsto, forall x,
+    end_edge_ext bottom top (low x) future_events &&
+    end_edge_ext bottom top (high x) future_events}.
+Proof.
+move=> endl endh vl vh.
+rewrite /update_open_cell/generic_trajectories.update_open_cell.
+case ogeq : (outgoing e) => [ | fog ogs].
+  move=> [] <- <- /= x; rewrite inE=> /eqP -> /=.
+  by rewrite endl endh.
+move: cle; rewrite /= => /andP[] cloe _.
+have cllsto := opening_cells_close vl vh oute endl endh cloe => {cloe}.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [[ | fno nos] lno].
+  have onn : outgoing e != [::] by rewrite ogeq.
+  have := opening_cells_aux_absurd_case vlo vho onn oute.
+  by rewrite ogeq oca_eq.
+move=> -[] <- <- /= x; rewrite inE=> /orP[/eqP -> | xin].
+  by rewrite /=; apply: (allP cllsto); rewrite /opening_cells ogeq oca_eq /=;
+   subset_tac.
+by apply: (allP cllsto); rewrite /opening_cells ogeq oca_eq /= inE xin orbT.
+Qed.
+
+Lemma update_open_cell_end_edge' c nos lno :
+  valid_edge (low c) (point e) ->
+  valid_edge (high c) (point e) ->
+  update_open_cell c e = (nos, lno) ->
+  close_alive_edges (rcons nos lno) future_events =
+  close_alive_edges (opening_cells (point e) (outgoing e)
+      (low c) (high c)) future_events.
+Proof.
+move=> vlc vhc; rewrite /update_open_cell/generic_trajectories.update_open_cell.
+case ogeq : (outgoing e) => [ | fog ogs].
+  move=> -[] <- <- /=.
+  rewrite /opening_cells /=.
+  rewrite -/(vertical_intersection_point _ _) /= pvertE //.
+  by rewrite -/(vertical_intersection_point _ _) pvertE.
+rewrite /opening_cells /=.
+have onn : outgoing e != [::] by rewrite ogeq.
+have := opening_cells_aux_absurd_case vlc vhc onn oute; rewrite ogeq.
+rewrite -/(opening_cells_aux _ _ _ _).
+by case oca_eq : (opening_cells_aux _ _ _ _) => [[ | ? ?] ?] + [] <- <- /=.
+Qed.
+
+(* Lemma update_open_cell_valid c nos lno :
+  valid_edge (low c) (point e) ->
+  valid_edge (high c) (point e) ->
+  update_open_cell c e = (nos, lno) ->
+  seq_valid (rcons nos lno) p =
+  seq_valid (opening_cells (point e) (outgoing e) (low c) (high c)) p.
+Proof.
+move=> vlc vhc; rewrite /update_open_cell/generic_trajectories.update_open_cell.
+case ogeq : (outgoing e) => [ | fog ogs].
+  move=> -[] <- <- /=.
+  rewrite /opening_cells /= -/(vertical_intersection_point _ _) pvertE //.
+  by rewrite -/(vertical_intersection_point _ _) pvertE.
+rewrite /opening_cells /=.
+have onn : outgoing e != [::] by rewrite ogeq.
+have := opening_cells_aux_absurd_case vlc vhc onn oute; rewrite ogeq.
+rewrite -/(opening_cells_aux _ _ _ _).
+by case oca_eq : (opening_cells_aux _ _ _ _) => [[ | ? ?] ?] + [] <- <- /=.
+Qed.
+*)
+Lemma lex_left_pts_inf' :
+  let '(fc, _, _, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+  let '(nos, lno) :=
+    opening_cells_aux (point e) (sort (@edge_below _) (outgoing e)) le he in
+    {in fc ++ nos ++ lno :: lc,
+      forall c, lexePt  (bottom_left_corner c) (point e)}.
+Proof.
+case oe : (open_cells_decomposition _ _) => [[[[[fc cc] lcc] lc] le] he].
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+have [ocd [_ [_ [_ [_ [leq [heq [lein hein]]]]]]]]:=
+  decomposition_main_properties oe exi.
+have [pal puh vle vhe A']:= decomposition_connect_properties rfo sval adj cbtom
+  bet_e oe.
+have sublehe : {subset rcons (le :: sort (@edge_below _) (outgoing e)) he <=
+                  all_edges open (e :: future_events)}.
+  move=> x; rewrite mem_rcons inE => /orP[/eqP -> | ].
+    by rewrite /all_edges; subset_tac.
+  rewrite inE=> /orP[/eqP -> | ].
+    by rewrite /all_edges; subset_tac.
+  by apply: subo'.
+have noc2:
+   {in rcons (le :: sort (@edge_below _) (outgoing e)) he &, no_crossing R}.
+  by move=> x y xin yin; apply: noc; apply: sublehe.
+move=> x; rewrite !(mem_cat, inE) => /orP[xfc | ].
+  by apply: lexPtW; apply: btom_left_corners; rewrite ocd; subset_tac.
+rewrite orbA=> /orP[xin | xlc]; last first.
+  apply: lexPtW.
+  apply: btom_left_corners; rewrite ocd; subset_tac.
+have noclh : below_alt le he.
+  by apply: noc2; rewrite ?(mem_rcons, inE) eqxx ?orbT.
+have lebhe : le <| he.
+  apply: (edge_below_from_point_above noclh vle vhe (underWC pal) puh).
+have := opening_cells_last_lexePt oute (underWC pal) puh vle vhe noc2 lebhe.
+rewrite /opening_cells oca_eq; apply.
+by rewrite mem_rcons inE orbC.
+Qed.
+
+Lemma step_keeps_btom_left_corners_default q :
+  lexPt (point e) q ->
+  let '(fc, _, _, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+  let '(nos, lno) :=
+    opening_cells_aux (point e) (sort (@edge_below _) (outgoing e)) le he in
+    {in fc ++ nos ++ lno :: lc, forall c, lexPt  (bottom_left_corner c) q}.
+Proof.
+move=> lexq.
+case oe : (open_cells_decomposition _ _) => [[[[[fc cc] lcc] lc] le] he].
+case oca_eq: (opening_cells_aux _ _ _ _) => [nos lno].
+have := lex_left_pts_inf'; rewrite oe oca_eq => main.
+by move=> x xin; apply: lexePt_lexPt_trans lexq; apply: main.
+Qed.
+
+Lemma leftmost_points_max :
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  left_limit (start_open_cell bottom top) =
+  max (p_x (left_pt bottom)) (p_x (left_pt top)).
+Proof.
+rewrite /start_open_cell/generic_trajectories.start_open_cell /leftmost_points => /andP[] /=.
+rewrite R_ltb_lt.
+case: ltrP => cmpl.
+  rewrite -/(vertical_intersection_point _ _).
+  case peq: (vertical_intersection_point (left_pt top) bottom) => [p' | //].
+  move=> _ /andP[] samex _ /=.
+  move: peq.
+  rewrite /vertical_intersection_point/generic_trajectories.vertical_intersection_point.
+  by case: ifP=> // ve [] <-.
+rewrite -/(vertical_intersection_point _ _).
+case peq: (vertical_intersection_point (left_pt bottom) top)=> [p' | //] _.
+by case: ifP=> [/eqP A | B]; move=> /andP[].
+Qed.
+
+Lemma trial1 c1 c2 :
+  below_alt (high c1) (low c2) ->
+  open_cell_side_limit_ok c1 ->
+  open_cell_side_limit_ok c2 ->
+  valid_edge (high c1) (point e) ->
+  valid_edge (low c2) (point e) ->
+  pvert_y (point e) (high c1) < pvert_y (point e) (low c2) ->
+  o_disjoint c1 c2.
+Proof.
+move=> noc12 ok1 ok2 vhc1 vlc2 cmpc1c2 q; apply/andP=>-[].
+move=> /andP[]inc1 _ /andP[] inc2 /andP[] str2 _.
+have /andP[_ vhc1q] := inside_open_cell_valid ok1 inc1.
+have /andP[vlc2q _] := inside_open_cell_valid ok2 inc2.
+move: (inc1)=> /andP[] /andP[] _ qh1 _.
+have := transport_above_edge noc12 vhc1 vlc2 vhc1q vlc2q cmpc1c2 str2.
+rewrite /point_under_edge.
+by rewrite qh1.
+Qed.
+
+Lemma trial2 c1 c2 :
+  high c1 <| low c2 ->
+  open_cell_side_limit_ok c1 ->
+  open_cell_side_limit_ok c2 ->
+  valid_edge (high c1) (point e) ->
+  valid_edge (low c2) (point e) ->
+  o_disjoint c1 c2.
+Proof.
+move=> c1bc2 ok1 ok2 v1 v2 q; apply/negP=> /andP[].
+move=>/andP[] /andP[] /andP[] _ qbh1 /andP[] _ inx /andP[] _ stricterx.
+have inx' : left_limit c1 < p_x q <= open_limit c1.
+  by rewrite stricterx inx.
+move: inx' {inx stricterx} => /(valid_high_limits ok1) vqhc1.
+move=>/andP[] /andP[] _ /andP[] _ inx /andP[] qalc2 stricterx.
+have inx' : left_limit c2 < p_x q <= open_limit c2.
+  by rewrite stricterx inx.
+move: inx' {inx stricterx} => /(valid_low_limits ok2) vqlc2.
+rewrite (under_pvert_y vqlc2) -ltNge in qalc2.
+rewrite -/(point_under_edge _ _) in qbh1.
+rewrite (under_pvert_y vqhc1) in qbh1.
+have /pvert_y_edge_below : pvert_y q (low c2) < pvert_y q (high c1).
+  by apply: (lt_le_trans qalc2 qbh1).
+by move=> /(_ vqlc2 vqhc1) /negP; apply.
+Qed.
+
+Lemma lexPt_left_pt_strict_under_edge_to_p_x (pt : pt) g:
+  valid_edge g pt -> lexPt (left_pt g) pt -> pt <<< g ->
+  p_x (left_pt g) < p_x pt.
+Proof.
+move=> vg.
+rewrite /lexPt eq_sym=> /orP[ | /andP[] /eqP samex]; first by [].
+have := same_pvert_y vg samex.
+rewrite (on_pvert (left_on_edge g))=> <-.
+rewrite ltNge le_eqVlt negb_or andbC.
+by move=> /[swap]; rewrite strict_under_pvert_y // => ->.
+Qed.
+
+Lemma pvert_y_right_pt (g : edge) : pvert_y (right_pt g) g = p_y (right_pt g).
+Proof. apply/on_pvert/right_on_edge. Qed.
+
+Lemma inside_box_sorted_le :
+  sorted <=%R [seq pvert_y (point e) (high c) | c <- extra_bot :: open].
+Proof.
+have adj' : adjacent_cells (extra_bot :: open).
+  rewrite /=; move: cbtom=> /andP[] /andP[]; case: (open) adj => // o1 os + _.
+  by move=> /= -> /eqP ->; rewrite eqxx.
+apply adjacent_right_form_sorted_le_y => //=.
+  rewrite andbb; apply/andP; split=> //.
+  by apply: (inside_box_valid_bottom_top inbox_e)=> //; rewrite inE eqxx.
+by rewrite edge_below_refl.
+Qed.
+
+Lemma head_cat [T : eqType] (s1 s2 : seq T) (a : T):
+   s1 != nil -> head a (s1 ++ s2) = head a s1.
+Proof. by case : s1 => [ | b s1]. Qed.
+
+(* This is not used, just now. *)
+Lemma left_limit_closing_cells (cc : seq cell) (p1 : pt) :
+  adjacent_cells cc -> seq_valid cc p1 ->
+  p1 >>> low (head_cell cc) -> p1 <<< high (last_cell cc) ->
+  all (contains_point p1) cc ->
+  [seq left_limit i | i <- closing_cells p1 cc] = [seq left_limit i | i <- cc].
+Proof.
+move=> adjcc svalcc pale puhe allcont.
+rewrite /closing_cells.
+rewrite -map_comp; rewrite -eq_in_map /close_cell => -[] ls rs lo hi cin /=.
+move: (allP svalcc _ cin) => /= /andP[] vloc vhic.
+by rewrite (pvertE vloc) (pvertE vhic).
+Qed.
+
+Definition set_right_pts (c : cell) (l : seq pt) :=
+  Bcell (left_pts c) l (low c) (high c).
+
+Lemma inside_closed_set_right_pts (c : cell) l q:
+  last dummy_pt (right_pts c) = last dummy_pt l ->
+  inside_closed' q c = inside_closed' q (set_right_pts c l).
+Proof.
+rewrite /inside_closed' /set_right_pts /inside_closed_cell /contains_point /=.
+by rewrite /right_limit /= => ->.
+Qed.
+
+Lemma update_closed_cell_keeps_right_limit c pt :
+  (1 < size (right_pts c))%N ->
+  closed_cell_side_limit_ok c ->
+  right_limit (update_closed_cell c pt) =
+  right_limit c.
+Proof.
+move=> non_empty.
+do 5 move=> /andP[_]; move=> /andP[ptsn0 /andP[/allP allx _]].
+rewrite /update_closed_cell /right_limit /=.
+move: non_empty.
+by case: (right_pts c) => [ | hr [ | r2 rpts]].
+Qed.
+
+Lemma inside_closed'_update q1 q:
+  inside_closed' q lstc = inside_closed' q (update_closed_cell lstc q1).
+Proof.
+have samer : last dummy_pt (right_pts lstc) =
+             last dummy_pt (head dummy_pt (right_pts lstc) :: q1 ::
+                  (behead (right_pts lstc))).
+  move: non_empty_right.
+  by case : (right_pts lstc) => [ // | hr [ // | r2 rpts]].
+rewrite /update_closed_cell.
+have := inside_closed_set_right_pts q samer.
+rewrite /set_right_pts /=.
+by rewrite /set_right_pts /= => <- //.
+Qed.
+
+Definition update_pts_head (l : seq pt) (p : pt) :=
+  p :: behead l.
+
+Definition update_pts_single (l : seq pt) (p : pt) :=
+  head dummy_pt l :: p :: behead l.
+
+Lemma update_open_cell_outgoing_empty c (lo : seq cell * cell) :
+ valid_edge (low c) (point e) ->
+ valid_edge (high c) (point e) ->
+ open_cell_side_limit_ok c ->
+ p_x (point e) = left_limit c ->
+ (1 < size (left_pts c))%N ->
+ point e >>> low c ->
+ point e <<< high c ->
+outgoing e = [::] ->
+  update_open_cell c e =
+  ([::], set_left_pts
+    c (update_pts_single (left_pts c) (point e))).
+Proof.
+intros vl vh okc xq lptsgt pal puh ogq.
+by rewrite /update_open_cell/generic_trajectories.update_open_cell ogq.
+Qed.
+
+Lemma update_open_cell_tail c (lo : seq cell * cell) :
+ valid_edge (low c) (point e) ->
+ valid_edge (high c) (point e) ->
+ open_cell_side_limit_ok c ->
+ p_x (point e) = left_limit c ->
+ (1 < size (left_pts c))%N ->
+ point e >>> low c ->
+ point e <<< high c ->
+  outgoing e != [::] ->
+  behead (rcons (update_open_cell c e).1
+               (update_open_cell c e).2) =
+  behead (opening_cells (point e) (outgoing e) (low c) (high c)).
+Proof.
+move=> vl vh cok at_x lgt1 pal puh on0.
+rewrite /update_open_cell/generic_trajectories.update_open_cell.
+case ogq : (outgoing e) => [ | fog ogs]; first by rewrite ogq in on0.
+case oca_eq : generic_trajectories.opening_cells_aux => [nos lno].
+have son0 : (fog :: ogs) != [::] by [].
+have oute2 : {in fog :: ogs,
+      forall g, left_pt g == point e}.
+  by rewrite -ogq.
+have := opening_cells_aux_absurd_case vl vh son0 oute2.
+rewrite /opening_cells_aux oca_eq /=.
+case nosq : nos => [ | fno nos']; first by [].
+move=> _ /=.
+by rewrite /opening_cells/opening_cells_aux oca_eq nosq.
+Qed.
+
+Lemma update_open_cellE1 c c1 :
+ valid_edge (low c) (point e) ->
+ valid_edge (high c) (point e) ->
+ open_cell_side_limit_ok c ->
+ p_x (point e) = left_limit c ->
+ (1 < size (left_pts c))%N ->
+ point e >>> low c ->
+ point e <<< high c ->
+ c1 \in (update_open_cell c e).1 ->
+ exists2 c', c' \in (opening_cells_aux (point e)
+                        (sort (@edge_below _) (outgoing e)) (low c)
+    (high c)).1 &
+     c1 = c' \/
+     exists2 l, last dummy_pt l = last dummy_pt (left_pts c') &
+     c1 = set_left_pts c' l.
+Proof.
+move=> vle vhe cok xcond sl pal puh.
+rewrite /update_open_cell/generic_trajectories.update_open_cell.
+case ogq : (outgoing e) => [ | fog ogs] //=.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [ [// | fno nos] lno] /=.
+rewrite inE => /orP[/eqP -> | ].
+  exists fno; first by rewrite inE eqxx.
+  right; exists (point e :: behead (left_pts c)).
+    case lptsq : (left_pts c) sl => [ // | p1 [ // | p2 lpts]] _ /=.
+    move: cok; rewrite /open_cell_side_limit_ok=> /andP[] _ /andP[] allx.
+    move=> /andP[] _ /andP[] _; rewrite lptsq /=.
+    have oute2 : {in (fog :: ogs),
+        forall g, left_pt g == point e}.
+      by rewrite -ogq; exact oute.
+    have oute3 : {in sort (@edge_below _) (fog :: ogs),
+        forall g, left_pt g == point e}.
+      by move=> g; rewrite mem_sort; apply: oute2.
+    have := opening_cells_side_limit vle vhe (underWC pal) puh oute2.
+    rewrite /opening_cells oca_eq=> /allP /(_ fno).
+    rewrite inE eqxx=> /(_ isT)=> /andP[] _ /andP[] _ /andP[] _ /andP[] _.
+    have := opening_cells_first_left_pts (high c) vle _ pal.
+    rewrite ogq oca_eq => /(_ isT) /= -> /=.
+    have [_ /= ] := adjacent_opening_aux vle vhe oute3 oca_eq => ->.
+    rewrite /=.
+    move=> /on_edge_same_point /[apply] /=.
+    rewrite xcond /left_limit lptsq /= => /(_ erefl) ->.
+    by apply/(@eqP pt); rewrite pt_eqE /= !eqxx.
+  by [].
+move=> c1in; exists c1; first by rewrite inE c1in orbT.
+by left.
+Qed.
+
+Lemma update_open_cellE2 c :
+ valid_edge (low c) (point e) ->
+ valid_edge (high c) (point e) ->
+ open_cell_side_limit_ok c ->
+ p_x (point e) = left_limit c ->
+ (1 < size (left_pts c))%N ->
+ point e >>> low c ->
+ point e <<< high c ->
+ (update_open_cell c e).2 =
+ (opening_cells_aux (point e) (sort (@edge_below _) (outgoing e)) (low c)
+    (high c)).2 \/
+  (update_open_cell c e).2 =
+  (set_left_pts c (head dummy_pt
+       (left_pts c) :: point e :: behead (left_pts c))).
+Proof.
+move=> vle vhe cok xcond sl pal puh.
+rewrite /update_open_cell/generic_trajectories.update_open_cell.
+case ogq : (outgoing e)=> [ | fog ogs]; first by right.
+left; rewrite -ogq.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [ [ | fno nos] lno] //=.
+have ognn : outgoing e != [::] by rewrite ogq.
+have := opening_cells_aux_absurd_case vle vhe ognn oute.
+by rewrite oca_eq.
+Qed.
+
+Lemma inside_open'_set_pts (c : cell) l1 l2 q :
+   last dummy_pt l1 = last dummy_pt (left_pts c) ->
+   inside_open' q c = inside_open' q (set_pts c l1 l2).
+Proof.
+move=> same_lim.
+rewrite /inside_open' /inside_open_cell /contains_point /left_limit /=.
+by rewrite same_lim.
+Qed.
+
+Lemma oc_disjoint_set_left_pts c1 c2 l :
+  last dummy_pt l = last dummy_pt (left_pts c1) ->
+  oc_disjoint c1 c2 ->
+  oc_disjoint (set_left_pts c1 l) c2.
+Proof.
+move=> eql ref q.
+rewrite -inside_open'_set_pts; last by apply/esym.
+exact: (ref q).
+Qed.
+
+Let step_keeps_disjoint_default' :=
+  step_keeps_disjoint_default disjoint_open_closed disjoint_closed
+  closed_right_limit.
+
+Lemma appE {T : Type} (l1 l2 : seq T) : app l1 l2 = cat l1 l2.
+Proof. by elim: l1 => [ | a l1 /= ->]. Qed.
+
+Lemma step_keeps_disjoint :
+  let s' := step (Bscan fop lsto lop cls lstc lsthe lstx) e in
+  {in state_closed_seq  s' &, disjoint_closed_cells R} /\
+  {in state_open_seq s' & state_closed_seq s',
+    disjoint_open_closed_cells R}.
+Proof.
+rewrite /step/=/generic_trajectories.simple_step.
+case: ifP=> [pxaway |/negbFE/eqP /[dup] pxhere /abovelstle palstol].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe : (open_cells_decomposition open (point e)) =>
+     [[[[[fc  cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  rewrite /state_closed_seq /state_open_seq /=.
+  rewrite -[X in rcons X _]cat_rcons rcons_cat /=.
+  have := step_keeps_disjoint_default'; rewrite oe oca_eq /=.
+  move=> [] A B; split;[apply: A | ].
+  by rewrite -catA; apply: B.
+case: ifP=> [eabove | ebelow].
+rewrite -/(open_cells_decomposition _ _).
+case oe : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  have eabove' : point e >>> low (head dummy_cell lop).
+    have llopq : low (head dummy_cell lop) = lsthe.
+      apply: esym; rewrite lstheq.
+      move: (exi' eabove)=> [w + _].
+      move: adj=> /adjacent_catW[] _.
+      by case: (lop) => [ // | ? ?] /andP[] /eqP.
+    by rewrite llopq.
+  have oe' :
+    open_cells_decomposition open (point e) =
+     (rcons fop lsto ++ fc', cc, lcc, lc, le, he).
+    move: adj rfo sval; rewrite /open -cat_rcons=> adj' rfo' sval'.
+    move: (open_cells_decomposition_cat adj' rfo' sval' (exi' eabove)).
+    by rewrite oe; apply.
+  have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe' exi.
+  have [pal puh vle vhe _]:=
+   decomposition_connect_properties rfo sval adj cbtom bet_e oe'.
+  rewrite /state_open_seq /state_closed_seq /= rcons_cat.
+  rewrite !appE.
+  rewrite -(cat_rcons lsto) -catA -(cat_rcons lno).
+  have := step_keeps_disjoint_default'.
+  by rewrite oe' oca_eq /= -(cat_rcons lno) -(cat_rcons lstc).
+case: ifP => [ebelow_st {ebelow} | eonlsthe].
+  rewrite -/(open_cells_decomposition _ _).
+  have oe : open_cells_decomposition open (point e) =
+          (fop, [::], lsto, lop, low lsto, high lsto).
+    by rewrite open_cells_decomposition_single=> //; rewrite -lstheq.
+  have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+  rewrite /state_open_seq /state_closed_seq /=.
+  rewrite -/(update_open_cell _ _).
+  case uoc_eq : (update_open_cell lsto e) => [nos lno] /=.
+  split.
+    have lstcn : lstc \notin cls.
+      by move: uniq_closed; rewrite rcons_uniq=> /andP[].
+    have lstcin : lstc \in rcons cls lstc by rewrite mem_rcons inE eqxx.
+    have in' c : c \in cls -> c \in rcons cls lstc.
+      by move=> cin; rewrite mem_rcons inE cin orbT.
+    have main c1 q:
+         c_disjoint c1 lstc ->
+         c_disjoint c1 (update_closed_cell lstc q).
+      by move=> /[swap] q1 /(_ q1); rewrite -inside_closed'_update.
+    move=> c1 c2; rewrite !mem_rcons !inE !(orbC _ (_ \in cls)).
+    move=>/orP[c1in | /eqP ->] /orP[c2in | /eqP ->]; last by left.
+        by apply: disjoint_closed; rewrite mem_rcons inE ?c1in ?c2in orbT.
+      right; apply: main; case: (disjoint_closed (in' _ c1in) lstcin)=> //.
+      by move: lstcn=> /[swap] <-; rewrite c1in.
+    apply: c_disjoint_eC; right; apply: main.
+    case: (disjoint_closed (in' _ c2in) lstcin)=> //.
+    by move: lstcn=> /[swap] <-; rewrite c2in.
+  have main c :
+     oc_disjoint c lstc ->
+     oc_disjoint c (update_closed_cell lstc (point e)).
+    by rewrite /oc_disjoint=> /[swap] q /(_ q); rewrite -inside_closed'_update.
+  have := step_keeps_disjoint_default'.
+  have lstok : open_cell_side_limit_ok lsto.
+    by apply: (allP open_side_limit); rewrite /open mem_cat /= inE eqxx orbT.
+  have pxo : p_x (point e) = left_limit lsto by rewrite -lstxq.
+  have slpts : (1 < size (left_pts lsto))%N.
+    by apply: size_left_lsto=> //; rewrite -lstheq; apply: underW.
+  have puh : point e <<< high lsto by rewrite -lstheq.
+  have := update_open_cellE1 vlo vho lstok pxo slpts palstol puh.
+  rewrite uoc_eq /=.
+  have := update_open_cellE2 vlo vho lstok pxo slpts palstol puh.
+  rewrite uoc_eq /=.
+  rewrite oe.
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos' lno'] /= helper2 helper1.
+  move=> [] _ helper3.
+  move=> c1 c2 c1in; rewrite mem_rcons inE => /orP[/eqP -> | ].
+    apply: main.
+    move: c1in; rewrite -!catA /= mem_cat=> /orP[c1f |].
+      apply: disjoint_open_closed; last by rewrite mem_rcons inE eqxx.
+      by rewrite /open mem_cat c1f.
+    rewrite mem_cat=> /orP[].
+      move=>/helper1 [c1' c1'in]=>- [-> | ].
+        by apply: helper3; rewrite !mem_cat ?mem_rcons ?c1'in ?inE ?eqxx ?orbT.
+      move=>[l lq ->] q.
+      suff -> : inside_open' q (set_left_pts c1' l) = inside_open' q c1'.
+        by apply: (helper3 c1' lstc _ _ q);
+            rewrite !mem_cat ?mem_rcons ?c1'in ?inE ?eqxx ?orbT.
+      by apply/esym/inside_open'_set_pts/esym.
+    rewrite inE=> /orP[/eqP -> | ].
+      case: helper2=> [ -> | -> ].
+        by apply: helper3; rewrite !mem_cat ?mem_rcons !inE !eqxx ?orbT.
+      set W := (set_left_pts _ _).
+      move=> q.
+      suff -> : inside_open' q W = inside_open' q lsto.
+        by apply: disjoint_open_closed;
+         rewrite ?mem_rcons ?mem_cat /= ?inE ?eqxx ?orbT.
+      apply/esym/inside_open'_set_pts.
+      have := size_left_lsto pxhere palstol (underW puh).
+      by case : (left_pts lsto) => [ | p1 [ | p2 lpts]].
+    move=> c1f.
+    by apply: disjoint_open_closed;
+         rewrite ?mem_cat ?mem_rcons ?inE ?c1f ?eqxx ?orbT.
+  move=> c2in.
+  move: c1in; rewrite -catA !mem_cat /= => /orP[c1f |].
+    by apply: disjoint_open_closed;
+       rewrite ?mem_cat ?mem_rcons ?inE ?c1f ?eqxx ?c2in ?orbT.
+  move=> /orP[/helper1 [c1' c1no'] |].
+    move=> [-> | [l lq -> q] ].
+      by apply: helper3; rewrite !(mem_rcons, mem_cat, inE) ?c1no' ?c2in ?orbT.
+    suff -> : inside_open' q (set_left_pts c1' l) = inside_open' q c1'.
+      by apply: helper3;
+           rewrite !(mem_cat, inE, mem_rcons) ?c1'in ?c2in ?c1no' ?orbT.
+    by apply/esym/inside_open'_set_pts/esym.
+  rewrite inE=> /orP[/eqP -> | ].
+    move: helper2=> [-> | ->].
+      by apply: helper3; rewrite !(mem_cat, mem_rcons, inE) ?eqxx ?c2in ?orbT.
+    set W := (set_left_pts _ _).
+    move=> q.
+    suff -> : inside_open' q W = inside_open' q lsto.
+      by apply: disjoint_open_closed;
+       rewrite ?mem_rcons ?mem_cat /= ?inE ?eqxx ?c2in ?orbT.
+    apply/esym/inside_open'_set_pts.
+    have := size_left_lsto pxhere palstol (underW puh).
+    by case : (left_pts lsto) => [ | p1 [ | p2 lpts]].
+  move=> c1f.
+  by apply: disjoint_open_closed;
+       rewrite ?mem_cat ?mem_rcons ?inE ?c1f ?c2in ?orbT.
+rewrite /generic_trajectories.update_open_cell_top.
+move : ebelow eonlsthe; rewrite lstheq=> /negbFE ebelow /negP/negP eonlsthe.
+have ponlsthe : point e === lsthe.
+  by rewrite lstheq; apply: under_above_on.
+have exi2 : exists2 c, c \in (lsto :: lop) &
+          contains_point' (point e) c.
+  exists lsto; first by rewrite inE eqxx.
+  by rewrite /contains_point' palstol /point_under_edge ebelow.
+case ogq : (outgoing e) => [ | fog og]; last first.
+  rewrite -/(open_cells_decomposition _ _).
+  case oe : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  have := open_cells_decomposition_cat adj rfo sval exi2 palstol.
+  rewrite oe=> oe'.
+  have lelow : le = low lsto.
+    move: oe; rewrite /open_cells_decomposition/generic_trajectories.open_cells_decomposition /=.
+    rewrite -/(contains_point _ _).
+    have -> : contains_point (point e) lsto.
+      by rewrite contains_pointE /point_under_edge ebelow underWC.
+    rewrite -/(open_cells_decomposition_contact _ _).
+    case : (open_cells_decomposition_contact _ _) => [[[a b] c] |] /=;
+      by move=> [] _ _ _ _ ->.
+  have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi2.
+  have [pal puh vle vhe _]:=
+   decomposition_connect_properties rfo sval adj cbtom bet_e oe'.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [[ | fno nos] lno].
+    have ognn : outgoing e != nil by rewrite ogq.
+    have:= opening_cells_aux_absurd_case vlo vhe ognn oute.
+    by rewrite ogq oca_eq /=.
+  rewrite /state_open_seq /state_closed_seq /=.
+  have := step_keeps_disjoint_default'; rewrite oe' ogq lelow oca_eq /=.
+  move=> [] clsdisj ocdisj.
+  split.
+    move=> x y xin yin; apply: clsdisj.
+      move: xin; rewrite !(mem_rcons, inE, mem_cat).
+      move=>/orP[-> | /orP[ | /orP[ ->| ->]]]; rewrite ?orbT //.
+      by case: (cc) => /= [// | ? ?]; rewrite !inE /= => ->; rewrite ?orbT.
+    move: yin; rewrite !(mem_rcons, inE, mem_cat).
+    move=>/orP[-> | /orP[ | /orP[ ->| ->]]]; rewrite ?orbT //.
+    by case: (cc) => /= [// | ? ?]; rewrite !inE /= => ->; rewrite ?orbT.
+  move=> x y.
+  rewrite !mem_cat !inE -!orbA !(orbCA _ (_ == set_left_pts _ _)).
+  move=>/orP[]; last first.
+    move=> xin yin; apply: ocdisj.
+      rewrite !(mem_cat, inE).
+      by move: xin=> /orP[-> | /orP[-> | ->]]; rewrite ?orbT //.
+    move: yin; rewrite !(mem_rcons, mem_cat, inE).
+    move=>/orP[-> | /orP[ | /orP[-> | ->] ]]; rewrite ?orbT //.
+    by case: (cc) => /= [// | ? ?]; rewrite !inE /= => ->; rewrite ?orbT.
+  move=> /eqP -> yin.
+  apply: oc_disjoint_set_left_pts; last first.
+    apply: ocdisj;[subset_tac | ].
+    move: yin; rewrite !(mem_cat, inE, mem_rcons).
+    move=> /orP[-> | /orP[ | /orP[-> | ->]]]; rewrite ?orbT //.
+    by case: (cc) => /= [// | ? ?]; rewrite !inE /= => ->; rewrite ?orbT.
+  have ognn : outgoing e != nil by rewrite ogq.
+  have slsto := size_left_lsto pxhere palstol ebelow.
+  have:= opening_cells_first_left_pts he vlo ognn palstol.
+  rewrite ogq oca_eq /= => -> /=.
+  move: slsto; case lptsq : (left_pts lsto) => [// | fp [// | sp lpts]] _ /=.
+  have : open_cell_side_limit_ok lsto.
+    by apply: (allP open_side_limit); rewrite /open mem_cat inE eqxx orbT.
+  move=> /andP[] _ /andP[] A /andP[] _ /andP[] _ onlow.
+  rewrite pxhere lstxq /left_limit lptsq /=.
+  apply/(@eqP pt); rewrite pt_eqE /= eqxx /= eq_sym; apply/eqP.
+  have -> : pvert_y (point e) (low lsto) = pvert_y (last sp lpts) (low lsto).
+    apply: same_pvert_y=> //.
+    by rewrite pxhere lstxq /left_limit lptsq.
+  by apply: on_pvert; move: onlow; rewrite lptsq.
+rewrite -/(open_cells_decomposition _ _).
+case oe : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+have := open_cells_decomposition_cat adj rfo sval exi2 palstol.
+rewrite oe /= => oe'.
+rewrite /state_closed_seq /state_open_seq /=.
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+  decomposition_main_properties oe' exi.
+have [pal puh vle vhe _]:=
+ decomposition_connect_properties rfo sval adj cbtom bet_e oe'.
+set nlsto := (X in (_ ++ X :: lc)).
+have lelow : le = low lsto.
+  move: oe; rewrite /open_cells_decomposition/generic_trajectories.open_cells_decomposition /=.
+  rewrite -/(contains_point _ _).
+  have -> : contains_point (point e) lsto.
+    by rewrite contains_pointE /point_under_edge ebelow underWC.
+  rewrite -/(open_cells_decomposition_contact _ _).
+  case : (open_cells_decomposition_contact _ _) => [[[a b] c] |] /=;
+    by move=> [] _ _ _ _ ->.
+have := step_keeps_disjoint_default'; rewrite oe' ogq lelow /=.
+rewrite -/(vertical_intersection_point _ _).
+rewrite pvertE // -/(vertical_intersection_point _ _) pvertE //=.
+have: Bpt (p_x (point e)) (pvert_y (point e) he) == point e :>pt = false.
+  apply/negP=> abs.
+  move: puh; rewrite strict_under_pvert_y // -[X in p_y X](eqP abs) /=.
+  by rewrite lt_irreflexive.
+have: point e == Bpt (p_x (point e)) (pvert_y (point e) (low lsto)) :> pt
+   = false.
+  apply/negP=> abs.
+  move: pal; rewrite under_pvert_y // lelow [X in p_y X](eqP abs) /=.
+  by rewrite le_eqVlt eqxx.
+do 2 rewrite -[pt_eqb _ _ _ _]/(_ == _ :> pt).
+move=> -> -> [] clcnd clopcnd.
+split.
+  move=> x y xin yin; apply: clcnd.
+    move: xin; rewrite !(mem_rcons, mem_cat, inE) orbCA=> /orP[]; last first.
+      by move=> /orP[->| /orP[] ->]; rewrite ?orbT.
+    by case: (cc) => //= a l; rewrite inE=> ->; rewrite ?orbT.
+  move: yin; rewrite !(mem_rcons, mem_cat, inE) orbCA=> /orP[]; last first.
+    by move=> /orP[->| /orP[] ->]; rewrite ?orbT.
+  by case: (cc) => //= a l; rewrite inE=> ->; rewrite ?orbT.
+rewrite cats0.
+move=> x y xin yin.
+have yin' : y \in cls ++ lstc :: rcons (closing_cells (point e) cc)
+                            (close_cell (point e) lcc).
+  move: yin; rewrite !(mem_rcons, mem_cat, inE) orbCA=> /orP[]; last first.
+    by move=> /orP[-> | /orP[] ->]; rewrite ?orbT.
+  by case: (cc) => //= ? ?; rewrite inE=> ->; rewrite ?orbT.
+move: xin; rewrite !(mem_cat, mem_rcons, inE)=> /orP[xin | ].
+  apply: clopcnd; first by rewrite !(mem_cat, mem_rcons, inE) xin.
+  by rewrite cat_rcons.
+move=>/orP[/eqP -> | xin]; last first.
+  apply: clopcnd.
+    by rewrite !(mem_cat, mem_rcons, inE) xin !orbT.
+  by rewrite cat_rcons.
+move=> q.
+move: clopcnd; set w := (X in _ ++ X :: _).
+have nlstoq : nlsto = set_pts w
+   (Bpt (p_x (point e)) (pvert_y (point e) he) :: left_pts lsto)
+   (right_pts lsto).
+   by rewrite /nlsto /generic_trajectories.pvert_y subrr.
+move=> clopcnd.
+rewrite nlstoq -inside_open'_set_pts.
+  apply: clopcnd.
+    by rewrite !(mem_cat, mem_rcons, inE) eqxx ?orbT.
+  by rewrite cat_rcons.
+rewrite /w /=.
+have /andP[] := allP open_side_limit lsto lstoin.
+case plstq : (left_pts lsto) => [ // | a l] _ /= /andP[] A /andP[] _ /andP[] _.
+move: lstxq; rewrite /left_limit plstq /= => sx one.
+apply/(@eqP pt); rewrite pt_eqE /= pxhere sx eqxx /=.
+rewrite -(on_pvert one).
+apply/eqP; apply: same_pvert_y; first by case/andP: one.
+by rewrite pxhere sx.
+Qed.
+
+Lemma opening_cells_subset' p' (le he : edge) (s sup : seq edge) :
+  le \in sup -> he \in sup -> {subset s <= sup} ->
+  valid_edge le p' -> valid_edge he p' ->
+  {in s, forall g, left_pt g == p'} ->
+  {subset cell_edges (opening_cells p' s le he) <= sup}.
+Proof.
+move=> lein hein ssub vl vh outp' /= g.
+have ocs := opening_cells_subset vl vh outp'.
+rewrite mem_cat=> /orP[] /mapP [/= c /[swap] + /ocs +] => <-.
+  by move=> /andP[] + _; rewrite inE=> /orP[/eqP -> // | ]; apply: ssub.
+by move=> /andP[] _; rewrite inE=> /orP[/eqP -> // | ]; apply: ssub.
+Qed.
+
+Lemma step_keeps_injective_high_default :
+  let '(fc, cc, lcc, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+    let '(nos, lno) :=
+      opening_cells_aux (point e)
+       (sort (@edge_below _) (outgoing e)) le he in
+    {in fc ++ nos ++ lno :: lc &, injective high}.
+Proof.
+  case oe : open_cells_decomposition => [[[[[fc cc] lcc] lc] le] he].
+  have [ocd [lcc_ctn [all_ct [all_nct [flcnct
+     [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe ncont]
+ := connect_properties cbtom adj rfo sval bet_e ocd all_nct all_ct
+  lcc_ctn flcnct.
+have dupcase c1 c2 : (c1 \in fc) || (c1 \in lc) ->
+   c2 \in opening_cells (point e) (outgoing e) le he ->
+   high c1 = high c2 -> c1 = c2.
+  move=> c1in; rewrite leq heq => c2in hc1c2.
+  have v1 : valid_edge (high c1) (point e).
+    move: sval=>/allP/(_ c1); rewrite ocd -cat_rcons !mem_cat orbCA c1in orbT.
+    by move=> /(_ isT) /andP[].
+  have v2 : valid_edge (high c2) (point e).
+    have /andP[ _ ] := opening_cells_subset vle vhe oute c2in.
+    rewrite inE=> /orP[/eqP -> // | ].
+    by have := opening_valid oute vle vhe => /allP /(_ _ c2in) /andP[].
+  have : point e <<< high c1 \/ point e >>> high c1.
+    move: c1in=> /orP[] c1in.
+      right.
+      by have := decomposition_above_high_fc oe cbtom adj bet_e rfo sval c1in.
+    left.
+    have [s1 [s2 lcq]] := mem_seq_split c1in.
+    case s2q : s2 => [ | c1' s2'].
+      move: inbox_e=> /andP[] /andP[] _ + _.
+      suff -> : high c1 = top by [].
+      move: cbtom=> /andP[] _ /eqP; rewrite ocd lcq s2q /=.
+      by rewrite !(last_cat, last_cons) /=.
+    have c1'in : c1' \in lc by rewrite lcq s2q mem_cat !inE eqxx !orbT.
+    have := decomposition_under_low_lc oe cbtom adj bet_e rfo sval c1'in.
+    suff -> : high c1 = low c1' by [].
+    move: adj; rewrite /adjacent_cells ocd=> /sorted_catW /andP[] _.
+    move=> /sorted_catW /andP[] _; rewrite lcq s2q.
+    by rewrite /= -cat_rcons cat_path last_rcons /= => /andP[] _ /andP[] /eqP.
+  have /andP[lows ] := opening_cells_subset vle vhe oute c2in.
+  rewrite inE => /orP[/eqP hc1he | ]; last first.
+    rewrite hc1c2 => /oute/eqP <-.
+    move=> [ | ].
+      rewrite strict_nonAunder; last first.
+        by apply valid_edge_extremities; rewrite eqxx ?orbT.
+      by rewrite left_on_edge.
+    rewrite under_onVstrict ?left_on_edge //.
+    by apply valid_edge_extremities; rewrite eqxx ?orbT.
+  have c1hec : c1 = lcc.
+    apply: high_inj.
+        by rewrite ocd -cat_rcons!mem_cat orbCA c1in orbT.
+      by rewrite ocd !(mem_cat, inE) eqxx !orbT.
+    by rewrite hc1c2.
+  have := ncont _ c1in.
+  by rewrite c1hec lcc_ctn.
+have henout : he \notin outgoing e.
+  apply/negP=> /oute /eqP abs.
+  have :=
+    bottom_left_lex_to_high cbtom adj rfo open_side_limit inbox_e btm_left.
+  move=> /(_ lcc); rewrite ocd !(mem_cat, inE) eqxx !orbT => /(_ isT).
+  by rewrite -heq abs lexPt_irrefl.
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+move=> c1 c2; rewrite -cat_rcons !mem_cat orbCA=> /orP[] c1in; last first.
+  rewrite orbCA=> /orP[] c2in; last first.
+    by apply: high_inj;
+      rewrite ocd -cat_rcons !mem_cat orbCA ?c1in ?c2in ?orbT.
+  by apply: (dupcase _ c2 c1in); rewrite /opening_cells oca_eq.
+rewrite orbCA=> /orP[] c2in; last first.
+  move/esym=> tmp; apply/esym; move: tmp.
+  by apply: (dupcase _ c1 c2in); rewrite /opening_cells oca_eq.
+have : uniq (rcons (sort (@edge_below _) (outgoing e)) he).
+  by rewrite rcons_uniq mem_sort henout sort_uniq.
+rewrite heq -(opening_cells_high vle vhe oute) => /uniq_map_injective; apply.
+all: rewrite /opening_cells -heq -leq oca_eq; by [].
+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 update_cells_injective_high l1 l2 l2' l3:
+  uniq (l1 ++ l2 ++ l3) ->
+  [seq high c | c <- l2] = [seq high c | c <- l2'] ->
+  {in l1 ++ l2 ++ l3 &, injective high} ->
+  {in l1 ++ l2' ++ l3 &, injective high}.
+Proof.
+move=> u2 eqh inj0 x1 x2; rewrite !mem_cat orbCA=> x1in.
+rewrite orbCA=> x2in hx1x2.
+move: x1in=> /orP[x1l2' | x1in]; last first.
+  move: x2in=> /orP[x2l2' | x2in]; last first.
+    by move: hx1x2; apply: inj0; rewrite !mem_cat orbCA ?x1in ?x2in ?orbT.
+  move: u2; rewrite uniq_catCA cat_uniq=> /andP[] _ /andP[] /negP abs _.
+  have : high x2 \in [seq high c | c <- l2].
+    by rewrite eqh; apply: map_f.
+  move=> /mapP[x20 x20in hx20].
+  rewrite -hx1x2 in hx20.
+  have x1x20: x1 = x20.
+    by apply: inj0; rewrite // ?mem_cat orbCA ?x20in ?x1in ?orbT.
+  case: abs; apply/hasP; exists x20=> //.
+  by rewrite -x1x20 mem_cat.
+move: x2in=> /orP[x2l2'| x2in]; last first.
+  move: u2; rewrite uniq_catCA cat_uniq=> /andP[] _ /andP[] /negP abs _.
+  have : high x1 \in [seq high c | c <- l2].
+    by rewrite eqh; apply: map_f.
+  move=> /mapP[x10 x10in hx10].
+  rewrite hx1x2 in hx10.
+  have x2x10: x2 = x10.
+    by apply: inj0; rewrite // !mem_cat orbCA ?x10in ?x2in ?orbT.
+  case: abs; apply/hasP; exists x10=> //.
+  by rewrite -x2x10 mem_cat.
+remember (index x1 l2') as j1 eqn:j1def.
+remember (index x2 l2') as j2 eqn:j2def.
+have inj2 : {in l2 &, injective high}.
+  by move=> u1 {}u2 uin1 uin2; apply: inj0; rewrite !mem_cat ?uin1 ?uin2 orbT.
+have ul2 : uniq l2.
+  by move: u2; rewrite !cat_uniq=> /andP[] _ /andP[] _ /andP[].
+have uh : uniq [seq high c | c <- l2].
+  by rewrite (map_inj_in_uniq inj2).
+have := nth_index dummy_cell x1l2'; rewrite -j1def => j1q.
+have := nth_index dummy_cell x2l2'; rewrite -j2def => j2q.
+have j1lt : (j1 < size l2')%N by rewrite j1def index_mem.
+have j2lt : (j2 < size l2')%N by rewrite j2def index_mem.
+have : nth (high dummy_cell) [seq high c | c <- l2'] j1 = high x1.
+  by rewrite (nth_map dummy_cell) // j1q.
+have : nth (high dummy_cell) [seq high c | c <- l2'] j2 = high x1.
+  by rewrite hx1x2 (nth_map dummy_cell) // j2q.
+move=> <-; rewrite -eqh.
+move: uh=> /uniqP => /(_ dummy_edge); rewrite [X in size X]eqh size_map.
+move=> /(_ j1 j2); rewrite !inE => /(_ j1lt j2lt) /[apply].
+by rewrite -j1q -j2q => ->.
+Qed.
+
+Lemma step_keeps_uniq_default fc cc lcc lc le he nos lno:
+  open_cells_decomposition open (point e) = (fc, cc, lcc, lc, le, he) ->
+  opening_cells_aux (point e)
+      (sort (@edge_below _) (outgoing e)) le he = (nos, lno) ->
+  uniq (fc ++ nos ++ lno :: lc).
+Proof.
+move=> oe oca_eq.
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe old_nctn]:=
+   decomposition_connect_properties rfo sval adj cbtom bet_e oe.
+have := opening_cells_contains_point vle vhe pal puh oute.
+rewrite /opening_cells oca_eq => /(_ _ erefl)=> new_ctn.
+have uo : uniq (sort (@edge_below _) (outgoing e)) by rewrite sort_uniq.
+have heno : he \notin (sort (@edge_below _) (outgoing e)).
+  apply/negP=> /oute'/eqP; move: puh=> /[swap] <-.
+  by rewrite (negbTE (left_pt_above he)).
+have uniqnew := opening_cells_aux_uniq uo heno oute' vle vhe oca_eq.
+rewrite -cat_rcons uniq_catCA cat_uniq uniqnew.
+move: uniq_open; rewrite ocd -cat_rcons uniq_catCA cat_uniq=> /andP[] _.
+move=>/andP[] _ ->; rewrite andbT /= -all_predC /=.
+apply/allP=> x /=; rewrite mem_cat=> /old_nctn nctn.
+by apply/negP=> /new_ctn/nctn.
+Qed.
+
+Lemma step_keeps_injective_high :
+  let s' := step (Bscan fop lsto lop cls lstc lsthe lstx) e in
+  {in state_open_seq s' &, injective high}.
+Proof.
+rewrite /step/=/generic_trajectories.simple_step.
+case: ifP=> [pxaway |/negbFE/eqP /[dup] pxhere /abovelstle palstol].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe : (open_cells_decomposition open (point e)) =>
+     [[[[[fc  cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  rewrite /state_closed_seq /state_open_seq /=.
+  have := step_keeps_injective_high_default; rewrite oe oca_eq /=.
+  by rewrite catA.
+case: ifP=> [eabove | ebelow].
+rewrite -/(open_cells_decomposition _ _).
+case oe : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  have eabove' : point e >>> low (head dummy_cell lop).
+    have llopq : low (head dummy_cell lop) = lsthe.
+      apply: esym; rewrite lstheq.
+      move: (exi' eabove)=> [w + _].
+      move: adj=> /adjacent_catW[] _.
+      by case: (lop) => [ // | ? ?] /andP[] /eqP.
+    by rewrite llopq.
+  have oe' :
+    open_cells_decomposition open (point e) =
+     (rcons fop lsto ++ fc', cc, lcc, lc, le, he).
+    move: adj rfo sval; rewrite /open -cat_rcons=> adj' rfo' sval'.
+    move: (open_cells_decomposition_cat adj' rfo' sval' (exi' eabove)).
+    by rewrite oe; apply.
+  have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe' exi.
+  have [pal puh vle vhe _]:=
+   decomposition_connect_properties rfo sval adj cbtom bet_e oe'.
+  rewrite /state_open_seq.
+  rewrite appE.
+  rewrite -(cat_rcons lsto) -catA -(cat_rcons lno).
+  have := step_keeps_injective_high_default.
+  by rewrite oe' oca_eq /= !catA -cat_rcons.
+case: ifP => [ebelow_st {ebelow} | eonlsthe].
+  have oe : open_cells_decomposition open (point e) =
+          (fop, [::], lsto, lop, low lsto, high lsto).
+    by rewrite open_cells_decomposition_single=> //; rewrite -lstheq.
+  have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+  rewrite /state_open_seq /=.
+  rewrite -/(update_open_cell _ _).
+  case uoc_eq : (update_open_cell _ _) => [nos lno] /=.
+  rewrite -catA -cat_rcons.
+  move: uoc_eq; rewrite /update_open_cell/generic_trajectories.update_open_cell.
+  case ogq : (outgoing e) => [ | fog ogs].
+    move=> [] <- <-; rewrite [rcons _ _]/=.
+    have uniqlsto : uniq (fop ++ [:: lsto] ++ lop).
+      by move: uniq_open; rewrite /open.
+    set w := (X in fop ++ X ++ lop).
+    have samehigh: [seq high c | c <- [:: lsto]] = [seq high c | c <- w] by [].
+    by apply: (update_cells_injective_high uniqlsto samehigh).
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [[ | fno nos'] lno'].
+    have ogn : outgoing e != [::] by rewrite ogq.
+    have := opening_cells_aux_absurd_case vlo vho ogn oute.
+    by rewrite ogq oca_eq.
+  move=> [] <- <-.
+  have := step_keeps_injective_high_default.
+  rewrite oe ogq oca_eq -cat_rcons.
+  apply: update_cells_injective_high.
+    have := step_keeps_uniq_default oe; rewrite ogq=> /(_ _ _ oca_eq).
+    by rewrite cat_rcons catA.
+  by rewrite !map_rcons.
+case oe': open_cells_decomposition => [[[[[fc' cc'] lcc'] lc'] le'] he'].
+have lsto_ctn : contains_point' (point e) lsto.
+  rewrite /contains_point' palstol -lstheq.
+  by move: ebelow=> /negbT; rewrite negbK.
+have exi2 : exists2 c, c \in lsto :: lop & contains_point' (point e) c.
+  by exists lsto; [rewrite inE eqxx | ].
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe' exi2.
+rewrite /update_open_cell_top/generic_trajectories.update_open_cell_top.
+rewrite -/(open_cells_decomposition _ _) oe'.
+case ogq : (outgoing e) => [ | fog ogs] /=.
+  rewrite /state_open_seq /= cats0 -cat1s.
+  have : {in fop ++ fc' ++ [:: lcc'] ++ lc' &, injective high}.
+    have subtmp : {subset fop ++ fc' ++ lcc' :: lc' <= open}.
+      move=> x; rewrite /open ocd !(mem_cat, inE).
+      repeat (move=> /orP[ -> | ]; rewrite ?orbT //).
+      by move=> ->; rewrite ?orbT.
+    by move=> x y xin yin; apply: high_inj; apply: subtmp.
+  rewrite catA.
+  apply: update_cells_injective_high.
+    rewrite cat_uniq; move: uniq_open; rewrite /open ocd catA.
+    rewrite [X in is_true X -> _]cat_uniq=> /andP[] -> /= /andP[].
+    rewrite has_cat negb_or => /andP[] _ /= => ->.
+    by rewrite [X in is_true X -> _]cat_uniq => /andP[] _ /andP[] _.
+  by rewrite /= heq.
+have := open_cells_decomposition_cat adj rfo sval exi2 palstol.
+rewrite oe' => oe.
+have [pal puh vle vhe _]:=
+   decomposition_connect_properties rfo sval adj cbtom bet_e oe.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [ [ | fno nos] lno].
+  have ogn : fog :: ogs != nil by [].
+  have := opening_cells_aux_absurd_case vlo vhe ogn.
+  by rewrite -[X in {in X, _}]ogq oca_eq => /(_ oute).
+rewrite /state_open_seq /= !catA -(catA (_ ++ _)) -cat_rcons.
+have := step_keeps_injective_high_default.
+rewrite oe ogq.
+have le'q : le' = low lsto.
+  have := last_step_situation oe' pxhere.
+  rewrite -/(point_strictly_under_edge _ _) in eonlsthe.
+  rewrite eonlsthe=> /(_ isT).
+  move: ebelow=> /negbT.
+  rewrite -/(point_under_edge _ _).
+  by rewrite negbK=> -> /(_ isT)[] + [].
+rewrite le'q oca_eq -cat_rcons.
+apply: update_cells_injective_high=> //.
+have := step_keeps_uniq_default oe; rewrite ogq le'q=> /(_ _ _ oca_eq).
+by rewrite cat_rcons !catA.
+Qed.
+
+(* TODO : understand why closing_cells_to_the_left seems to use too many
+   hypotheses, once out of the section. *)
+Lemma closing_cells_to_the_left fc cc lcc lc le he :
+  open_cells_decomposition open (point e) = (fc, cc, lcc, lc, le, he) ->
+  {in closing_cells (point e) cc, forall c, right_limit c <= p_x (point e)} /\
+  right_limit (close_cell (point e) lcc) <= p_x (point e).
+Proof.
+move=> oe.
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe _]:=
+  decomposition_connect_properties rfo sval adj cbtom bet_e oe.
+split; last first.
+  have vlolcc : valid_edge (low lcc) (point e).
+    apply: (proj1 (andP (allP sval lcc _))).
+    by rewrite ocd !(mem_cat, inE) eqxx ?orbT.
+  rewrite /close_cell (pvertE vlolcc).
+  rewrite -heq (pvertE vhe) /right_limit /=.
+  by case: ifP; case: ifP.
+move=> c /mapP[c' c'in ->].
+have c'in2 : c' \in open by rewrite ocd !mem_cat c'in ?orbT.
+have /andP[vlc vhc] := allP sval c' c'in2.
+rewrite /close_cell (pvertE vlc) (pvertE vhc) /=.
+by case: ifP; case: ifP.
+Qed.
+
+Lemma step_keeps_closed_to_the_left :
+  let s' := step (Bscan fop lsto lop cls lstc lsthe lstx) e in
+  {in state_closed_seq s', forall c, right_limit c <= p_x (point e)}.
+Proof.
+rewrite /step/=/generic_trajectories.simple_step.
+case: ifP => [pxaway | /negbFE/eqP/[dup] pxhere /abovelstle palstol].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe : (open_cells_decomposition _ _) => [[[[[fc cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  rewrite /state_closed_seq /=.
+  have [ccP lccP] := closing_cells_to_the_left oe.
+  move=> x; rewrite mem_rcons inE => /orP[/eqP -> // | ].
+  by rewrite appE -cat_rcons mem_cat => /orP[/closed_right_limit | /ccP].
+case: ifP=> [eabove | ebelow].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe' : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  have eabove' : point e >>> low (head dummy_cell lop).
+    have llopq : low (head dummy_cell lop) = lsthe.
+      apply: esym; rewrite lstheq.
+      move: (exi' eabove)=> [w + _].
+      move: adj=> /adjacent_catW[] _.
+      by case: (lop) => [ // | ? ?] /andP[] /eqP.
+    by rewrite llopq.
+  move: adj rfo sval; rewrite /open -cat_rcons => adj' rfo' sval'.
+  have := open_cells_decomposition_cat adj' rfo' sval' (exi' eabove) eabove'.
+  rewrite oe' cat_rcons => oe.
+  have [ccP lccP] := closing_cells_to_the_left oe.
+  rewrite /state_closed_seq /=.
+  move=> x; rewrite mem_rcons inE => /orP[/eqP -> // | ].
+  by rewrite appE -cat_rcons mem_cat => /orP[ /closed_right_limit | /ccP].
+case: ifP => [ebelow_st {ebelow} | eonlsthe].
+  rewrite -/(update_open_cell _ _).
+  case uoc_eq : (update_open_cell _ _) => [nos lno].
+  rewrite /state_closed_seq /=.
+  move=> x; rewrite mem_rcons inE => /orP[/eqP -> | ].
+    rewrite update_closed_cell_keeps_right_limit //; last first.
+      by apply: (allP close_side_limit); rewrite mem_rcons inE eqxx.
+    by apply: closed_right_limit; rewrite mem_rcons inE eqxx.
+  move=> xin.
+  suff /closed_right_limit : x \in rcons cls lstc by [].
+  by rewrite mem_rcons inE xin orbT.
+rewrite -/(open_cells_decomposition _ _).
+case oe' : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+rewrite -/(update_open_cell_top lsto _ e).
+case uoct_eq : (update_open_cell_top lsto _ _) => [nos lno].
+have exi2 : exists2 c, c \in (lsto :: lop) &
+          contains_point' (point e) c.
+  exists lsto; first by rewrite inE eqxx.
+  by rewrite /contains_point' palstol -lstheq /point_under_edge (negbFE ebelow).
+have := open_cells_decomposition_cat adj rfo sval exi2 palstol.
+rewrite -/(open_cells_decomposition _ _).
+rewrite oe' => oe.
+rewrite /state_closed_seq /=.
+have [ccP lccP] := closing_cells_to_the_left oe.
+move=> x; rewrite mem_rcons inE => /orP[/eqP ->|]; first by [].
+rewrite mem_cat=> /orP[xin | ].
+  have /ccP // : x \in closing_cells (point e) cc.
+  by move/mapP: xin=> [] x' x'in ->; apply/map_f/mem_behead.
+by rewrite -mem_rcons; apply: closed_right_limit.
+Qed.
+
+Lemma contains_right (c : cell) :
+  c \in open ->  right_pt (high c) = point e -> contains_point (point e) c.
+Proof.
+move=> cino rq.
+have /andP[vlc vhc] := allP sval c cino.
+apply/andP; split; last first.
+ rewrite -/(point_under_edge _ _).
+  by rewrite under_onVstrict // -rq right_on_edge.
+apply/negP=> abs.
+have bl := allP rfo c cino.
+have := order_edges_strict_viz_point vlc vhc bl abs.
+by rewrite (strict_nonAunder vhc) -rq right_on_edge.
+Qed.
+
+Lemma inbox_lexePt_right_bt g pt:
+  inside_box pt ->
+  g \in [:: bottom; top] -> lexePt pt (right_pt g).
+Proof.
+rewrite !inE /inside_box /lexePt.
+by move=> /andP[] _ /andP[] /andP[] _ lb /andP[] _ lt /orP[] /eqP ->;
+  rewrite ?lt ?lb.
+Qed.
+
+Lemma inside_box_lexPt_bottom pt :
+  inside_box pt -> lexPt (left_pt bottom) pt && lexPt pt (right_pt bottom).
+Proof.
+by move=> /andP[] _ /andP[] /andP[] lp pr  _; rewrite /lexPt lp pr.
+Qed.
+
+Lemma inside_box_lexPt_top pt :
+  inside_box pt -> lexPt (left_pt top) pt && lexPt pt (right_pt top).
+Proof.
+by move=> /andP[] _ /andP[]  _ /andP[] lp pr; rewrite /lexPt lp pr.
+Qed.
+
+Lemma step_keeps_lex_edge_default :
+  let '(fc, cc, lcc, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+    let '(nos, lno) := opening_cells_aux (point e)
+       (sort (@edge_below _) (outgoing e)) le he in
+   forall e', inside_box (point e') -> lexPtEv e e' ->
+               (forall e2, e2 \in future_events -> lexePtEv e' e2) ->
+   {in [seq high c | c <- fc ++ nos ++ lno :: lc], forall g,
+       lexPt (left_pt g) (point e') && lexePt (point e') (right_pt g)}.
+Proof.
+case oe : (open_cells_decomposition _ _) =>
+ [[[[[fc cc] lcc] lc] le] he].
+case oca_eq:(opening_cells_aux _ _ _ _) => [nos nlsto].
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vl vp nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+      (inside_box_between inbox_e) oe.
+move=> e' inbox_e' ee' e'fut g.
+rewrite !map_cat !mem_cat.
+have old:  (g \in [seq high c | c <- fc]) || (g \in [seq high c | c <- lc]) ->
+   lexPt (left_pt g) (point e') && lexePt (point e') (right_pt g).
+  move=> gin; apply/andP; split.
+    have /lexPt_trans : lexPt (left_pt g) (point e).
+      have /lex_open_edges /andP[] // : g \in [seq high c | c <- open].
+      rewrite ocd !map_cat !mem_cat map_cons inE.
+      by move: gin => /orP[ | ] ->; rewrite ?orbT.
+    by apply.
+  have /mapP [c cin gq] : g \in [seq high c | c <- fc ++ lc].
+    by rewrite map_cat mem_cat.
+  have cino : c \in open.
+    by move: cin; rewrite ocd !mem_cat /= inE=> /orP[] ->; rewrite ?orbT.
+  move : (allP clae _ cino)=> /andP[] _; rewrite /end_edge.
+  move=> /orP[ /(inbox_lexePt_right_bt inbox_e') | ]; first by rewrite gq.
+  rewrite -gq; move=> /hasP [e2 e2in /eqP /[dup] e2P ->].
+  apply: e'fut.
+  move: e2in; rewrite inE => /orP[/eqP e2e | ]; last by [].
+  move: (cin); rewrite mem_cat => /nc [].
+  by apply: contains_right; rewrite // -e2e -gq.
+move=> /orP[oldf |]; first by apply: old; rewrite oldf.
+rewrite /= inE orbA=> /orP[| oldl]; last by apply: old; rewrite oldl orbT.
+move=> /orP[go | ghe].
+  have := opening_cells_aux_high vl vp oute'; rewrite oca_eq /=.
+  move: go=> /[swap] -> /[dup] go /oute' /eqP /[dup] ge ->.
+  rewrite mem_sort in go.
+  apply/andP; split; first by exact ee'.
+  have := cle; rewrite /= /close_out_from_event /end_edge => /andP[] + _.
+  move=> /allP /(_ g go).
+  by move=> /hasP[e3 e3in /eqP ->]; apply: e'fut.
+have := opening_cells_aux_high_last vl vp oute'; rewrite oca_eq /= -(eqP ghe).
+move=> {}ghe.
+have lcco : lcc \in open by rewrite ocd !mem_cat inE eqxx !orbT.
+have /lex_open_edges : g \in [seq high c | c <- open].
+  by apply/mapP; exists lcc; rewrite // ghe.
+move=> /andP[] left_e e_right.
+rewrite (lexPt_trans left_e ee') /=.
+have := (allP clae lcc lcco) => /andP[] _; rewrite /end_edge.
+move=> /orP[].
+  rewrite !inE -heq -ghe => /orP[] /eqP ->; move: inbox_e'.
+    by move=> /inside_box_lexPt_bottom /andP[] _ /lexPtW.
+  by move=> /inside_box_lexPt_top /andP[] _ /lexPtW.
+move=> /hasP [e2 + /eqP ge2].
+rewrite inE=> /orP[ /eqP abs | ].
+  suff /onAbove : point e === he by rewrite puh.
+  by rewrite -abs -ge2 heq right_on_edge.
+by move=> /e'fut; rewrite /lexePtEv -ge2 -heq ghe.
+Qed.
+
+Lemma step_keeps_lex_edge :
+  let s' := step (Bscan fop lsto lop cls lstc lsthe lstx) e in
+  forall e', inside_box (point e') -> lexPtEv e e' ->
+               (forall e2, e2 \in future_events -> lexePtEv e' e2) ->
+   {in [seq high c | c <- state_open_seq s'], forall g,
+       lexPt (left_pt g) (point e') && lexePt (point e') (right_pt g)}.
+Proof.
+rewrite /step/=/generic_trajectories.simple_step.
+case: ifP => [pxaway | /negbFE/eqP/[dup] pxhere /abovelstle palstol].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe : (open_cells_decomposition _ _) => [[[[[fc cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  rewrite /state_open_seq /state_closed_seq /=.
+  move=> e' in_e' ee' e'fut.
+  by have := step_keeps_lex_edge_default; rewrite oe oca_eq catA; apply.
+case: ifP=> [eabove | ebelow].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe' : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  have eabove' : point e >>> low (head dummy_cell lop).
+    have llopq : low (head dummy_cell lop) = lsthe.
+      apply: esym; rewrite lstheq.
+      move: (exi' eabove)=> [w + _].
+      move: adj=> /adjacent_catW[] _.
+      by case: (lop) => [ // | ? ?] /andP[] /eqP.
+    by rewrite llopq.
+  move: adj rfo sval; rewrite /open -cat_rcons => adj' rfo' sval'.
+  have := open_cells_decomposition_cat adj' rfo' sval' (exi' eabove) eabove'.
+  rewrite oe' cat_rcons => oe.
+  rewrite /state_open_seq /state_closed_seq /=.
+  have := step_keeps_lex_edge_default; rewrite oe oca_eq.
+  move=> main e' in_e' ee' e'fut g /mapP[c cin gq].
+  apply: (main e' in_e' ee' e'fut); apply/mapP; exists c; last by [].
+  by move: cin; rewrite !(mem_rcons, mem_cat, inE) !orbA (orbC _ (c == lsto)).
+have ebelow' : point e <<= lsthe by exact (negbFE ebelow).
+case: ifP => [ebelow_st | enolsthe].
+  rewrite /state_open_seq /update_open_cell/generic_trajectories.update_open_cell /=.
+  have belowo : point e <<< high lsto by rewrite -lstheq.
+  have := open_cells_decomposition_single adj rfo sval palstol belowo.
+  move=> oe.
+  have [ocd [lcc_ctn [_ [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+  have [pal puh vl vp nc]:=
+   decomposition_connect_properties rfo sval adj cbtom
+    (inside_box_between inbox_e) oe.
+  case ogq: (outgoing e) => [ | fog ogs] /=.
+    move=> e' in_e' ee' e'fut; rewrite cats0=> g /mapP [c + gq].
+    rewrite mem_cat inE orbCA gq=> /orP[/eqP /[dup] cq -> /= | ].
+      rewrite (fun h => lexPt_trans h ee')/=; last first.
+        apply: (proj1 (andP (lex_open_edges (map_f _ _)))).
+        by rewrite mem_cat inE eqxx orbT.
+      have /andP[_ /orP[|] ] := (allP clae lsto lstoin).
+        by move=>/(inbox_lexePt_right_bt in_e').
+      move=> /hasP [e2].
+      rewrite inE => /orP[/eqP -> | /e'fut +] /eqP rq.
+        move: (strict_nonAunder vho); rewrite -lstheq /point_strictly_under_edge ebelow_st=>/esym.
+        move: gq; rewrite cq high_set_left_pts=> gq.
+        by rewrite lstheq -rq right_on_edge.
+      by rewrite /lexePtEv -rq.
+    move=> cold; apply/andP.
+    have cino : c \in open.
+      by rewrite mem_cat inE; move: cold=> /orP[] ->; rewrite ?orbT .
+    split.
+      apply: lexPt_trans ee'.
+      by have /andP[] := lex_open_edges (map_f _ cino).
+    have /andP[_] := (allP clae _ cino).
+    move=> /orP[].
+      by move=> /(inbox_lexePt_right_bt in_e').
+    move=> /hasP[e2 + /eqP e2P]; rewrite inE => /orP[/eqP e2e | ].
+      rewrite e2e in e2P.
+      by move: (nc _ cold)=> []; apply: contains_right.
+    by move=> /e'fut; rewrite /lexePtEv -e2P.
+  rewrite -ogq.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [[ | fno nos] lno].
+    have ogn : outgoing e != [::] by rewrite ogq.
+    have := opening_cells_aux_absurd_case vlo vho ogn oute.
+    by rewrite oca_eq.
+  rewrite /= => e' in_e' ee' e'fut g /mapP[c cin gq].
+  have := step_keeps_lex_edge_default.
+  rewrite oe oca_eq=> /(_ e' in_e' ee' e'fut) main.
+  move: cin; rewrite -!catA /= mem_cat => /orP[cin | ].
+    by apply: main; apply/mapP; exists c; rewrite // mem_cat cin.
+  rewrite inE=> /orP[/eqP cq | ].
+    rewrite gq cq high_set_left_pts; apply: main.
+    by apply/mapP; exists fno; rewrite // !(mem_cat, inE) eqxx ?orbT.
+  move=> cin; apply: main.
+  by apply/mapP; exists c; rewrite //= mem_cat inE cin !orbT.
+move=> e' in_e' ee' e'fut.
+rewrite -/(open_cells_decomposition _ _).
+case oe' : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+rewrite -/(update_open_cell_top _ _ _).
+case uoctq: update_open_cell_top => [nos lno].
+rewrite /state_open_seq /= -!catA.
+move=> g /mapP [c cin gq]; rewrite gq {gq}.
+have exi2 : exists2 c, c \in lsto :: lop & contains_point' (point e) c.
+  exists lsto; first by rewrite inE eqxx.
+  by rewrite /contains_point' palstol -lstheq ebelow'.
+have := open_cells_decomposition_cat adj rfo sval exi2 palstol.
+rewrite oe'=> oe.
+have [ocd [lcc_ctn [_ [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vl vp nc]:=
+   decomposition_connect_properties rfo sval adj cbtom
+    (inside_box_between inbox_e) oe.
+have := step_keeps_lex_edge_default; rewrite oe => main.
+move: uoctq; rewrite /update_open_cell_top/generic_trajectories.update_open_cell_top.
+have := last_step_situation oe' pxhere (negbT enolsthe) ebelow'.
+move=> [] fc'0 [] leo [cc' ccq].
+case ogq : (outgoing e) => [ | fog ogs]; last first.
+  rewrite -ogq.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [ [ | fno nos'] lno'].
+    have ogn : outgoing e != [::] by rewrite ogq.
+    have := opening_cells_aux_absurd_case vlo vp ogn oute.
+    by rewrite oca_eq.
+  move=> -[] nosq lnoq.
+  move: main; rewrite leo oca_eq => /(_ _ in_e' ee' e'fut) main.
+  move: cin; rewrite mem_cat=> /orP[cin | ].
+    by apply: main; apply/mapP; exists c; rewrite // !mem_cat cin.
+  rewrite fc'0 /= mem_cat inE orbA=> /orP[|cin]; last first.
+    by apply: main; apply/mapP; exists c; rewrite // !(mem_cat, inE) cin !orbT.
+  move=> /orP[ | /eqP clno]; last first.
+    apply: main; apply/mapP; exists c; rewrite // lnoq !(mem_cat, inE) clno.
+    by rewrite eqxx !orbT.
+  rewrite -nosq inE=> /orP[ | cin]; last first.
+    by apply: main; apply/mapP; exists c; rewrite // !(mem_cat, inE) cin !orbT.
+  move=> /eqP ->; rewrite high_set_left_pts.
+  by apply: main; apply/mapP; exists fno; rewrite // !mem_cat inE eqxx !orbT.
+move=> [] nosq lnoq.
+have oca_eq : opening_cells_aux (point e) (sort (@edge_below _) (outgoing e))
+   le he =
+  ([::], (Bcell (@no_dup_seq pt
+      [:: (Bpt (p_x (point e)) (pvert_y (point e) he));
+          (point e);
+          (Bpt (p_x (point e)) (pvert_y (point e) le))]) [::] le he)).
+  rewrite ogq -[sort _ _]/[::].
+  rewrite /opening_cells_aux/generic_trajectories.opening_cells_aux.
+  by rewrite -/(vertical_intersection_point _ _) (pvertE vl)
+       -/(vertical_intersection_point _ _)  (pvertE vp).
+move: main; rewrite oca_eq => /(_ _ in_e' ee' e'fut)=> main.
+move: cin; rewrite mem_cat=> /orP[cin |].
+  by apply: main; apply/mapP; exists c; rewrite // !mem_cat cin.
+rewrite fc'0 -nosq /= inE=> /orP[/eqP clno | cin]; last first.
+  by apply: main; apply/mapP; exists c; rewrite // !(mem_cat, inE) cin !orbT.
+apply: main.
+rewrite map_cat /=.
+suff ->: high c = he by rewrite !(mem_cat, inE) eqxx !orbT.
+by rewrite clno -lnoq /=.
+Qed.
+
+Lemma opening_cells_aux_cover_outgoing le he nos lno:
+  valid_edge le (point e) ->
+  opening_cells_aux (point e) (sort (@edge_below _) (outgoing e)) le he =
+  (nos, lno) ->
+  {in (outgoing e), forall g,
+  exists c, c \in nos /\ high c = g /\ left_limit c = p_x (left_pt g)}.
+Proof.
+move=> + + g go.
+have go' : g \in sort (@edge_below _) (outgoing e) by rewrite mem_sort.
+elim: (sort _ _) go' oute' le nos lno {go} => [ // | g' og Ih].
+rewrite inE=> /orP[/eqP -> | gin]; move=> + le nos lno vle.
+  have /[swap] /[apply] /eqP lpg' : g' \in g' :: og by rewrite inE eqxx.
+  rewrite /=.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case: (opening_cells_aux _ _ _ _) => s nc.
+  rewrite -/(vertical_intersection_point _ _) (pvertE vle).
+  set it := Bcell _ _ _ _; move=> [] sq ncq; exists it.
+  rewrite -sq inE eqxx; split=> //; split=> //.
+  rewrite /left_limit /=.
+  rewrite -[pt_eqb _ _ _ _]/(_ == _ :> pt).
+  by case: ifP => [/eqP -> /=| /= ]; rewrite lpg'.
+move=> outg'.
+have outg : {in og, forall g, left_pt g == point e}.
+  by move=> x xin; apply: outg'; rewrite inE xin orbT.
+rewrite /=.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [s nc].
+rewrite -/(vertical_intersection_point _ _) (pvertE vle) => - [sq ncq].
+have vg : valid_edge g' (point e).
+  rewrite -(eqP (outg' g' _)); last by rewrite inE eqxx.
+  by apply: valid_edge_left.
+have [it [P1 P2]]:= Ih gin outg g' s nc vg oca_eq.
+  exists it; split; last by [].
+by rewrite -sq inE P1 orbT.
+Qed.
+
+Lemma step_keeps_edge_covering_default gen_closed fc cc lcc lc le he nos lno:
+  open_cells_decomposition open (point e) = (fc, cc, lcc, lc, le, he) ->
+  opening_cells_aux (point e) (sort (@edge_below _) (outgoing e)) le he =
+     (nos, lno) ->
+  forall g,
+  edge_covered g open gen_closed \/ g \in outgoing e ->
+  edge_covered g (fc ++ nos ++ lno :: lc)
+    (gen_closed ++ rcons (closing_cells (point e) cc)
+         (close_cell (point e) lcc)).
+Proof.
+move=> oe oca_eq.
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe old_nctn]:=
+   decomposition_connect_properties rfo sval adj cbtom bet_e oe.
+move=> g [go | gn]; last first.
+  have [c [cin [highc cleft]]]:=
+      opening_cells_aux_cover_outgoing vle oca_eq gn.
+  left; exists c, [::]; split=> /=; first by [].
+  split; first by move=> c'; rewrite inE=> /eqP ->.
+  split; first by [].
+  split; last by [].
+  by rewrite !mem_cat cin !orbT.
+case: go => [[opc [pcc [pccsub opcP]]] |
+              [ pcc [pccn0 [pccsub pccP]]]]; last first.
+  right; exists pcc.
+ split;[exact pccn0 | split; [ | exact pccP]].
+  by move=> g1 /pccsub; rewrite mem_cat=> ->.
+move: opcP => [highc [cnc [opco pccl]]].
+have [ghe | gnhe] := eqVneq g he.
+  have vllcc : valid_edge (low lcc) (point e).
+    apply: (seq_valid_low sval); rewrite ocd !map_cat !mem_cat /= inE.
+    by rewrite eqxx ?orbT.
+  have lccq : lcc = opc.
+    apply: high_inj=> //; first by rewrite ocd !(mem_cat, inE) eqxx !orbT.
+    by rewrite (highc opc) ?ghe; last rewrite mem_rcons inE eqxx.
+  left; exists lno, (rcons pcc (close_cell (point e) lcc)).
+  split.
+    move=> c; rewrite mem_rcons inE=> /orP[/eqP -> | /pccsub].
+      by rewrite !(mem_rcons, mem_cat, inE) eqxx ?orbT.
+    by rewrite mem_cat=> ->.
+  split.
+    move=> c; rewrite !(mem_rcons, inE).
+    move=> /orP[/eqP |/orP[/eqP | inpcc]]; last 1 first.
+        by apply: highc; rewrite !(mem_rcons, mem_cat, inE, inpcc, orbT).
+      rewrite /close_cell.
+      move=> ->; rewrite ghe.
+      have := higher_edge_new_cells oute vle vhe.
+      by rewrite /opening_cells oca_eq => /(_ _ erefl); rewrite last_rcons.
+    rewrite /close_cell=> ->.
+    by rewrite -heq (pvertE vhe) (pvertE vllcc) /= ghe.
+  split.
+    elim/last_ind : {-1} pcc (erefl pcc) => [pcceq | pcc1 lpcc _ pcceq].
+      rewrite /= andbT.
+      rewrite close_cell_right_limit; last first.
+        by rewrite /valid_cell vllcc -heq vhe.
+      have /(_ lno) -> // := opening_cells_left oute vle vhe.
+      by rewrite /opening_cells oca_eq mem_rcons inE eqxx.
+    rewrite connect_limits_rcons; last by apply/eqP/rcons_neq0.
+    apply/andP; split; last first.
+      rewrite last_rcons right_limit_close_cell //.
+        have /(_ lno) -> // := opening_cells_left oute vle vhe.
+        by rewrite /opening_cells oca_eq mem_rcons inE eqxx.
+      by rewrite -heq.
+    rewrite connect_limits_rcons; last by apply/eqP/rcons_neq0.
+    move: cnc.
+    rewrite pcceq connect_limits_rcons; last by apply/eqP/rcons_neq0.
+    move=> /andP[] -> /eqP ->.
+    by rewrite left_limit_close_cell lccq eqxx.
+  split; first by rewrite !(mem_cat, inE, eqxx, orbT).
+  move: pccl; rewrite lccq; case: (pcc)=> /=; last by [].
+  by rewrite left_limit_close_cell.
+rewrite -cat_rcons.
+move: opco; rewrite ocd -cat_rcons !mem_cat orbCA => /orP[]; last first.
+  move=> opc_pres.
+  left; exists opc, pcc.
+  split; first by apply: subset_catrl.
+  split; first by [].
+  split; first by [].
+  split; last by [].
+  by rewrite !mem_cat orbCA opc_pres orbT.
+move=> opcc.
+right.
+have [_ highopc leftopc] := close_cell_preserve_3sides (point e) opc.
+exists (rcons pcc (close_cell (point e) opc)).
+split.
+  by apply/eqP/rcons_neq0.
+split.
+  move=> c; rewrite mem_rcons inE=> /orP[/eqP -> | ].
+    rewrite mem_cat/closing_cells; apply/orP; right.
+    by rewrite -map_rcons; apply/mapP; exists opc.
+  by move=> /pccsub cin; rewrite mem_cat cin.
+split.
+  move=> c; rewrite mem_rcons inE => /orP[/eqP -> | inpcc]; last first.
+    by apply highc; rewrite mem_rcons inE inpcc orbT.
+  by rewrite highopc; apply highc; rewrite mem_rcons inE eqxx.
+split.
+  have [/eqP -> | pccn0] := boolP (pcc == [::]).
+    by [].
+  move: cnc; rewrite !connect_limits_rcons // => /andP[] -> /eqP -> /=.
+  by rewrite /left_limit leftopc.
+split.
+  move: pccl; case pccq: pcc => [ | pcc0 pcc'] //=.
+  by rewrite /left_limit leftopc.
+have opco : opc \in open.
+  by rewrite ocd -cat_rcons !mem_cat opcc orbT.
+rewrite /last_cell last_rcons right_limit_close_cell; last first.
+    by apply/(seq_valid_high sval)/map_f.
+  by apply/(seq_valid_low sval)/map_f.
+have hopc : high opc = g by apply: highc; rewrite mem_rcons inE eqxx.
+have {}opcc : opc \in cc.
+  move: opcc; rewrite mem_rcons inE=> /orP[] // /eqP abs.
+  by case/eqP: gnhe; rewrite -hopc abs.
+have e_on : point e === high opc.
+  by apply: (open_cells_decomposition_point_on cbtom adj bet_e sval oe opcc).
+have [ abs | -> ] := open_non_inner opco e_on; last by rewrite hopc.
+have := bottom_left_lex_to_high cbtom adj rfo open_side_limit.
+move=> /(_ _ inbox_e btm_left _ opco).
+by rewrite abs lexPt_irrefl.
+Qed.
+
+Lemma edge_covered_set_left_pts g l1 c l2 l3 lpts :
+  left_limit c = p_x (last dummy_pt lpts) ->
+  edge_covered g (l1 ++ c :: l2) l3 ->
+  edge_covered g (l1 ++ (set_left_pts c lpts) :: l2) l3.
+Proof.
+move=> left_cond [active | [pcc pccP]]; last by right; exists pcc; exact pccP.
+move: active => [opc [pcc [pccP1 [pccP2 [pccP3 [pccP4 pccP5]]]]]].
+have [copc | cnopc] := eqVneq c opc.
+  left; exists (set_left_pts c lpts), pcc.
+  split; first by [].
+  split.
+    move=> x; rewrite mem_rcons inE=> /orP[ /eqP -> | xin]; last first.
+      by apply: pccP2; rewrite mem_rcons inE xin orbT.
+    rewrite /set_left_pts /=.
+    by apply: pccP2; rewrite mem_rcons inE copc eqxx.
+  split.
+    have [-> | pccn0] := eqVneq pcc [::]; first by [].
+    move: pccP3; rewrite !connect_limits_rcons // => /andP[] -> /eqP -> /=.
+    rewrite /set_left_pts /=.
+    by rewrite -copc left_cond /left_limit.
+  split; first by rewrite mem_cat inE eqxx orbT.
+   move: pccP5; have [-> /= | pccn0] := eqVneq pcc [::].
+     by rewrite -copc left_cond.
+   by move: pccn0; case: (pcc).
+left; exists opc, pcc.
+split; first by [].
+split; first by [].
+split; first by [].
+split; last by [].
+move: pccP4.
+rewrite !mem_cat !inE=> /orP[ -> | /orP [ | -> ]]; rewrite ?orbT //.
+by move: cnopc=> /[swap]; rewrite eq_sym=> ->.
+Qed.
+
+Lemma update_closed_cell_keep_left_limit c pt :
+  left_limit (update_closed_cell c pt) = left_limit c.
+Proof. by move: c => [? ? ? ?]. Qed.
+
+Lemma connect_limits_seq_subst (l : seq cell) c c' :
+  left_limit c = left_limit c' -> right_limit c = right_limit c' ->
+  connect_limits l -> connect_limits (seq_subst l c c').
+Proof.
+move=> ll rr; elim: l => [ | a [ | b l] Ih] /=; first by [].
+  by case: ifP.
+move=> /[dup] conn /andP[ab conn'].
+have conn0 : path (fun c1 c2 => right_limit c1 == left_limit c2) a (b :: l).
+   by exact: conn.
+have /Ih : sorted (fun c1 c2 => right_limit c1 == left_limit c2) (b :: l).
+  by apply: (path_sorted conn0).
+case: ifP=> [/eqP ac | anc].
+  rewrite /=; case: ifP => [/eqP bc | bnc].
+    by rewrite /= -rr -ll -ac (eqP ab) ac -bc eqxx.
+  by rewrite /= -rr -ac ab.
+rewrite /=; case: ifP=> [/eqP bc | bnc].
+  by rewrite /= -ll -bc ab.
+by rewrite /= ab.
+Qed.
+
+Lemma edge_covered_update_closed_cell g l1 l2 c pt :
+  (1 < size (right_pts c))%N ->
+  closed_cell_side_limit_ok c ->
+  edge_covered g l1 (rcons l2 c) ->
+  edge_covered g l1 (rcons l2 (update_closed_cell c pt)).
+Proof.
+move=> szpts cok ecg.
+have lq : left_limit (update_closed_cell c pt) = left_limit c.
+  by case: (c).
+have rq : right_limit (update_closed_cell c pt) = right_limit c.
+  rewrite update_closed_cell_keeps_right_limit //.
+case: ecg => [[oc [pcc [ocP1 [hP [cP [ocin conn]]]]]] | ].
+  left; exists oc, (seq_subst pcc c (update_closed_cell c pt)).
+  split.
+    elim: (pcc) ocP1 => [ // | a l Ih].
+    move=> subh x; rewrite /=.
+    have /Ih {} Ih : {subset l <= rcons l2 c}.
+      by move=> y yin; have /subh : y \in a:: l by rewrite inE yin orbT.
+    case: ifP => [ac | anc]; rewrite !(inE, mem_rcons).
+      by move=> /orP[-> // | /Ih]; rewrite mem_rcons inE.
+    move=> /orP[xa | ].
+      have /subh : x \in a :: l by rewrite inE xa.
+      by rewrite mem_rcons inE (eqP xa) anc /= orbC => ->.
+    by move/Ih; rewrite mem_rcons inE.
+  split.
+    move=> x; rewrite mem_rcons inE => /orP[xoc | ].
+      by apply: hP; rewrite mem_rcons inE xoc.
+    have : {in pcc, forall c, high c = g}.
+      by move=> y yin; apply: hP; rewrite mem_rcons inE yin orbT.
+    elim: (pcc) => [ // | a l Ih] {}hP.
+    have /Ih {}Ih : {in l, forall c, high c = g}.
+      by move=> y yin; apply: hP; rewrite inE yin orbT.
+    rewrite /=; case: ifP=> [ac | anc].
+      rewrite inE=> /orP[/eqP -> | ]; last by [].
+      have: high c = g by apply: hP; rewrite inE eq_sym ac.
+      by case: (c).
+    rewrite inE=> /orP[/eqP -> | ]; last by [].
+    by apply: hP; rewrite inE eqxx.
+  split.
+    elim/last_ind: (pcc) cP => [// | pcc' lpcc _].
+    rewrite connect_limits_rcons; last by apply/eqP/rcons_neq0.
+    move=> /andP[] cP cc.
+    rewrite connect_limits_rcons; last first.
+      by case: (pcc')=> /= [ | ? ?]; case: ifP.
+    apply/andP; split; last first.
+      rewrite -cats1 seq_subst_cat /=.
+      move: cc; rewrite last_rcons=> /eqP <-.
+      case: ifP; rewrite cats1 last_rcons; last by [].
+      by rewrite rq => /eqP ->.
+    by apply: connect_limits_seq_subst.
+  split; first by [].
+  case: (pcc) conn => [ | fpcc pcc']/=; first by [].
+  by case: ifP=> [ /eqP -> | ].
+move=> [pcc [P0 [P1 [P2 [P3 [P4 P5]]]]]].
+right.
+exists (seq_subst pcc c (update_closed_cell c pt)).
+split.
+  by rewrite seq_subst_eq0.
+split.
+  elim : (pcc) P1 => [ | a l Ih] P1; first by [].
+  have ain : a \in rcons l2 c by apply: P1; rewrite inE eqxx.
+  have /Ih {} Ih : {subset l <= rcons l2 c}.
+    by move=> y yin; apply: P1; rewrite inE yin orbT.
+  rewrite /=; case: ifP=> [ ac | anc].
+    move=> g'; rewrite !inE => /orP[/eqP -> | /Ih]; last by [].
+    by rewrite mem_rcons inE eqxx.
+  move=> g'; rewrite !inE=> /orP[/eqP -> | ].
+    by move: ain; rewrite !mem_rcons !inE anc /= orbC => ->.
+  by apply: Ih.
+split.
+  elim: (pcc) P2 => [ | a l Ih] P2; first by [].
+  have /Ih {} Ih : {in l, forall c, high c = g}.
+    by move=> x xin; apply: P2; rewrite inE xin orbT.
+  rewrite /=; case: ifP => [ac | anc].
+    move=> c'; rewrite inE => /orP[/eqP -> | ].
+      move: (P2 c); rewrite inE eq_sym ac => /(_ isT).
+      by case: (c).
+    by apply: Ih.
+  move=> c'; rewrite inE => /orP[/eqP -> | ].
+    by apply: P2; rewrite inE eqxx.
+  by apply: Ih.
+split; first by apply: connect_limits_seq_subst.
+split.
+  move: P4; case: (pcc)=> [ | a l]; first by [].
+  rewrite /=; case: ifP=> [/eqP ac | anc] /=; last by [].
+  by rewrite lq ac.
+move: P5; elim/last_ind : (pcc) => [ | l b _]; first by [].
+rewrite -cats1 seq_subst_cat /=; case: ifP=> [/eqP bc | bnc].
+  by rewrite /last_cell !last_cat /= rq bc.
+by rewrite /last_cell !last_cat /=.
+Qed.
+
+Lemma lsthe_at_left : point e <<= lsthe ->
+  p_x (left_pt lsthe) < p_x (point e).
+Proof.
+move=> puh.
+have /lex_open_edges/andP[+ _] : lsthe \in [seq high c | c <- open].
+  by apply/mapP; exists lsto.
+rewrite /lexPt=> /orP[ | /andP[] /eqP samex lty]; first by [].
+have vhe : valid_edge lsthe (point e).
+  move: (allP sval lsto); rewrite /open mem_cat inE eqxx !orbT.
+  by move=> /(_ isT)=> /andP[]; rewrite lstheq.
+move: puh; rewrite under_pvert_y //.
+move: (samex)=> /esym samex'.
+rewrite (same_pvert_y vhe samex').
+by rewrite (on_pvert (left_on_edge _)) leNgt lty.
+Qed.
+
+Lemma step_keeps_edge_covering:
+  let s' :=  step (Bscan fop lsto lop cls lstc lsthe lstx) e in
+  forall g, edge_covered g open (rcons cls lstc) \/ g \in outgoing e ->
+  edge_covered g (state_open_seq s') (state_closed_seq s').
+Proof.
+rewrite /step/=/generic_trajectories.simple_step.
+case: ifP => [pxaway | /negbFE/eqP/[dup] pxhere /abovelstle palstol].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe : (open_cells_decomposition _ _) => [[[[[fc cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  rewrite /state_open_seq /state_closed_seq /=.
+  move=> g gin.
+  have := step_keeps_edge_covering_default oe oca_eq gin.
+  by rewrite -!cats1 -?catA /=.
+case: ifP=> [eabove | ebelow].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe' : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  have eabove' : point e >>> low (head dummy_cell lop).
+    have llopq : low (head dummy_cell lop) = lsthe.
+      apply: esym; rewrite lstheq.
+      move: (exi' eabove)=> [w + _].
+      move: adj=> /adjacent_catW[] _.
+      by case: (lop) => [ // | ? ?] /andP[] /eqP.
+    by rewrite llopq.
+  move: adj rfo sval; rewrite /open -cat_rcons => adj' rfo' sval'.
+  have := open_cells_decomposition_cat adj' rfo' sval' (exi' eabove) eabove'.
+  rewrite oe' cat_rcons => oe.
+  rewrite /state_open_seq /state_closed_seq /=.
+  move=> g gin.
+  have := step_keeps_edge_covering_default oe oca_eq gin.
+  by rewrite !cat_rcons -!cats1 -?catA /=.
+have [p1 [p2 [pts ptsq]]]: exists p1 p2 pts, left_pts lsto = p1 :: p2 :: pts.
+  have ebelow' : point e <<= high lsto.
+    by move/negbFE :ebelow; rewrite lstheq.
+  have := size_left_lsto pxhere palstol ebelow'.
+  case: (left_pts lsto) => [// | pt1 [ // | pt2 pts]] _.
+  by exists pt1, pt2, pts.
+case: ifP => [ebelow_st {ebelow} | eonlsthe].
+  rewrite /update_open_cell/generic_trajectories.update_open_cell.
+  case ogq : (outgoing e) => [ /= | fog ogs].
+    move=> g [ ecg | //].
+    rewrite /state_open_seq /= cats0 /state_closed_seq /=.
+    apply: edge_covered_set_left_pts.
+      by rewrite /left_limit ptsq.
+    apply: edge_covered_update_closed_cell=> //.
+    by apply: (allP close_side_limit); rewrite mem_rcons inE eqxx.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [[ | fno nos] lno]  /=.
+    have outn0 : fog :: ogs != nil by [].
+    have oute2 : {in fog :: ogs, forall g, left_pt g == point e}.
+      by rewrite -ogq.
+    have := opening_cells_aux_absurd_case vlo vho outn0 oute2.
+    by rewrite oca_eq.
+  move=> g [ecg | gnew]; last first.
+    left.
+    have :=opening_cells_aux_cover_outgoing vlo.
+    move=> /(_ (high lsto) (fno :: nos) lno); rewrite ogq=> /(_ oca_eq).
+    move=> /(_ g gnew) [gc [P1 [P2 P3]]].
+    exists (if gc == fno then
+               set_left_pts fno (point e :: behead (left_pts lsto))
+            else gc), [::].
+    split; first by [].
+    split.
+      move=> x; rewrite /= inE => /eqP ->.
+      case: ifP => [/eqP <- | ]; last by [].
+      by case: (gc) P2.
+    split; first by [].
+    split.
+      rewrite /state_open_seq /=.
+      move: P1; case: ifP => [/eqP -> _ | ].
+        by rewrite !mem_cat inE eqxx orbT.
+      by rewrite inE=> -> /=; rewrite !mem_cat inE=> ->; rewrite ?orbT.
+    rewrite /head_cell /=; case: ifP=> [/eqP <- | ]; last by [].
+    move: lstxq; rewrite /left_limit.
+    rewrite ptsq /left_limit /= => <-.
+    by rewrite (eqP (@oute g _)) ?pxhere // ogq.
+  move: ecg=> [[oc [pcc [P1 [P2 [P3 [P4 P5]]]]]] | ].
+    move: P4; rewrite mem_cat inE orbCA=> /orP[/eqP oclsto | inold].
+      rewrite /state_open_seq /state_closed_seq /=.
+      rewrite /= -catA /=.
+      apply: edge_covered_set_left_pts.
+        rewrite (opening_cells_left oute vlo vho).
+          by rewrite pxhere lstxq /left_limit ptsq.
+        by rewrite /opening_cells ogq oca_eq mem_rcons !inE eqxx !orbT.
+      apply: edge_covered_update_closed_cell=> //.
+        by apply: (allP close_side_limit); rewrite mem_rcons inE eqxx.
+      left; exists lno, pcc.
+      split; first by [].
+      split.
+        move=> x; rewrite mem_rcons inE=> /orP[/eqP -> | xin]; last first.
+          by apply P2; rewrite mem_rcons inE xin orbT.
+        have := opening_cells_aux_high_last vlo vho oute'.
+        rewrite ogq oca_eq /= -oclsto=> ->; apply: P2.
+        by rewrite mem_rcons inE eqxx.
+      have left_lno : left_limit lno = lstx.
+        have := opening_cells_left oute vlo vho.
+          rewrite -pxhere /opening_cells ogq oca_eq; apply.
+          by rewrite mem_rcons inE eqxx.
+      split.
+        elim/last_ind: {-1} pcc (erefl pcc)  => [ | pcc' pcl _] pccq;
+          first by [].
+        rewrite connect_limits_rcons; last by apply/eqP/rcons_neq0.
+        move: P3; rewrite pccq connect_limits_rcons; last first.
+          by apply/eqP/rcons_neq0.
+        move=> /andP[] -> /eqP ->.
+        by rewrite oclsto -lstxq left_lno eqxx.
+      split; first by rewrite !(mem_cat, inE) eqxx !orbT.
+      move: P5; case: (pcc) => //=.
+      by rewrite left_lno oclsto lstxq.
+    rewrite /state_closed_seq /state_open_seq /=.
+    rewrite -!catA /=.
+    have left_fno : left_limit fno = lstx.
+      have := opening_cells_left oute vlo vho.
+      rewrite -pxhere /opening_cells ogq oca_eq; apply.
+      by rewrite mem_rcons !inE eqxx !orbT.
+    apply: edge_covered_set_left_pts.
+      by rewrite left_fno lstxq /left_limit ptsq.
+    apply: edge_covered_update_closed_cell=> //.
+      by apply: (allP close_side_limit); rewrite mem_rcons inE eqxx.
+    left; exists oc, pcc; repeat (split; first by []); split; last by [].
+    by rewrite !(mem_cat, inE); move: inold=> /orP[] ->; rewrite ?orbT.
+  move=> [pcc [P1 [P2 [P3 [P4 P5]]]]].
+  rewrite /state_open_seq /state_closed_seq /=.
+  apply: edge_covered_update_closed_cell => //.
+    by apply: (allP close_side_limit); rewrite mem_rcons inE eqxx.
+  by right; exists pcc; repeat (split; first by []); done.
+rewrite -/(open_cells_decomposition _ _).
+case oe' : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+have exi2 : exists2 c, c \in (lsto :: lop) & contains_point' (point e) c.
+  have : contains_point' (point e) lsto.
+    by rewrite /contains_point' palstol -lstheq /point_under_edge (negbFE ebelow).
+  by exists lsto;[rewrite inE eqxx | ].
+have := open_cells_decomposition_cat adj rfo sval exi2.
+rewrite /= oe' => /(_ palstol)=> oe.
+have [ocd [lcc_ctn [all_ct [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe old_nctn]:=
+ decomposition_connect_properties rfo sval adj cbtom bet_e oe.
+rewrite -/(update_open_cell_top _ _ _).
+case uoct_eq: (update_open_cell_top lsto he e) => [nos lno].
+rewrite /state_closed_seq /state_open_seq /= -!catA /=.
+move=> g [ | ]; last first.
+  case ogq : (outgoing e) => [// | fog ogs]; rewrite -ogq => go.
+  move: uoct_eq; rewrite /update_open_cell_top/generic_trajectories.update_open_cell_top ogq.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [[ | fno nos'] lno'].
+    have ogn : fog :: ogs != [::] by [].
+    have := opening_cells_aux_absurd_case vlo vhe ogn.
+    by rewrite -[X in {in X, _}]ogq oca_eq=> /(_ oute).
+  rewrite -ogq in oca_eq.
+  move=> [] <- <-.
+  have [oc [P1 [P2 P3]]] := opening_cells_aux_cover_outgoing vlo oca_eq go.
+  left; exists (if oc == fno then
+                  set_left_pts fno (point e :: behead (left_pts lsto))
+                else oc), [::].
+  split;[by [] | split;[ | split; [by [] | ]]].
+    case: ifP => [/eqP ocfno | ocnfno]; last first.
+      by move=> x; rewrite mem_rcons !inE=> /orP[/eqP -> | ].
+    move=> x; rewrite inE -ocfno=> /eqP ->.
+    by case: (oc) P2.
+  split.
+    case: ifP => [/eqP ocfno | ocnfno].
+      by rewrite !(mem_cat, inE) eqxx !orbT.
+    by move: P1; rewrite inE ocnfno /= !(mem_cat, inE)=> ->; rewrite !orbT.
+  rewrite /=; case: ifP => [ocfno | ocnfno]; last by [].
+  move: lstxq; rewrite /left_limit ptsq -pxhere /= => <-.
+  by apply/f_equal/esym/(@eqP pt)/oute.
+move=> [ | [pcc [P0 [P1 [P2 [P3 [P4 P5]]]]]]]; last first.
+  move: uoct_eq; rewrite /update_open_cell_top/generic_trajectories.update_open_cell_top.
+  case ogq : (outgoing e) => [ | fog ogs].
+    move=> [] <- <- /=.
+    right; exists pcc; split; [by [] | split; last by []].
+    move=> x /P1; rewrite !(mem_rcons, inE, mem_cat).
+    by move=> /orP[] ->; rewrite ?orbT.
+  rewrite -ogq.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) =>
+       [[ | fno nos'] lno'].
+    have ogn : outgoing e != [::] by rewrite ogq.
+    have := opening_cells_aux_absurd_case vlo vhe ogn oute.
+    by rewrite oca_eq.
+  move=> [] <- <-.
+  right; exists pcc.
+  split; first by [].
+  split; last by [].
+  move=> x /P1.
+  by rewrite !(mem_cat, mem_rcons, inE)=> /orP[] ->; rewrite ?orbT.
+move=> [oc [pcc [P1 [P2 [P3 [P4 P5]]]]]].
+move: P4; rewrite /open ocd.
+move=> ocin.
+have olds : [|| oc \in fop, oc \in fc' | (oc \in lc)] ->
+      edge_covered g (fop ++ fc' ++ nos ++ lno :: lc)
+        (rcons (closing_cells (point e) (behead cc) ++ lstc :: cls)
+           (close_cell (point e) lcc)).
+  move=> ocin'; left; exists oc, pcc.
+  split.
+    move=> x /P1; rewrite !(mem_rcons, mem_cat, inE).
+    by move=> /orP[] ->; rewrite ?orbT.
+  do 2 (split; first by []).
+  split; last by [].
+  rewrite !(mem_cat, inE).
+  by move: ocin'=> /orP[-> | /orP[] -> ]; rewrite ?orbT.
+move: ocin; rewrite -!catA !(mem_cat, inE) => /orP[ocin |].
+  by apply: olds; rewrite ocin ?orbT.
+move=> /orP[ocin |]; first by apply: olds; rewrite ocin ?orbT.
+rewrite orbA=> /orP[ | ocin];last by apply: olds; rewrite ocin ?orbT.
+have ealsthe : point e >>= lsthe by rewrite /point_strictly_under_edge eonlsthe.
+have ebelow' : point e <<= lsthe by rewrite /point_under_edge (negbFE ebelow).
+have := last_step_situation oe' pxhere ealsthe ebelow'.
+move=> [-> /= [leo [cc' ccq]] ].
+have ll := lsthe_at_left ebelow'.
+rewrite ccq inE -orbA => /orP[/eqP oclsto | ].
+  have gq : g = lsthe.
+    by rewrite lstheq -oclsto P2 // mem_rcons inE eqxx.
+  have [pcc1 [pcc' pccq]] : exists pcc1 pcc', pcc = pcc1 :: pcc'.
+    case pccq : pcc => [ | pcc1 pcc']; last by exists pcc1, pcc'.
+    move: P5; rewrite pccq /= oclsto -lstxq -pxhere => abs.
+    by rewrite abs gq lt_irreflexive in ll.
+  right; exists pcc.
+    split.
+      by rewrite pccq.
+    split.
+      move=> x /P1; rewrite !(mem_rcons, mem_cat, inE).
+      by move=> /orP[] -> ; rewrite ?orbT.
+    split.
+      by move=> x xin; apply: P2; rewrite mem_rcons inE xin orbT.
+    split.
+      move: P3; rewrite connect_limits_rcons; last by rewrite pccq.
+      by move=> /andP[].
+    split; first by move: P5; rewrite pccq.
+    move: P3; rewrite connect_limits_rcons; last by rewrite pccq.
+    move=> /andP[] _ /eqP ->.
+    have eon : point e === high lsto.
+      rewrite -lstheq.
+      by apply: under_above_on; first rewrite lstheq.
+    move: (open_non_inner lstoin eon)=> []; last first.
+      rewrite -lstheq gq oclsto => <-.
+      by rewrite -lstxq pxhere.
+    by move: ll=> /[swap] ->; rewrite -lstheq lt_irreflexive.
+    move=> /orP[ | oclcc]; last first.
+  have hlnoq : high lno = high lcc.
+    move: uoct_eq; rewrite /update_open_cell_top/generic_trajectories.update_open_cell_top.
+    case ogq: (outgoing e) => [| fog ogs]; first by move=> [] _ <- /=.
+    rewrite -ogq.
+    rewrite -/(opening_cells_aux _ _ _ _).
+    case oca_eq : (opening_cells_aux _ _ _ _) => [[ | fno nos'] lno'].
+      have := opening_cells_aux_high_last vle vhe oute'; rewrite leo oca_eq /=.
+      by move=> /[swap] - [] _ <- => ->.
+    have := opening_cells_aux_high_last vle vhe oute'; rewrite leo oca_eq /=.
+    by move=> /[swap] - [] _ <- => ->.
+  have llno : left_limit lno = p_x (point e).
+    move: uoct_eq; rewrite /update_open_cell_top/generic_trajectories.update_open_cell_top.
+    case ogq: (outgoing e) => [| fog ogs].
+      have:= size_left_lsto pxhere palstol.
+      rewrite -lstheq => /(_ ebelow').
+      move: lstxq; rewrite /left_limit pxhere => -> + [] _ <- /=.
+      by case: (left_pts lsto).
+    rewrite -ogq.
+    rewrite -/(opening_cells_aux _ _ _ _).
+    case oca_eq: opening_cells_aux => [ [ | fno nos'] lno'] [] _ <-;
+      have := opening_cells_left oute vlo vhe;
+      rewrite /opening_cells oca_eq=> /(_ lno');
+      by rewrite mem_rcons inE eqxx=> /(_ isT).
+  have vlcc : valid_cell lcc (point e).
+    by apply/andP/(allP sval); rewrite /open ocd !(mem_cat, inE) eqxx ?orbT.
+  left; exists lno, (rcons pcc (close_cell (point e) lcc)).
+  split.
+    move=> c; rewrite !(mem_rcons, mem_cat, inE)=> /orP[-> |]; first by [].
+    by move=> /P1; rewrite mem_rcons inE => ->; rewrite !orbT.
+  split.
+    move=> c; rewrite mem_rcons inE => /orP[/eqP -> |].
+      by rewrite hlnoq; apply: P2; rewrite (eqP oclcc) mem_rcons inE eqxx.
+    rewrite mem_rcons inE => /orP[/eqP -> | ].
+      have [_ -> _] := close_cell_preserve_3sides (point e) lcc.
+        by rewrite -(eqP oclcc); apply: P2; rewrite mem_rcons inE eqxx.
+      by move=> cin; apply: P2; rewrite mem_rcons inE cin orbT.
+  split.
+    rewrite connect_limits_rcons; last by apply/eqP/rcons_neq0.
+    rewrite last_rcons close_cell_right_limit // llno eqxx andbT.
+    case pccq : pcc => [ | pcc1 pcc']; first by [].
+    rewrite connect_limits_rcons //.
+    move: P3; rewrite pccq connect_limits_rcons // => /andP[] -> /=.
+    move=> /eqP ->; rewrite /left_limit (eqP oclcc).
+    by have [_ _ ->] := close_cell_preserve_3sides (point e) lcc.
+  split; first by rewrite !mem_cat inE eqxx !orbT.
+  rewrite /head_cell !head_rcons.
+  move: P5; rewrite (eqP oclcc) => <-.
+  case: (pcc) => [ /= | ? ?]; last by [].
+  by rewrite left_limit_close_cell.
+move=> ocin.
+have ocin' : oc \in cc by rewrite ccq inE ocin orbT.
+have right_pt_e : right_pt (high oc) = point e.
+  have := open_cells_decomposition_point_on cbtom adj bet_e sval oe ocin'.
+      have ocop : oc \in open by rewrite /open ocd !mem_cat ocin' ?orbT.
+      have := open_non_inner ocop; rewrite /non_inner => /[apply].
+      move=> [ abs |->]; last by [].
+      have : high oc \in [seq high c | c <- open] by apply: map_f.
+      by move=> /lex_open_edges; rewrite abs lexPt_irrefl.
+right; exists (rcons pcc (close_cell (point e) oc)).
+split.
+  by apply/eqP/rcons_neq0.
+split.
+  have clocin : close_cell (point e) oc \in closing_cells (point e) cc'.
+    by apply: map_f.
+  move=> c; rewrite !(mem_rcons, mem_cat, inE)=> /orP[ /eqP -> | /P1].
+    by rewrite clocin ?orbT.
+  by rewrite mem_rcons inE=> ->; rewrite !orbT.
+split.
+  move=> c; rewrite mem_rcons inE => /orP[/eqP -> | ].
+    have [_ -> _] := close_cell_preserve_3sides (point e) oc.
+    by apply: P2; rewrite mem_rcons inE eqxx.
+  by move=> cin; apply: P2; rewrite mem_rcons inE cin orbT.
+split.
+  case pccq : pcc => [ | pcc1 pcc']; first by [].
+  rewrite connect_limits_rcons /left_limit; last by [].
+  have [_ _ ->] := close_cell_preserve_3sides (point e) oc.
+  by move: P3; rewrite pccq connect_limits_rcons.
+split.
+  case pccq : pcc => [ | pcc1 pcc'] /=.
+    move: P5; rewrite pccq /= /left_limit.
+    by have [_ _ ->] := close_cell_preserve_3sides (point e) oc.
+  by move: P5; rewrite pccq.
+rewrite /last_cell last_rcons close_cell_right_limit; last first.
+  by apply/andP/(allP sval); rewrite /open ocd !mem_cat ocin' !orbT.
+rewrite P2 in right_pt_e; last by rewrite mem_rcons inE eqxx.
+by rewrite right_pt_e.
+Qed.
+
+Lemma step_keeps_subset_default:
+  let '(fc, cc, lcc, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+    let '(nos, lno) := opening_cells_aux (point e)
+       (sort (@edge_below _) (outgoing e)) le he in
+  {subset [seq high c | c <- fc ++ nos ++ lno :: lc]
+       <= [seq high c | c <- open] ++ outgoing e}.
+Proof.
+case oe : (open_cells_decomposition _ _) =>
+ [[[[[fc cc] lcc] lc] le] he].
+case oca_eq:(opening_cells_aux _ _ _ _) => [nos lno].
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vl vp nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+      (inside_box_between inbox_e) oe.
+move=> g; rewrite ocd -2!cat_rcons !map_cat /= !(mem_cat, inE).
+rewrite orbCA=> /orP[ | gold]; last first.
+  by apply/orP; left; rewrite orbCA gold orbT.
+suff -> : [seq high c | c <- rcons nos lno] =i rcons (outgoing e) he.
+  by rewrite map_rcons !mem_rcons !inE heq=> /orP[-> | ->]; rewrite !orbT.
+have := opening_cells_aux_high vl vp oute'; rewrite oca_eq /=.
+rewrite map_rcons=> -> g'; rewrite !mem_rcons !inE mem_sort; congr (_ || _).
+by have := opening_cells_aux_high_last vl vp oute'; rewrite oca_eq /= => ->.
+Qed.
+
+Lemma step_keeps_subset :
+  let s' :=  step (Bscan fop lsto lop cls lstc lsthe lstx) e in
+  {subset [seq high c | c <- state_open_seq s'] <=
+    [seq high c | c <- open] ++ outgoing e}.
+Proof.
+rewrite /step/=/generic_trajectories.simple_step.
+case: ifP => [pxaway | /negbFE/eqP/[dup] pxhere /abovelstle palstol].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe : (open_cells_decomposition _ _) => [[[[[fc cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+rewrite /state_open_seq /= -catA.
+  by have := step_keeps_subset_default; rewrite oe oca_eq.
+case: ifP=> [eabove | ebelow].
+  rewrite -/(open_cells_decomposition _ _).
+  case oe' : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+  have eabove' : point e >>> low (head dummy_cell lop).
+    have llopq : low (head dummy_cell lop) = lsthe.
+      apply: esym; rewrite lstheq.
+      move: (exi' eabove)=> [w + _].
+      move: adj=> /adjacent_catW[] _.
+      by case: (lop) => [ // | ? ?] /andP[] /eqP.
+    by rewrite llopq.
+  move: adj rfo sval; rewrite /open -cat_rcons => adj' rfo' sval'.
+  have := open_cells_decomposition_cat adj' rfo' sval' (exi' eabove) eabove'.
+  rewrite oe' cat_rcons => oe.
+  rewrite /state_open_seq /= -!catA /=.
+  have := step_keeps_subset_default.
+  by rewrite oe oca_eq; rewrite cat_rcons -!catA.
+have ebelow' : point e <<= lsthe by exact (negbFE ebelow).
+case: ifP => [ebelow_st | enolsthe].
+  have belowo : point e <<< high lsto by rewrite -lstheq.
+  have := open_cells_decomposition_single adj rfo sval palstol belowo.
+  move=> oe.
+  have [ocd [lcc_ctn [_ [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+  have [pal puh vl vp nc]:=
+   decomposition_connect_properties rfo sval adj cbtom
+    (inside_box_between inbox_e) oe.
+  rewrite /update_open_cell/generic_trajectories.update_open_cell /state_open_seq.
+  case ogq: (outgoing e) => [ | fog ogs] /=.
+    have := step_keeps_subset_default; rewrite oe ogq /=.
+    rewrite !cats0.
+    do 2 rewrite -/(vertical_intersection_point _ _).
+    by rewrite (pvertE vl) (pvertE vp) /= !map_cat /=.
+  have := step_keeps_subset_default; rewrite oe ogq /=.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [ [ | fno nos'] lno'] /=.
+    have := opening_cells_aux_absurd_case vl vp => /(_ (fog :: ogs) isT).
+    by rewrite -ogq => /(_ oute); rewrite ogq oca_eq.
+  move=> main g gin; apply: main; move: gin.
+  by repeat (rewrite !map_cat /=); rewrite -!catA.
+rewrite -/(open_cells_decomposition _ _).
+case oe' : (open_cells_decomposition _ _) => [[[[[fc' cc] lcc] lc] le] he].
+rewrite -/(update_open_cell_top _ _ _).
+case uoctq: update_open_cell_top => [nos lno].
+rewrite /state_open_seq /= -!catA.
+move=> g /mapP [c cin gq]; rewrite gq {gq}.
+have exi2 : exists2 c, c \in lsto :: lop & contains_point' (point e) c.
+  exists lsto; first by rewrite inE eqxx.
+  by rewrite /contains_point' palstol -lstheq ebelow'.
+have := open_cells_decomposition_cat adj rfo sval exi2 palstol.
+rewrite oe'=> oe.
+have [ocd [lcc_ctn [_ [all_nct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vl vp nc]:=
+   decomposition_connect_properties rfo sval adj cbtom
+    (inside_box_between inbox_e) oe.
+have := last_step_situation oe' pxhere (negbT enolsthe) ebelow'.
+move=> [fc'0 [leo [cc' ccq]]].
+case ogq : (outgoing e) => [ | fog ogs]; last first.
+  move: uoctq; rewrite /update_open_cell_top/generic_trajectories.update_open_cell_top.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  case oca_eq : (opening_cells_aux _ _ _ _) => [ [ | fno nos'] lno'].
+    have ogn : outgoing e != [::] by rewrite ogq.
+    have := opening_cells_aux_absurd_case vlo vp ogn oute.
+    by rewrite oca_eq.
+  rewrite ogq.
+  have := step_keeps_subset_default; rewrite oe.
+  rewrite leo oca_eq fc'0 cats0 /= -ogq.
+  move=> main [] nosq lnoq; apply: main.
+  move: cin; rewrite mem_cat map_cat=> /orP[cin |cin].
+    by rewrite mem_cat map_f.
+  rewrite 2!mem_cat inE fc'0 /= -nosq inE -orbA in cin.
+  rewrite mem_cat /=; apply/orP; right.
+  move: cin=> /orP[/eqP -> | cin].
+    by rewrite high_set_left_pts inE eqxx.
+  rewrite inE; apply/orP; right.
+  by apply/map_f; rewrite mem_cat inE lnoq.
+move: uoctq; rewrite /update_open_cell_top/generic_trajectories.update_open_cell_top ogq => -[] nosq lnoq.
+move: cin; rewrite /open ocd fc'0 -nosq !cats0 /= mem_cat.
+rewrite map_cat inE mem_cat.
+move=> /orP[cin | cin].
+  by rewrite map_f.
+apply/orP; right.
+rewrite map_cat mem_cat; apply/orP; right.
+move: cin=> /orP[/eqP -> | cin].
+  by rewrite -lnoq /= heq inE eqxx.
+by rewrite /= inE map_f ?orbT.
+Qed.
+
+(* Keeping as a record that this statement should be proved.  However,
+  since this statement is not used yet, we do not start a proof. *)
+Definition TODO_step_keeps_left_pts_inf :=
+  let s' := step (Bscan fop lsto lop cls lstc lsthe lstx) e in
+  {in state_open_seq s', forall c, lexPt (bottom_left_corner c) (point e)}.
+
+Lemma step_keeps_left_limit_has_right_limit_default :
+  let '(fc, cc, lcc, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+    let '(nos, lno) := opening_cells_aux (point e)
+       (sort (@edge_below _) (outgoing e)) le he in
+  {in fc ++ nos ++ lno :: lc,
+   forall c p, inside_box p -> left_limit c = p_x p ->
+     contains_point' p c ->
+     has (inside_closed' p)
+      (cls ++ lstc :: rcons (closing_cells (point e) cc)
+         (close_cell (point e) lcc))}.
+Proof.
+case oe : (open_cells_decomposition _ _) =>
+ [[[[[fc cc] lcc] lc] le] he].
+case oca_eq:(opening_cells_aux _ _ _ _) => [nos lno].
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vl vp nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+      (inside_box_between inbox_e) oe.
+remember (fc ++ nos ++ lno :: lc) as open' eqn:openeq.
+remember (cls ++ lstc :: rcons (closing_cells (point e) cc)
+           (close_cell (point e) lcc)) as closed' eqn:closeeq.
+have := invariant1_default_case.
+  rewrite oe oca_eq => - [] clae' [] sval' [] adj' []cbtom' rfo'.
+move=> c cin pt' inboxp lbnd pin.
+move: cin; rewrite openeq -cat_rcons !mem_cat orbCA orbC=> /orP[cold | cnew].
+  rewrite closeeq -cat_rcons has_cat; apply/orP; left.
+  apply: (left_limit_has_right_limit _ inboxp lbnd pin).
+  by rewrite ocd -cat_rcons !mem_cat orbCA cold orbT.
+have lcco : lcc \in open.
+  by rewrite ocd !(mem_cat, inE) eqxx !orbT.
+have ppe : p_x pt' = p_x (point e).
+  have := (opening_cells_left oute vl vp); rewrite /opening_cells oca_eq.
+  by rewrite -lbnd; apply.
+have adjcc : adjacent_cells cc.
+  by move: adj; rewrite ocd=> /adjacent_catW[] _ /adjacent_catW[].
+have valcc : seq_valid cc (point e).
+  by apply/allP=> x xin; apply: (allP sval); rewrite ocd !mem_cat xin ?orbT.
+have lonew : low (head dummy_cell
+                 (opening_cells (point e) (outgoing e) le he)) = le.
+  have := adjacent_opening_aux vl vp oute'; rewrite /opening_cells oca_eq.
+  by move=> /(_ _ _ erefl) [].
+have lonew' : head dummy_edge
+    [seq low c | c <- opening_cells (point e) (outgoing e) le he] = le.
+  move: (opening_cells_not_nil (outgoing e) le he) lonew.
+  by set w := opening_cells _ _ _ _; case: w=> [ | a tl].
+have highnew : [seq high i | i <- opening_cells (point e)(outgoing e) le he]=
+               rcons (sort (@edge_below _) (outgoing e)) he.
+  by rewrite (opening_cells_high vl vp).
+have allval : all (fun g => valid_edge g pt')
+     (head dummy_edge [seq low i | i <- opening_cells (point e)
+              (outgoing e) le he] ::
+     [seq high i | i <- opening_cells (point e) (outgoing e) le he]).
+  apply/allP=> x; rewrite inE=> xin.
+  suff : valid_edge x (point e) by rewrite /valid_edge/generic_trajectories.valid_edge ppe.
+  move: xin=> /orP[/eqP xin | xin]; first by rewrite xin lonew'.
+  rewrite (opening_cells_high vl vp) // ?mem_rcons inE mem_sort in xin.
+  case/orP: xin=> [/eqP -> // | xin ].
+  apply: valid_edge_extremities; apply/orP; left.
+  by apply: oute.
+set lec := head lcc cc.
+have [cc' ccq] : exists cc', rcons cc lcc = lec :: cc'.
+  rewrite /lec; case: (cc) => [ | a b]; first by exists [::].
+  by exists (rcons b lcc).
+have lecc : lec \in rcons cc lcc by rewrite ccq inE eqxx.
+have lecin : lec \in open.
+  by rewrite ocd -cat_rcons !mem_cat lecc ?orbT.
+have vhlece : valid_edge (high lec) (point e).
+  by have := seq_valid_high sval (map_f high lecin).
+have vhlecp : valid_edge (high lec) pt'.
+  by move: vhlece; rewrite /valid_edge/generic_trajectories.valid_edge ppe.
+move: adj'; rewrite -catA -cat_rcons =>
+  /adjacent_catW[] _ /adjacent_catW[] adjo _.
+have adjo' : adjacent_cells (opening_cells (point e) (outgoing e) le he).
+  by rewrite /opening_cells oca_eq.
+have [yle | yabove] := lerP (p_y pt') (p_y (point e)).
+  have pale : pt' >>> le.
+    have /mem_seq_split [s1 [s2 s1s2q]] := cnew.
+    case s1q : s1 => [ | c0 s1'].
+      move: lonew; rewrite /opening_cells oca_eq s1s2q s1q /= => <-.
+      by move: pin=> /andP[].
+    have lco : low c \in outgoing e.
+      have := seq_low_high_shift
+                (opening_cells_not_nil (outgoing e) le he (point e))
+                adjo'.
+      rewrite /opening_cells oca_eq /= s1s2q s1q /= => - [].
+      rewrite -[RHS]/[seq high i | i <- (c0 :: s1') ++ c :: s2] -s1q -s1s2q.
+      move: (opening_cells_high vl vp oute); rewrite /opening_cells oca_eq.
+      move=> ->=> /rcons_inj [] lows _.
+      have : low c \in [seq low i | i <- s1' ++ c :: s2].
+        by apply: map_f; rewrite mem_cat inE eqxx orbT.
+      by rewrite lows mem_sort.
+    have vlce : valid_edge (low c) (point e).
+      by apply: valid_edge_extremities; rewrite (oute lco).
+    move: pin => /andP[] + _; rewrite under_pvert_y; last first.
+      by move: vlce; rewrite /valid_edge/generic_trajectories.valid_edge ppe.
+    rewrite -(same_pvert_y vlce)//.
+    by rewrite on_pvert ?yle // -(eqP (oute lco)) // left_on_edge.
+  have plec : contains_point' pt' lec.
+    rewrite /contains_point' -leq pale.
+    rewrite under_pvert_y //.
+    apply: (le_trans yle).
+    rewrite -(same_pvert_y vhlece)//.
+    rewrite -under_pvert_y //.
+    case ccq': cc => [ | cc0 ccs].
+      by move: ccq; rewrite ccq' /= => -[] <- _; rewrite -heq; apply/underW.
+    suff/allct/andP[] : lec \in cc by [].
+    by move: ccq; rewrite ccq' /= => -[] -> _; rewrite inE eqxx.
+  have [/eqP lbnd' | safe] := boolP(left_limit lec == p_x pt').
+    rewrite closeeq has_cat.
+    have := (left_limit_has_right_limit lecin inboxp lbnd' plec).
+    move=> /hasP[x]; rewrite mem_rcons inE => /orP[] xin xP.
+      by apply/orP; right; apply/hasP; exists x=> //; rewrite inE xin.
+    by apply/orP; left; apply/hasP; exists x.
+  have lbnd2 : left_limit lec < p_x pt'.
+    rewrite lt_neqAle safe /=.
+    rewrite ppe; apply/lexePt_xW/lexPtW.
+    by apply: (btm_left lecin).
+  rewrite closeeq has_cat; apply/orP; right.
+  apply/hasP; exists (close_cell (point e) lec).
+    rewrite inE; apply/orP; right; rewrite /closing_cells -map_rcons.
+    by apply:map_f; rewrite ccq inE eqxx.
+  have vlec : valid_cell lec (point e).
+    by apply/andP/(allP sval).
+  rewrite inside_closed'E /left_limit.
+  have [-> -> ->]:= close_cell_preserve_3sides (point e) lec.
+  move: plec=> /andP[] -> ->.
+  by rewrite (close_cell_right_limit) // lbnd2 ppe lexx.
+have plcc : contains_point' pt' lcc.
+  have puhe : pt' <<= he.
+    have /mem_seq_split [s1 [s2 s1s2q]] := cnew.
+    elim /last_ind: {2} (s2) (erefl s2) => [ | s2' c2 _] s2q.
+      move: highnew; rewrite /opening_cells oca_eq s1s2q s2q cats1 map_rcons.
+      move=>/rcons_inj[] _ <-.
+      by move: pin => /andP[].
+    have hco : high c \in outgoing e.
+      have := opening_cells_high vl vp oute.
+      rewrite /opening_cells oca_eq s1s2q s2q.
+      rewrite (_ : [seq high i | i <- s1 ++ c :: rcons s2' c2] =
+             rcons [seq high i | i <- s1 ++ c :: s2'] (high c2)); last first.
+        by rewrite !map_cat /= map_rcons -!cats1 /= -!catA /=.
+      move=> /rcons_inj[] his _.
+      have : high c \in [seq high i | i <- s1 ++ c :: s2'].
+        by apply: map_f; rewrite mem_cat inE eqxx orbT.
+      by rewrite his mem_sort.
+    have vhce : valid_edge (high c) (point e).
+      by apply: valid_edge_extremities; rewrite (oute hco).
+    move: (pin) => /andP[] _; rewrite under_pvert_y; last first.
+      by move: vhce; rewrite /valid_edge/generic_trajectories.valid_edge ppe.
+    rewrite -(same_pvert_y vhce)// on_pvert; last first.
+      by rewrite -(eqP (oute hco)) // left_on_edge.
+    move=> ple.
+    have ppe': p_y pt' = p_y (point e).
+      by apply: le_anti; rewrite ple (ltW yabove).
+    have/eqP -> : pt' == point e :> pt by rewrite pt_eqE ppe ppe' !eqxx.
+    by apply/underW.
+  rewrite /contains_point'; rewrite -heq puhe andbT.
+  have vllcce : valid_edge (low lcc) (point e).
+    by apply: (seq_valid_low sval); apply/map_f.
+  have vllccp : valid_edge (low lcc) pt'.
+    by move: vllcce; rewrite /valid_edge/generic_trajectories.valid_edge ppe.
+  rewrite under_pvert_y // -?ltNge.
+  apply: le_lt_trans yabove.
+  rewrite -(same_pvert_y vllcce)// leNgt -strict_under_pvert_y //.
+  by have /andP[] := lcc_ctn.
+have [/eqP lbnd' | safe] := boolP(left_limit lcc == p_x pt').
+  rewrite closeeq has_cat /= orbA.
+  have := left_limit_has_right_limit lcco inboxp lbnd' plcc.
+  move/hasP=> [x]; rewrite mem_rcons inE=> /orP[/eqP -> ->| xin xP].
+    by rewrite orbT.
+  by apply/orP; left; apply/orP; left; apply/hasP; exists x.
+have lbnd2 : left_limit lcc < p_x pt'.
+  rewrite lt_neqAle safe /=.
+  rewrite ppe; apply/lexePt_xW/lexPtW.
+  by apply: (btom_left_corners lcco).
+rewrite closeeq has_cat; apply/orP; right.
+apply/hasP; exists (close_cell (point e) lcc).
+  by rewrite inE mem_rcons inE eqxx ?orbT.
+have vlcc : valid_cell lcc (point e).
+  by apply/andP/(allP sval).
+rewrite inside_closed'E /left_limit.
+have [-> -> ->]:= close_cell_preserve_3sides (point e) lcc.
+move: plcc=> /andP[] -> ->.
+by rewrite (close_cell_right_limit) // lbnd2 ppe lexx.
+Qed.
+
+(* This statement is the normal lifting of the previous statement from
+ the default case to the complete step function.  However, this proof
+ is not used for now, so we make it a definition just to keep in records what
+ should be the lemma statement. *)
+Definition TODO_step_keeps_cover_left_border :=
+  let s' :=  step (Bscan fop lsto lop cls lstc lsthe lstx) e in
+  {in state_open_seq s', forall c p, inside_box p -> left_limit c = p_x p ->
+     contains_point' p c ->
+     has (inside_closed' p) (state_closed_seq s')}.
+(*
+Proof.
+have [ + [+ [+ []]]] := step_keeps_invariant1.
+set open0 := state_open_seq _ => + + + + + step_res c cin pt.
+have := step_keeps_left_pts_inf.
+have noc' : {in cell_edges open ++ outgoing e &, no_crossing R}.
+  by move=> g1 g2 g1in g2in; apply: noc; rewrite /= !mem_cat orbA
+   -2!mem_cat ?g1in ?g2in.
+*)
+
+(* The following statement is not necessary for a safety statement, since a
+  vertical cell decomposition that returns an empty list of cells would indeed
+  return only cells whose interior is safe. *)
+
+Lemma step_keeps_cover_default :
+  let '(fc, cc, lcc, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+    let '(nos, lno) := opening_cells_aux (point e)
+       (sort (@edge_below _) (outgoing e)) le he in
+  cover_left_of p (fc ++ nos ++ lno :: lc)
+    (cls ++ lstc :: rcons (closing_cells (point e) cc)
+         (close_cell (point e) lcc)).
+Proof.
+case oe : (open_cells_decomposition _ _) =>
+ [[[[[fc cc] lcc] lc] le] he].
+case oca_eq:(opening_cells_aux _ _ _ _) => [nos lno].
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have oc_eq : opening_cells (point e) (outgoing e) le he = rcons nos lno.
+  by rewrite /opening_cells oca_eq.
+have [pal puh vl vp nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+      (inside_box_between inbox_e) oe.
+remember (fc ++ nos ++ lno :: lc) as open' eqn:openeq.
+remember (cls ++ lstc :: rcons (closing_cells (point e) cc)
+           (close_cell (point e) lcc)) as closed' eqn:closeeq.
+have := invariant1_default_case.
+rewrite oe oca_eq => - [] clae' [] sval' [] adj' []cbtom' rfo'.
+have := step_keeps_left_limit_has_right_limit_default.
+have := step_keeps_btom_left_corners_default.
+rewrite oe oca_eq -openeq.
+move=> btm_left' left_border_in'.
+move=> q inbox_q limrq.
+have [qright | qleft] := boolP(lexPt (point e) q).
+  rewrite /inside_box in inbox_q.
+  move: (inbox_q) => /andP[] bet_q _.
+  have [c cin ctn]:= exists_cell cbtom' adj' bet_q.
+  move: cin.
+
+  have subpq1 : subpred (lexePt p) (lexePt q).
+    by move=> x px; apply/(lexePt_trans limrq).
+  have limr : all (lexePt p) [seq point x | x <- future_events].
+    by apply/allP=> x /mapP [ev evc ->]; apply: plexfut.
+  have limrq1 := sub_all subpq1 limr.
+  rewrite -catA -cat_rcons !mem_cat orbCA -mem_cat=> /orP[] cin; last first.
+    have [inc | ninc] := boolP(inside_open' q c).
+      apply/orP; left;  rewrite openeq -cat_rcons !has_cat orbCA -has_cat.
+      by apply/orP; right; apply/hasP; exists c.
+    have cin0 : c \in open.
+     by rewrite ocd -cat_rcons !mem_cat orbCA -mem_cat cin ?orbT.
+    have cin1 : c \in open'.
+      by rewrite openeq -cat_rcons !mem_cat orbCA -mem_cat cin orbT.
+    apply/orP; right.
+    rewrite closeeq -cat_rcons has_cat; apply/orP; left.
+    move: ninc; rewrite inside_open'E; rewrite lt_neqAle.
+    move: (ctn)=> /andP[] -> -> /=.
+    have -> : left_limit c <= p_x q.
+      have : p_x (point e) <= p_x q by apply/lexePt_xW/lexPtW.
+      apply: le_trans.
+      rewrite /left_limit -[X in X <= _]/(p_x (bottom_left_corner c)).
+      by apply/lexePt_xW/lexPtW; apply: btm_left.
+   have -> : p_x q <= open_limit c.
+      rewrite /open_limit le_min.
+      have extg :
+         forall g, g \in [:: bottom; top] -> p_x q <= p_x (right_pt g).
+        move: inbox_q=> /andP[] _ /andP[] /andP[] _ /ltW + /andP[] _ /ltW.
+        by move=> A B g; rewrite !inE=> /orP[] /eqP ->.
+      have intg g : has (event_close_edge g) future_events ->
+           p_x q <= p_x (right_pt g).
+        move=>/hasP[] ev' ev'in /eqP ->.
+        by apply/lexePt_xW/(lexePt_trans limrq)/(allP limr)/map_f.
+      move: clae'; rewrite -catA -openeq=> /allP /(_ _ cin1) /andP[].
+      by move=> /orP[/extg | /intg] -> /orP[/extg | /intg] ->.
+    rewrite !andbT negbK => /eqP atll.
+    by apply: (left_limit_has_right_limit _ inbox_q atll ctn).
+
+  have limrq' : forall e, e \in future_events -> lexePt q (point e).
+    by move/(sub_all subpq1): (limr); rewrite all_map=>/allP.
+  have [vertp | rightofp] : left_limit c = p_x q \/ left_limit c < p_x q.
+      have cin' :  c \in opening_cells (point e) (outgoing e) le he.
+        by rewrite oc_eq.
+      rewrite (opening_cells_left oute vl vp cin').
+      move: qright=> /lexPtW/lexePt_xW; rewrite le_eqVlt=> /orP[/eqP -> | ->].
+        by left.
+      by right.
+    rewrite closeeq (left_border_in' _ _ _ _ vertp ctn) ?orbT //.
+    by rewrite openeq -cat_rcons !mem_cat cin ?orbT.
+  apply/orP; left; rewrite openeq -cat_rcons; rewrite !has_cat.
+  apply/orP; right; apply/orP; left.
+  apply/hasP; exists c=> //.
+  rewrite inside_open'E rightofp /open_limit le_min.
+  have [/andP[_ ->] /andP[_ ->]] : valid_cell c q.
+    have := opening_valid oute vl vp=> /allP; rewrite oc_eq=> /(_ c cin).
+    move=> /andP[] vlce vhce.
+    have := (allP clae' c); rewrite -catA -cat_rcons !mem_cat cin orbT.
+    move=> /(_ isT).
+    move=> /andP[] end_edge_lc end_edge_hc.
+    have :=
+      valid_between_events (lexPtW qright) limrq' vlce inbox_q end_edge_lc.
+    have :=
+      valid_between_events (lexPtW qright) limrq' vhce inbox_q end_edge_hc.
+    move=> vhcq vlcq.
+    by split.
+  by move: ctn=> /andP[] -> ->.
+have qe : p_x q <= p_x (point e).
+  by apply: lexePt_xW; rewrite lexePtNgt.
+have inclosing : forall c, c \in cc -> inside_open' q c ->
+  (forall c, c \in cc -> valid_edge (low c) (point e) &&
+     (valid_edge (high c) (point e))) ->
+  exists2 c', c' \in closing_cells (point e) cc & inside_closed' q c'.
+  move=> c cin ins allval.
+  exists (close_cell (point e) c).
+    by apply: map_f.
+  move: ins; rewrite inside_open'E andbA=>/andP[] ctn /andP[liml _] /=.
+  move: ctn=>/andP [qlc qhc].
+  rewrite /contains_point/close_cell /=.
+  have [p1 vip1] := exists_point_valid (proj1 (andP (allval _ cin))).
+  have [p2 vip2] := exists_point_valid (proj2 (andP (allval _ cin))).
+  have [onl x1] := intersection_on_edge vip1.
+  have [onh x2] := intersection_on_edge vip2.
+  by rewrite inside_closed'E vip1 vip2 qlc qhc; case: ifP=> [p1e | p1ne];
+    case: ifP=> [p2e | p2ne]; rewrite liml /right_limit /= -?x2 -?x1.
+(* TODO : inclosing and inclosel could probably be instances of a single
+  statement. maybe replacing cc with rcons cc lcc in the statement of
+  inclosing. *)
+have inclosel : inside_open' q lcc ->
+  inside_closed' q (close_cell (point e) lcc).
+  rewrite inside_open'E andbA=> /andP[] /andP[qlc qhc] /andP[liml _] /=.
+  have lccin : lcc \in open by rewrite ocd !mem_cat inE eqxx ?orbT.
+  have [p1 vip1] := exists_point_valid (proj1 (andP (allP sval _ lccin))).
+  have [p2 vip2] := exists_point_valid (proj2 (andP (allP sval _ lccin))).
+  have [onl x1] := intersection_on_edge vip1.
+  have [onh x2] := intersection_on_edge vip2.
+  by rewrite inside_closed'E /close_cell vip1 vip2 qlc qhc /=;
+    case: ifP=> [p1e | p1ne]; case: ifP=> [p2e | p2ne];
+    rewrite liml /right_limit /= -?x2 -?x1.
+move: qleft; rewrite -lexePtNgt lexePt_eqVlt.
+have svalcc :
+   forall c : cell,
+     c \in cc -> valid_edge (low c) (point e) && valid_edge (high c) (point e).
+   by move=> x xin; apply: (allP sval); rewrite ocd !mem_cat xin orbT.
+move=> /orP[/eqP qe' | qlte ].
+  rewrite qe'.
+  apply/orP; right; apply/hasP.
+  set opc := head lcc cc.
+  have opcin' : opc \in open.
+    rewrite ocd -cat_rcons !mem_cat orbCA; apply/orP; left.
+    by rewrite /opc; case: (cc)=> [ | ? ?]; rewrite /= inE eqxx.
+  have adjcc : adjacent_cells cc.
+    by move: adj; rewrite ocd => /adjacent_catW[] _ /adjacent_catW[].
+  have opc_ctn' : contains_point' (point e) opc.
+    rewrite /contains_point' -leq pal /=.
+    case ccq : cc => [ | c1 cc']; rewrite /opc ccq /=.
+      by rewrite -heq; apply underW.
+    by have /allct/andP[] : c1 \in cc by rewrite ccq inE eqxx.
+  have [leftb | ] :=
+    boolP(p_x (last dummy_pt (left_pts opc)) < p_x (point e)); last first.
+    move=> nleftb.
+    have := btom_left_corners opcin';rewrite /bottom_left_corner.
+    rewrite /lexPt (negbTE nleftb) /= => /andP[/eqP sx yl].
+    have /hasP[x xin xP] :=
+      left_limit_has_right_limit opcin' inbox_e sx opc_ctn'.
+    exists x=> //.
+    by rewrite closeeq -cat_rcons mem_cat xin.
+  have : inside_open' (point e) opc.
+    have elt: all (lexePt (point e)) [seq point e0 | e0 <- e :: future_events].
+      rewrite /=; rewrite lexePt_eqVlt eqxx /=.
+      move: sort_evs; rewrite path_sortedE; last exact: lexPtEv_trans.
+      move=> /andP[cmpE _]; apply/allP=> x /mapP[ev evin ->].
+      by apply/lexPtW/(allP cmpE).
+    by apply: (contains_to_inside_open' sval clae inbox_e leftb).
+  move: (opc_ctn').
+  rewrite -qe'=> einopc einop'.
+  case ccq : cc => [ | cc1 cc'] /=.
+    exists (close_cell (point e) lcc).
+      by rewrite closeeq !(mem_cat, inE, mem_rcons) eqxx ?orbT.
+    by apply: inclosel; move: einop'; rewrite /opc ccq.
+  have opcincc : opc \in cc by rewrite /opc ccq /= inE eqxx.
+  have [it itin itP]:= inclosing opc opcincc einop' svalcc.
+  exists it; last by [].
+  by rewrite closeeq mem_cat inE mem_rcons inE itin ?orbT.
+have /orP[| already_closed]:=
+    cover_left_of_e inbox_q (lexPtW qlte); last first.
+  by rewrite closeeq -cat_rcons has_cat already_closed orbT.
+rewrite openeq ocd -2!cat_rcons 2!has_cat orbCA.
+move=> /orP[/hasP[opc opcin qinopc] | keptopen].
+  move: opcin; rewrite mem_rcons inE=> /orP[opclcc | opcin]; last first.
+    have [it it1 it2] := inclosing _ opcin qinopc svalcc.
+    apply/orP; right; apply/hasP.
+    by exists it=> //; rewrite closeeq !(inE, mem_cat, mem_rcons) it1 ?orbT.
+  apply/orP; right; apply/hasP; exists (close_cell (point e) lcc).
+    by rewrite closeeq !(mem_cat, inE, mem_rcons) eqxx ?orbT.
+  by apply: inclosel; rewrite -(eqP opclcc).
+apply/orP; left; apply/hasP.
+move: keptopen; rewrite -has_cat=>/hasP[it + it2].
+by rewrite mem_cat=> infclc; exists it; rewrite // !mem_cat orbCA infclc orbT.
+Qed.
+
+Lemma step_keeps_right_limit_closed_default :
+  let '(fc, cc, lcc, lc, le, he) :=
+    open_cells_decomposition open (point e) in
+    let '(nos, lno) := opening_cells_aux (point e)
+       (sort (@edge_below _) (outgoing e)) le he in
+  {in  rcons(cls ++
+          lstc :: closing_cells (point e) cc) (close_cell (point e) lcc) &
+     future_events, forall c e, right_limit c <= p_x (point e)}.
+Proof.
+case oe : (open_cells_decomposition _ _) =>
+ [[[[[fc cc] lcc] lc] le] he].
+case oca_eq:(opening_cells_aux _ _ _ _) => [nos lno].
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+move=> c ev; rewrite mem_rcons=> cin evin.
+suff rl_ev' : right_limit c <= p_x (point e).
+  apply: (le_trans rl_ev').
+  move: sort_evs; rewrite /= path_sortedE; last by apply: lexPtEv_trans.
+  move=> /andP[] /allP /(_ ev evin) /orP[/ltW // | /andP[] /eqP -> _] _.
+  by apply: le_refl.
+have := sval; rewrite ocd /seq_valid !all_cat=> /andP[] _ /andP[] svalcc /=.
+move=> /andP[] /andP[] vllcc vhlcc _.
+move: cin; rewrite inE => /orP[/eqP -> | ].
+  by have := right_limit_close_cell vllcc vhlcc=> ->; apply: le_refl.
+rewrite mem_cat=> /orP[cold | ].
+  by apply: closed_right_limit; rewrite mem_rcons inE cold orbT.
+rewrite inE=> /orP[cold | ].
+  by apply: closed_right_limit; rewrite mem_rcons inE cold.
+move=> /mapP [c' c'in ->].
+have /andP[vlc' vhc'] := allP svalcc c' c'in.
+by rewrite (right_limit_close_cell vlc' vhc') le_refl.
+Qed.
+
+(* TODO : move to other file *)
+Lemma close_cell_in (p' : pt) c :
+  valid_cell c p' ->
+  p' \in (right_pts (close_cell p' c): seq pt).
+Proof.
+move=> [] vl vh.
+rewrite /close_cell; rewrite (pvertE vl) (pvertE vh) /=.
+by case: ifP=> [/eqP <- | ];
+  case: ifP=> [/eqP <- // | _ ]; rewrite !inE eqxx ?orbT.
+Qed.
+
+Lemma last_closing_side_char pp fc cc lcc lc le he :
+  open_cells_decomposition open (point e) = (fc, cc, lcc, lc, le, he) ->
+  cc != [::] ->
+  in_safe_side_right pp (close_cell (point e) lcc) =
+   [&& p_x pp == p_x (point e), p_y (point e) < p_y pp & pp <<< he].
+Proof.
+move=> oe ccn0.
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+      (inside_box_between inbox_e) oe.
+have lccin : lcc \in open by rewrite ocd !(mem_cat, inE) eqxx !orbT.
+have /andP [vlcc vhcc] : valid_edge (low lcc) (point e) &&
+  valid_edge (high lcc) (point e) by apply: (allP sval).
+have := right_limit_close_cell vlcc vhcc.
+rewrite /in_safe_side_right.
+move=> ->.
+have [/eqP samex /= | ] := boolP (p_x pp == p_x (point e)); last by [].
+have [-> -> _] := close_cell_preserve_3sides (point e) lcc.
+rewrite -heq.
+have eonllcc : (point e) === low lcc.
+  have := open_cells_decomposition_point_on cbtom adj
+            (inside_box_between inbox_e) sval oe.
+  elim /last_ind: {-1} (cc) (erefl cc) ccn0 => [ | cc' cc2 _] ccq // _.
+  have : cc2 \in rcons cc' cc2 by rewrite mem_rcons mem_head.
+  move=> + /(_ cc2) =>/[swap] /[apply].
+  move: adj; rewrite ocd ccq cat_rcons; do 2 move =>/adjacent_catW[] _.
+  by move=> /= /andP[] /eqP ->.
+have vppl : valid_edge (low lcc) pp by rewrite (same_x_valid _ samex).
+have vpphe : valid_edge he pp by rewrite (same_x_valid _ samex).
+rewrite (under_pvert_y vppl) (same_pvert_y vppl samex) -ltNge.
+rewrite (on_pvert eonllcc).
+rewrite (andbC _ (pp <<< he)).
+have [ppuh | ] := boolP (pp <<< he); last by [].
+have [ppae | ] := boolP (p_y (point e) < p_y pp); last by [].
+rewrite /right_pts/close_cell (pvertE vlcc) (pvertE vhcc) /=.
+rewrite !pt_eqE !eqxx /=.
+rewrite (on_pvert eonllcc) eqxx.
+rewrite -heq; move: (puh).
+rewrite (strict_under_pvert_y vhe) lt_neqAle eq_sym=>/andP[]/negbTE -> _.
+have ppuhy : (p_y pp == pvert_y (point e) he) = false.
+  apply/negbTE; move: (ppuh).
+  rewrite (strict_under_pvert_y vpphe) lt_neqAle=> /andP[] + _.
+  by rewrite (same_pvert_y vpphe samex).
+rewrite !(@in_cons pt).
+rewrite !pt_eqE ppuhy andbF orbF.
+move: ppae; rewrite lt_neqAle eq_sym=>/andP[] /negbTE -> _.
+by rewrite andbF.
+Qed.
+
+Lemma first_closing_side_char pp fc cc1 cc lcc lc le he :
+  open_cells_decomposition open (point e) = (fc, cc1 :: cc, lcc, lc, le, he) ->
+  in_safe_side_right pp (close_cell (point e) cc1) =
+   [&& p_x pp == p_x (point e), p_y pp < p_y (point e) & pp >>> le].
+Proof.
+move=> oe.
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [/= leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+      (inside_box_between inbox_e) oe.
+have cc1in : cc1 \in open by rewrite ocd !(mem_cat, inE) eqxx !orbT.
+have /andP [vlcc1 vhcc1] : valid_edge (low cc1) (point e) &&
+  valid_edge (high cc1) (point e) by apply: (allP sval).
+have := right_limit_close_cell vlcc1 vhcc1.
+rewrite /in_safe_side_right.
+move=> ->.
+have [/eqP samex /= | ] := boolP (p_x pp == p_x (point e)); last by [].
+have [-> -> _] := close_cell_preserve_3sides (point e) cc1.
+rewrite -leq.
+have eonhcc1 : (point e) === high cc1.
+  have := open_cells_decomposition_point_on cbtom adj
+            (inside_box_between inbox_e) sval oe.
+  by move=> /(_ cc1 (mem_head _ _)).
+have vpph : valid_edge (high cc1) pp by rewrite (same_x_valid _ samex).
+have vpple : valid_edge le pp by rewrite (same_x_valid _ samex).
+rewrite (strict_under_pvert_y vpph) (same_pvert_y vpph samex).
+rewrite (on_pvert eonhcc1).
+have [ppue /= | ] := boolP (p_y pp < p_y (point e)); last by [].
+have [ppal/= | ] := boolP (pp >>> le); last by [].
+rewrite /right_pts/close_cell (pvertE vlcc1) (pvertE vhcc1) /=.
+rewrite !pt_eqE !eqxx /=.
+rewrite (on_pvert eonhcc1) eqxx.
+rewrite -leq; move: (pal).
+rewrite (under_pvert_y vle) -ltNge lt_neqAle eq_sym => /andP[] /negbTE -> _.
+have ppaly : (p_y pp == pvert_y (point e) le) = false.
+  apply/negbTE; move: (ppal).
+  rewrite (under_pvert_y vpple) -ltNge lt_neqAle eq_sym=> /andP[] + _.
+  by rewrite (same_pvert_y vpple samex).
+rewrite !(@in_cons pt) !pt_eqE ppaly andbF.
+move: ppue; rewrite lt_neqAle eq_sym=>/andP[] /negbTE -> _.
+by rewrite andbF.
+Qed.
+
+Lemma middle_closing_side_char pp fc cc1 cc lcc lc le he :
+  open_cells_decomposition open (point e) = (fc, cc1 :: cc, lcc, lc, le, he) ->
+  ~~ has (in_safe_side_right pp) [seq close_cell (point e) c | c <- cc].
+Proof.
+move=> oe.
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+      (inside_box_between inbox_e) oe.
+rewrite -all_predC; apply/allP=> c /mapP [c' cin cq] /=.
+have /andP[vlc' vhc']: valid_edge (low c') (point e) &&
+       valid_edge (high c') (point e).
+  by apply: (allP sval); rewrite ocd !(mem_cat, inE) cin !orbT.
+have := right_limit_close_cell vlc' vhc'.
+have allon := open_cells_decomposition_point_on cbtom adj
+            (inside_box_between inbox_e) sval oe.
+have /allon eonh : c' \in cc1 :: cc by rewrite inE cin orbT.
+have eonl : point e === low c'.
+  have [s1 [s2 ccq]] := mem_seq_split cin.
+  have := adj; rewrite ocd ccq /= => /adjacent_catW[] _ /=.
+  rewrite /= cat_path=> /andP[] + _.
+  rewrite cat_path=> /andP[] _ /= /andP[] /eqP <- _.
+  by apply: allon; rewrite ccq -cat_cons mem_cat mem_last.
+rewrite /in_safe_side_right cq=> ->.
+have [-> -> _] := close_cell_preserve_3sides (point e) c'.
+have [/eqP samex /= | ] := boolP (p_x pp == p_x (point e)); last by [].
+have vpph : valid_edge (high c') pp by rewrite (same_x_valid _ samex).
+have vppl : valid_edge (low c') pp by rewrite (same_x_valid _ samex).
+rewrite (strict_under_pvert_y vpph) (same_pvert_y vpph samex).
+rewrite (on_pvert eonh).
+rewrite (under_pvert_y vppl) (same_pvert_y vppl samex).
+rewrite (on_pvert eonl).
+by case : ltP; rewrite // le_eqVlt=> ->; rewrite orbT andbF.
+Qed.
+
+Lemma mem_no_dup_seq {A: eqType} (s : seq A) : no_dup_seq s =i s.
+Proof.
+elim: s => [ | a [ | b s] Ih]; first by [].
+  by [].
+rewrite -[no_dup_seq _]/(if a == b then no_dup_seq (b :: s) else
+                           a :: no_dup_seq (b :: s)).
+have [ab | anb] := (eqVneq a b).
+  by move=> c; rewrite Ih !inE ab; case: (c == b).
+by move=> c; rewrite 2!inE Ih.
+Qed.
+
+Lemma single_closing_side_char fc lcc lc le he pp :
+  open_cells_decomposition open (point e) = (fc, [::], lcc, lc, le, he) ->
+  in_safe_side_right pp (close_cell (point e) lcc) =
+  ([&& p_x pp == p_x (point e), pp >>> le & p_y pp < p_y (point e)] ||
+   [&& p_x pp == p_x (point e), pp <<< he & p_y (point e) < p_y pp]).
+Proof.
+move=> oe.
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [/= leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+      (inside_box_between inbox_e) oe.
+have /andP[vllcc vhlcc] : valid_edge (low lcc) (point e) &&
+   valid_edge (high lcc) (point e).
+  by apply: (allP sval); rewrite ocd /= !(mem_cat, inE) eqxx !orbT.
+have [ppe | ppne] := eqVneq (pp : pt) (point e).
+  rewrite ppe !lt_irreflexive !andbF.
+  apply /negbTE.
+  have einr := close_cell_in (conj vllcc vhlcc).
+  by rewrite /in_safe_side_right einr !andbF.
+have := right_limit_close_cell vllcc vhlcc.
+rewrite /in_safe_side_right.
+move=> ->.
+have [/eqP samex /= | ] := boolP (p_x pp == p_x (point e)); last by [].
+have [-> -> _] := close_cell_preserve_3sides (point e) lcc.
+rewrite -heq -leq.
+have puhy : p_y (point e) < pvert_y (point e) he.
+  by rewrite -(strict_under_pvert_y vhe).
+have paly :  pvert_y (point e) le < p_y (point e).
+  by rewrite ltNge -(under_pvert_y vle).
+rewrite /close_cell/right_pts -leq -heq (pvertE vle) (pvertE vhe).
+rewrite (@mem_no_dup_seq pt) !(@in_cons pt) (negbTE ppne) /=.
+have [vpple vpphe] : valid_edge le pp /\ valid_edge he pp.
+  by rewrite !(same_x_valid _ samex).
+have [pu | ] := ltrP (p_y pp) (p_y (point e)).
+  rewrite !pt_eqE /= andbT samex /=.
+  rewrite ltNge le_eqVlt pu orbT andbF orbF.
+  have ppuhe : pp <<< he.
+    rewrite strict_under_pvert_y // (same_pvert_y _ samex) //.
+    apply: (lt_trans pu).
+    by rewrite -strict_under_pvert_y.
+  rewrite (andbCA _ (pp >>> le)).
+  have [ppale /= | ] := boolP (pp >>> le); last by [].
+  have ppaly : (p_y pp == pvert_y (point e) le) = false.
+    apply/negbTE; move: (ppale).
+    rewrite (under_pvert_y vpple) -ltNge lt_neqAle eq_sym=> /andP[] + _.
+    by rewrite (same_pvert_y vpple samex).
+  have ppuhy : (p_y pp == pvert_y (point e) he) = false.
+    apply/negbTE; move: (ppuhe).
+    rewrite (strict_under_pvert_y vpphe) lt_neqAle=> /andP[] + _.
+    by rewrite (same_pvert_y vpphe samex).
+  by rewrite ppaly ppuhy ppuhe !eqxx.
+rewrite le_eqVlt => /orP[samey | /[dup] pa ->].
+   by case/negP: ppne; rewrite pt_eqE samex eq_sym samey !eqxx.
+rewrite andbF andbT /=.
+have [ppuhe /= | ] := boolP (pp <<< he); last by [].
+
+rewrite !pt_eqE /= samex /=.
+have ppale : pp >>> le.
+  rewrite under_pvert_y // (same_pvert_y _ samex) // -ltNge.
+  apply: (lt_trans _ pa).
+  by rewrite ltNge -under_pvert_y.
+have ppaly : (p_y pp == pvert_y (point e) le) = false.
+  apply/negbTE; move: (ppale).
+  rewrite (under_pvert_y vpple) -ltNge lt_neqAle eq_sym=> /andP[] + _.
+  by rewrite (same_pvert_y vpple samex).
+have ppuhy : (p_y pp == pvert_y (point e) he) = false.
+  apply/negbTE; move: (ppuhe).
+  rewrite (strict_under_pvert_y vpphe) lt_neqAle=> /andP[] + _.
+  by rewrite (same_pvert_y vpphe samex).
+by rewrite ppale ppuhy ppaly !eqxx.
+Qed.
+
+Lemma sides_equiv fc cc lcc lc le he:
+  open_cells_decomposition open (point e) = (fc, cc, lcc, lc, le, he) ->
+  forall p, has (in_safe_side_right p)
+              (rcons (closing_cells (point e) cc)
+                 (close_cell (point e) lcc)) ==
+       has (in_safe_side_left p)
+         (opening_cells (point e) (outgoing e) le he).
+Proof.
+move=> oe pp.
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+have [pal puh vle vhe nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+      (inside_box_between inbox_e) oe.
+have [ogq | ogq] := eqVneq (outgoing e) [::].
+  rewrite (single_opening_cell_side_char pp vle vhe pal puh ogq).
+  case ccq : cc => [ | cc1 cc'].
+    move: (oe); rewrite ccq=> oe'.
+    by rewrite /= (single_closing_side_char pp oe') orbF.
+  move: (oe); rewrite ccq=> oe'.
+  rewrite /= has_rcons.
+  rewrite (first_closing_side_char pp oe').
+  rewrite (negbTE (middle_closing_side_char _ oe')) orbF.
+  rewrite (last_closing_side_char pp oe'); last by [].
+  by rewrite (andbC (pp >>> le)) (andbC (pp <<< he)).
+rewrite /opening_cells; case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+have oeq : opening_cells (point e) (outgoing e) le he = rcons nos lno.
+ by rewrite /opening_cells oca_eq.
+have := opening_cells_aux_absurd_case vle vhe ogq oute; rewrite oca_eq /=.
+case nosq : nos => [ | fno nos'] // _.
+move: oeq; rewrite nosq=> oeq.
+rewrite /=.
+rewrite (first_opening_cells_side_char pp ogq vle vhe pal oute oeq).
+rewrite [in X in _ == X]has_rcons.
+rewrite (last_opening_cells_safe_side_char pp ogq vle vhe puh oute oeq).
+rewrite (negbTE (middle_opening_cells_side_char pp ogq vle vhe oute oeq)) orbF.
+case ccq : cc => [ | cc1 cc'].
+    move: (oe); rewrite ccq=> oe'.
+    rewrite /= (single_closing_side_char pp oe') orbF.
+    by rewrite (andbC (_ >>> _)) (andbC (_ <<< _)).
+move: (oe); rewrite ccq=> oe'.
+rewrite /= has_rcons.
+rewrite (first_closing_side_char pp oe').
+rewrite (negbTE (middle_closing_side_char _ oe')) orbF.
+by rewrite (last_closing_side_char pp oe'); last by [].
+Qed.
+
+End step.
+
+End proof_environment.
+
+Notation open_cell_side_limit_ok :=
+  (@open_cell_side_limit_ok R).
+
+Lemma inside_box_left_ptsP bottom top p :
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  inside_box bottom top p -> left_limit (start_open_cell bottom top)  < p_x p.
+Proof.
+move=> sok /andP[] _ /andP[] /andP[] valb _ /andP[] valt _.
+rewrite leftmost_points_max //.
+by case : (lerP (p_x (left_pt bottom)) (p_x (left_pt top))).
+Qed.
+
+Lemma cell_edges_start bottom top :
+  cell_edges [::(start_open_cell bottom top)] = [:: bottom; top].
+Proof. by []. Qed.
+
+Record common_invariant bottom top edge_set s
+  (events : seq event') :=
+  { inv1 : inv1_seq bottom top events (state_open_seq s);
+   lstx_eq : lst_x _ _ s = left_limit (lst_open s);
+   high_lsto_eq : high (lst_open s) = lst_high _ _ s;
+   edges_sub : {subset all_edges (state_open_seq s) events <=
+                    bottom :: top :: edge_set};
+   closed_events : close_edges_from_events events;
+   out_events : {in events, forall e, out_left_event e};
+   inbox_events : all (inside_box bottom top)
+           [seq point x | x <- events];
+   lex_events : sorted (@lexPtEv _) events;
+   sides_ok : all open_cell_side_limit_ok (state_open_seq s);
+}.
+
+Record common_general_position_invariant bottom top edge_set s
+  (events : seq event') :=
+  { gcomm : common_invariant bottom top edge_set s events;
+   general_pos :
+     all (fun ev => lst_x _ _ s < p_x (point ev)) events &&
+     sorted (fun e1 e2 => p_x (point e1) < p_x (point e2)) events;
+}.
+
+Record common_non_gp_invariant bottom top edge_set s (events : seq event') :=
+  { ngcomm : common_invariant bottom top edge_set s events;
+    lst_side_lex :
+        (1 < size (left_pts (lst_open s)))%N &&
+        path (@lexPt _) (nth dummy_pt (left_pts (lst_open s)) 1)
+         [seq point e | e <- events]}.
+
+(* This lemma only provides a partial correctness statement in the case
+  where the events are never aligned vertically.  This condition is
+  expressed by the very first hypothesis.  TODO: it relies on the assumption
+  that the first open cell is well formed.  This basically means that the
+  two edges have a vertical overlap.  This statement should be probably
+  be made clearer in a different way.
+
+  TODO: one should probably also prove that the final sequence of open
+  cells, here named "open", should be reduced to only one element. *)
+Record disjoint_general_position_invariant (bottom top : edge)
+ (edge_set : seq edge)
+ (s : scan_state) (events : seq event') :=
+ { op_cl_dis :
+     {in state_open_seq s & state_closed_seq s,
+       disjoint_open_closed_cells R};
+   cl_dis : {in state_closed_seq s &, disjoint_closed_cells R};
+   common_inv_dis : common_general_position_invariant bottom top
+        edge_set s events;
+   pairwise_open : pairwise (@edge_below _)
+       (bottom :: [seq high c | c <- state_open_seq s]);
+   closed_at_left :
+       {in state_closed_seq s & events,
+          forall c e, right_limit c <= p_x (point e)};
+   }.
+
+Definition dummy_state :=
+  Bscan [::] dummy_cell [::] [::] dummy_cell dummy_edge 0.
+
+Definition initial_state bottom top (events : seq event') :=
+  match events with
+  | [::] => dummy_state
+  | ev :: future_events =>
+    let (nos, lno) :=
+      opening_cells_aux (point ev) (sort (@edge_below _) (outgoing ev))
+           bottom top in
+      Bscan nos lno [::] [::]
+         (close_cell (point ev) (start_open_cell bottom top))
+         top (p_x (point ev))
+  end.
+
+Lemma initial_intermediate bottom top s events :
+(*   sorted (fun e1 e2=> p_x (point e1) < p_x (point e2)) events -> *)
+  bottom <| top ->
+  (* TODO: rephrase this statement in a statement that easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  all (inside_box bottom top) [seq point e | e <- events] ->
+  sorted (@lexPtEv _) events ->
+  {subset flatten [seq outgoing e | e <- events] <= s} ->
+  {in events, forall ev, out_left_event ev} ->
+  close_edges_from_events events ->
+  events != [::] ->
+  let op0 := (* close_cell (point (head (dummy_event _) events))  *)
+               (start_open_cell bottom top) in
+  all open_cell_side_limit_ok [:: op0] /\
+  cells_bottom_top bottom top [:: op0] /\
+  adjacent_cells [:: op0] /\
+  seq_valid [:: op0] (point (head dummy_event events)) /\
+  s_right_form [:: op0] /\
+  all (inside_box bottom top) [seq point e | e <- behead events] /\
+  close_edges_from_events (behead events) /\
+  {in behead events, forall e, out_left_event e} /\
+  close_alive_edges bottom top [:: op0] events  /\
+  valid_edge bottom (point (head dummy_event events)) /\
+  valid_edge top (point (head dummy_event events)) /\
+  open_cells_decomposition ([::] ++ [:: op0])
+        (point (head dummy_event events)) =
+       ([::], [::], op0, [::], low op0, high op0) /\
+  {in bottom :: top :: s &, no_crossing R} /\
+  {in all_edges [:: op0] events &, no_crossing R} /\
+  pairwise (@edge_below _) (bottom :: [seq high c | c <- [:: op0]]) /\
+  sorted (@lexPtEv _) (behead events).
+Proof.
+move=> boxwf startok nocs' evin lexev evsub out_evs cle.
+have nocs : {in bottom :: top :: s &, no_crossing R}.
+  by apply: inter_at_ext_no_crossing.
+case evsq : events => [ | ev future_events]; [by [] | move=> _ /=].
+set op0 := (start_open_cell bottom top).
+have op0sok : all open_cell_side_limit_ok ([::] ++ [::op0]).
+  by rewrite /= /op0 startok.
+have cbtom0 : cells_bottom_top bottom top [:: op0].
+  by rewrite /op0 /cells_bottom_top/cells_low_e_top/= !eqxx.
+have adj0: adjacent_cells [:: op0] by [].
+have sval0 : seq_valid [:: op0] (point ev).
+  move: evin; rewrite evsq /= => /andP[] /andP[] _ /andP[] ebot etop _.
+  have betW : forall a b c : R, a < b < c -> a <= b <= c.
+    by move=> a b c /andP[] h1 h2; rewrite !ltW.
+  by rewrite /= /valid_edge/generic_trajectories.valid_edge /= !betW.
+have rf0: s_right_form [:: op0] by rewrite /= boxwf.
+have inbox0 : all (inside_box bottom top) [seq point e | e <- future_events].
+  by move: evin; rewrite evsq map_cons /= => /andP[].
+have cle0 : close_edges_from_events future_events.
+  by move: cle; rewrite evsq /= => /andP[].
+have oute0 : {in future_events, forall e, out_left_event e}.
+  by move=> e ein; apply: out_evs; rewrite evsq inE ein orbT.
+have clae0 : close_alive_edges bottom top [:: op0] (ev :: future_events).
+  by rewrite /=/end_edge_ext !inE !eqxx !orbT.
+have noc0 : {in all_edges [:: op0] (ev :: future_events) &, no_crossing R}.
+  rewrite /=; move: nocs; apply sub_in2.
+  move=> x; rewrite -evsq !inE.
+  move=> /orP[ -> // | /orP[-> // | ]]; rewrite ?orbT //.
+  by move=> /evsub ->; rewrite !orbT.
+have [vb vt] : valid_edge bottom (point ev) /\ valid_edge top (point ev).
+  have /(allP sval0) : start_open_cell bottom top \in [:: op0].
+    by rewrite inE eqxx.
+  by rewrite /= => /andP[].
+have /andP[/andP[pal puh] _] : inside_box bottom top (point ev).
+   by apply: (@allP pt _ _ evin); rewrite evsq map_f// inE eqxx.
+have : open_cells_decomposition [:: op0] (point ev) =
+  ([::], [::], op0, [::], bottom, top).
+  apply: (open_cells_decomposition_single
+           (isT : adjacent_cells ([::] ++ [:: op0])) rf0 sval0 pal puh).
+have pw0 : pairwise (@edge_below _) (bottom :: [seq high c | c <- [::op0]]).
+  by rewrite /= !andbT /=.
+have lexev0 : sorted (@lexPtEv _) future_events.
+  by move: lexev; rewrite evsq=> /path_sorted.
+do 15 (split; first by []).
+by [].
+Qed.
+
+Lemma initial_common_invariant bottom top s events:
+  bottom <| top ->
+  (* TODO: rephrase this statement in a statement that easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  all (inside_box bottom top) [seq point e | e <- events] ->
+  sorted (@lexPtEv _) events ->
+  {subset flatten [seq outgoing e | e <- events] <= s} ->
+  {in events, forall ev, out_left_event ev} ->
+  close_edges_from_events events ->
+  events != [::] ->
+  common_invariant bottom top s
+    (initial_state bottom top events) (behead events).
+Proof.
+move=> boxwf startok nocs' evin lexev evsub out_evs cle evsn0.
+have :=
+  initial_intermediate boxwf startok nocs' evin lexev evsub out_evs cle evsn0.
+case evsq : events evsn0 => [ | ev future_events]; [by [] | move=> _].
+move=> [op0sok [cbtom0 [adj0 /=
+           [sval0 [rf0 [inbox0 [cle0 [oute0 [clae0 [vb
+             [vt [oe [nocs [noc0 [pw0 lexev0]]]]]]]]]]]]]]].
+have evins : ev \in events by rewrite evsq inE eqxx.
+set op0 := start_open_cell bottom top.
+case oca_eq:  (opening_cells_aux _ _ _ _) => [nos lno].
+set w := Bscan _ _ _ _ _ _ _.
+have [state1 ] : exists state1, state1 = w by exists w.
+rewrite /w => {w} st1q.
+set cl0 := lst_closed state1.
+set ops0 := [::] ++ [:: op0].
+have evsin0 : all (inside_box bottom top) [seq point ev | ev <- events].
+  exact: evin.
+have oute : out_left_event ev by apply: out_evs.
+have oute' : {in sort (@edge_below _) (outgoing ev), forall g,
+                  left_pt g == point ev}.
+  by move=> g; rewrite mem_sort; apply: oute.
+have edges_sub1 : {subset all_edges (rcons nos lno)
+        future_events <= [:: bottom, top & s]}.
+  move=> g; rewrite mem_cat=> /orP[ | gfut ]; last first.
+    have /evsub {}gfut : g \in events_to_edges events.
+      by rewrite evsq events_to_edges_cons mem_cat gfut orbT.
+    by rewrite !inE gfut; rewrite !orbT.
+  have := opening_cells_subset vb vt oute.
+  rewrite /opening_cells oca_eq=> main.
+  rewrite mem_cat=> /orP[] /mapP [c /main + ->] => /andP[]; rewrite !inE.
+    move=> /orP[-> | +] _; first by rewrite ?orbT.
+    move=> {}main; apply/orP; right; apply/orP; right.
+    by apply/evsub/flattenP; exists (outgoing ev); rewrite // map_f.
+  move=> _ /orP[-> |]; first by rewrite ?orbT.
+  move=> {}main; apply/orP; right; apply/orP; right.
+  by apply/evsub/flattenP; exists (outgoing ev); rewrite // map_f.
+have pin : inside_box bottom top (point ev).
+  by apply: (@allP pt _ _ evin); rewrite evsq /= inE eqxx.
+have inbox_all_events0 :
+  all (inside_box bottom top) [seq point x | x <- (ev :: future_events)].
+  by move: evin; rewrite evsq.
+have evlexfut : path (@lexPtEv _) ev future_events.
+  by move: lexev; rewrite evsq.
+have rf0' : s_right_form ([::] ++ [:: start_open_cell bottom top]) by [].
+have cle0' : close_edges_from_events (ev :: future_events) by rewrite -evsq.
+have := invariant1_default_case
+          inbox_all_events0 oute rf0' cbtom0 adj0 sval0 cle0' clae0 noc0
+          evlexfut.
+rewrite oe oca_eq /=.
+move=> /[dup] inv1 -[] clae1 [] sval' [] adj1 [] cbtom1 rf1.
+have rl0 : {in [::], forall c : cell, right_limit c <= p_x (point ev)} by [].
+have cl0q : cl0 = close_cell (point ev) op0 by rewrite /cl0 st1q.
+rewrite -cats1 in edges_sub1 sval'.
+have lstx1op : lst_x _ _ state1 = left_limit (lst_open state1).
+  have := opening_cells_left oute vb vt; rewrite /opening_cells.
+  by rewrite oca_eq st1q => -> //=; rewrite mem_rcons inE eqxx.
+have he1q' : high (lst_open state1) = lst_high _ _ state1.
+  rewrite st1q /=.
+  by have := opening_cells_aux_high_last vb vt oute'; rewrite oca_eq.
+move: lstx1op he1q'; rewrite st1q=> lstx1op he1q'.
+have oks1 : all open_cell_side_limit_ok (nos ++ [:: lno]).
+  have := pin => /andP[] /andP[] /underWC pal puh _.
+  have := opening_cells_side_limit vb vt pal puh oute.
+  by rewrite /opening_cells oca_eq cats1.
+by constructor.
+Qed.
+
+Lemma initial_common_general_position_invariant bottom top s events:
+  sorted (fun e1 e2=> p_x (point e1) < p_x (point e2)) events ->
+  bottom <| top ->
+  (* TODO: rephrase this statement in a statement that easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  all (inside_box bottom top) [seq point e | e <- events] ->
+  sorted (@lexPtEv _) events ->
+  {subset flatten [seq outgoing e | e <- events] <= s} ->
+  {in events, forall ev, out_left_event ev} ->
+  close_edges_from_events events ->
+  events != [::] ->
+  common_general_position_invariant bottom top s
+    (initial_state bottom top events) (behead events).
+Proof.
+move=> ltev boxwf startok nocs' evin lexev evsub out_evs cle evsn0.
+have ici := initial_common_invariant boxwf startok nocs' evin lexev evsub
+            out_evs cle evsn0.
+constructor; first by exact: ici.
+case evsq :  events => [ | ev1 evs] //.
+move: ltev; rewrite evsq /=.
+rewrite path_sortedE; last by  move=> x y z; apply: lt_trans.
+move=> /andP[] + ->; rewrite andbT.
+rewrite /initial_state /=.
+by case oca_eq:  (opening_cells_aux _ _ _ _).
+Qed.
+
+Lemma opening_cells_aux_event le he p gs nos lno :
+  valid_edge le p ->
+  valid_edge he p ->
+  p >>= le ->
+  p <<< he ->
+  {in gs, forall g, left_pt g == p} ->
+  opening_cells_aux p gs le he = (nos, lno) ->
+  (1 < size (left_pts lno))%N /\
+  nth dummy_pt (left_pts lno) 1 = p.
+Proof.
+move=> vle vhe; elim: gs le vle nos lno=>
+   [ | g1 gs Ih] le vle nos lno pal puh oute /=.
+  rewrite -/(vertical_intersection_point p le) (pvertE vle).
+  rewrite -/(vertical_intersection_point p he) (pvertE vhe).
+  case: ifP=> [/eqP abs1 | dif1 //]; last first.
+    case: ifP=> [/eqP abs2 | dif2 //]; last first.
+      by move=> [] _ <- /=.
+    by move=> [] _ <- /=; split; [ | rewrite -abs2].
+  move=> [] _.
+  rewrite (strict_under_pvert_y vhe) ltNge in puh.
+  move: puh => /negP; case.
+  by rewrite on_pvert // -abs1 pvert_on.
+case oca_eq : (opening_cells_aux p gs g1 he) => [no1 lno1].
+rewrite -/(vertical_intersection_point p le) (pvertE vle).
+have g1q : left_pt g1 = p.
+  have g1in : g1 \in g1 :: gs by rewrite inE eqxx.
+  by rewrite (eqP (oute g1 g1in)).
+have vg : valid_edge g1 p.
+  by rewrite -g1q valid_edge_left.
+case: ifP => [/eqP ponl | dif]; last first.
+  move=> [] A <-.
+  apply: (Ih g1 vg no1)=> //.
+    by rewrite -g1q; apply: left_pt_above.
+  by move=> g gin; apply: oute; rewrite inE gin orbT.
+move=> [] _ <-.
+apply: (Ih g1 vg no1)=> //.
+  by rewrite -g1q; apply: left_pt_above.
+by move=> g gin; apply: oute; rewrite inE gin orbT.
+Qed.
+
+Lemma sorted_cat_rcons [T : Type] (rel : rel T) s1 e s2 :
+  sorted rel ((rcons s1 e) ++ s2) =
+  sorted rel (rcons s1 e) && path rel e s2.
+Proof.
+elim: s1 => [ | e1 s1 Ih] //.
+by rewrite /= cat_path last_rcons.
+Qed.
+
+Lemma initial_common_non_gp_invariant bottom top s events:
+  bottom <| top ->
+  (* TODO: rephrase this statement in a statement that easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  all (inside_box bottom top) [seq point e | e <- events] ->
+  sorted (@lexPtEv _) events ->
+  {subset flatten [seq outgoing e | e <- events] <= s} ->
+  {in events, forall ev, out_left_event ev} ->
+  close_edges_from_events events ->
+  events != [::] ->
+  common_non_gp_invariant bottom top s
+    (initial_state bottom top events) (behead events).
+Proof.
+move=> boxwf startok nocs' evin lexev evsub out_evs cle evsn0.
+have ici := initial_common_invariant boxwf startok nocs' evin lexev evsub
+            out_evs cle evsn0.
+constructor; first by exact: ici.
+case evsq :  events evsn0 => [ | ev1 evs] //= _.
+case oca_eq: (opening_cells_aux _ _ _ _) => [nos lno].
+have oute1 : out_left_event ev1.
+  by apply: out_evs; rewrite evsq inE eqxx.
+have oute1' : {in sort (@edge_below _) (outgoing ev1), forall g,
+                  left_pt g == point ev1}.
+  by move=> g; rewrite mem_sort; apply: oute1.
+have := sides_ok ici.
+rewrite /initial_state evsq oca_eq /state_open_seq/= all_cat /= andbT.
+move=> /andP[] _; rewrite /open_cell_side_limit_ok.
+move=> /andP[] _ /andP[] samex /andP[] srt _.
+have ev1in : inside_box bottom top (point ev1).
+  by apply: (allP evin); rewrite evsq map_f // inE eqxx.
+have [vb vt] : valid_edge bottom (point ev1) /\ valid_edge top (point ev1).
+  by rewrite !(inside_box_valid_bottom_top ev1in) // !inE eqxx ?orbT.
+move: (ev1in); rewrite /inside_box=> /andP[] /andP[] /underWC ev1a ev1u _.
+have [] := opening_cells_aux_event vb vt ev1a ev1u oute1' oca_eq.
+case lptsq : (left_pts lno) => [ | p1 [ | p2 ps]] //= _ p2q.
+rewrite p2q path_map.
+by move: lexev; rewrite evsq /=.
+Qed.
+
+Lemma initial_disjoint_general_position_invariant
+    bottom top s events:
+   sorted (fun e1 e2=> p_x (point e1) < p_x (point e2)) events ->
+  bottom <| top ->
+  (* TODO: rephrase this statement in a statement that easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  all (inside_box bottom top) [seq point e | e <- events] ->
+  sorted (@lexPtEv _) events ->
+  {subset flatten [seq outgoing e | e <- events] <= s} ->
+  {in events, forall ev, out_left_event ev} ->
+  close_edges_from_events events ->
+  events != [::] ->
+  disjoint_general_position_invariant bottom top s
+   (initial_state bottom top events)
+   (* (head (dummy_event _) events) *) (behead events).
+Proof.
+move=> ltev boxwf startok nocs' evin lexev evsub out_evs cle evsn0.
+have := initial_common_general_position_invariant ltev boxwf startok
+  nocs' evin lexev evsub out_evs cle evsn0.
+have := initial_intermediate boxwf startok nocs' evin lexev evsub
+   out_evs cle evsn0.
+move: evsn0; case evsq : events => [ | ev evs];[by [] | move=> _].
+lazy zeta; rewrite [head _ _]/= [behead _]/=.
+move=> -[] op0sok [cbtom0 [adj0 [sval0 [rf0 [inbox0
+[cle0 [oute0 [clae0 [vb [vt [oe [nocs [noc0 [pw0 lexev0]]]]]]]]]]]]]].
+have evins : ev \in events by rewrite evsq inE eqxx.
+rewrite /initial_state /state_open_seq/state_closed_seq/= => Cinv.
+case oca_eq:  (opening_cells_aux _ _ _ _) Cinv => [nos lno] Cinv.
+move: (Cinv)=> -[] []; rewrite /state_open_seq/state_closed_seq/=.
+move=> inv1 pxe hlno edges_sub1 cle1 oute1 inbox1 lexevs sok1 gen_pos.
+set op0 := start_open_cell bottom top.
+have op0_cl0_dis : {in [:: op0] & [::], disjoint_open_closed_cells R} by [].
+have inbox0' : all (inside_box bottom top) [seq point e | e <- ev :: evs].
+  by rewrite -evsq.
+have cl0_dis : {in [::] &, disjoint_closed_cells R} by [].
+have rl0 : {in [::], forall c : cell, right_limit c <= p_x (point ev)} by [].
+have := @step_keeps_disjoint_default bottom top ev [::]
+            op0 [::] evs inbox0' (out_evs _ evins) rf0 cbtom0 adj0
+            sval0 pw0 op0sok [::] op0_cl0_dis cl0_dis rl0.
+  rewrite oe oca_eq /= => -[] cl_dis1 op_cl_dis1.
+have pw1 : pairwise (@edge_below _)
+     (bottom:: [seq high c | c <- (nos ++ [:: lno ])]).
+  have rf0' : s_right_form ([::] ++ [:: op0]) by [].
+  have := step_keeps_pw_default inbox0' (out_evs _ evins) rf0' cbtom0 adj0
+    sval0 noc0 pw0.
+  by rewrite oe oca_eq.
+have rl_closed1 : {in [:: close_cell (point ev) op0] & evs,
+  forall c e, right_limit c <= p_x (point e)}.
+  have vho : valid_edge (high op0) (point ev) by [].
+  have vlo : valid_edge (low op0) (point ev) by [].
+  have := right_limit_close_cell vlo vho=> rlcl0 c e.
+  rewrite inE=> /eqP ->.
+  move: lexev; rewrite evsq /= path_sortedE; last by apply: lexPtEv_trans.
+  move=> /andP[] + _=> /allP /[apply].
+  rewrite rlcl0=> /orP[]; first by move/ltW.
+  by move=> /andP[] /eqP -> _; apply: le_refl.
+by constructor.
+Qed.
+
+Lemma simple_step_common_invariant
+  bottom top s fop lsto lop fc cc lcc lc le he cls lstc ev
+  lsthe lstx evs :
+  bottom <| top ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s, forall g, inside_box bottom top (left_pt g) &&
+                   inside_box bottom top (right_pt g)} ->
+  open_cells_decomposition (fop ++ lsto :: lop) (point ev) =
+    (fc, cc, lcc, lc, le, he) ->
+  common_invariant bottom top s
+     (Bscan fop lsto lop cls lstc lsthe lstx)
+     (ev :: evs) ->
+  common_invariant bottom top s
+     (simple_step fc cc lc lcc le he cls lstc ev)
+    evs.
+Proof.
+move=> boxwf nocs' inbox_s oe.
+move=> []; rewrite /state_open_seq/state_closed_seq/=.
+move=> inv lstxq lstheq sub_edges cle out_es /[dup] inbox0.
+move=> /andP[] inbox_e inbox_es.
+move=> lexev oks.
+move: (inv)=> [] clae [] []; first by [].
+move=> sval [] adj [] cbtom rfo.
+have oute : out_left_event ev.
+  by apply: out_es; rewrite inE eqxx.
+have oute' : {in sort (@edge_below _) (outgoing ev),
+                   forall g, left_pt g == point ev}.
+  by move=> g; rewrite mem_sort; apply: oute.
+have nocs : {in bottom :: top :: s &, no_crossing R}.
+  by apply: inter_at_ext_no_crossing.
+have noco : {in all_edges (fop ++ lsto :: lop) (ev :: evs) &,
+                 no_crossing R}.
+ by  move=> g1 gt2 g1in g2in; apply: nocs; apply: sub_edges.
+rewrite /simple_step/generic_trajectories.simple_step.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+have inv' : inv1_seq bottom top evs ((fc ++ nos) ++ lno :: lc).
+  have := invariant1_default_case inbox0 oute rfo cbtom adj sval cle clae
+            noco lexev.
+  by rewrite oe oca_eq.
+have := inv' =>  -[] clae' [] sval' [] adj' []cbtom' rfo'.
+have exi := exists_cell cbtom adj (inside_box_between inbox_e).
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+  decomposition_main_properties oe exi.
+have [{}pal {}puh vl vp nc]:=
+  decomposition_connect_properties rfo sval adj cbtom
+    (inside_box_between inbox_e) oe.
+have /esym left_last : left_limit lno = p_x (point ev).
+  apply: (opening_cells_left oute vl vp).
+  by rewrite /opening_cells oca_eq mem_rcons inE eqxx.
+have heqo : high lno = he.
+  by have := opening_cells_aux_high_last vl vp oute'; rewrite oca_eq.
+have sub_edges' : {subset all_edges ((fc ++ nos) ++ lno :: lc) evs <=
+                     [:: bottom, top & s]}.
+  have := step_keeps_subset_default inbox0 oute rfo cbtom adj sval.
+  rewrite oe oca_eq !catA /= /all_edges => main g.
+  rewrite mem_cat=> /orP[ | gin]; last first.
+    apply: sub_edges; rewrite mem_cat; apply/orP; right.
+    by rewrite events_to_edges_cons mem_cat gin orbT.
+  rewrite (cell_edges_sub_high cbtom' adj') inE=> /orP[/eqP -> | /main].
+    by rewrite inE eqxx.
+  rewrite mem_cat=> /orP[] gin; apply: sub_edges; last first.
+    by rewrite mem_cat events_to_edges_cons orbC mem_cat gin.
+  by rewrite mem_cat mem_cat gin orbT.
+have cle' : close_edges_from_events evs by move: cle=> /andP[].
+have out_es' : {in evs, forall e, out_left_event e}.
+  by move=> e ein; apply: out_es; rewrite inE ein orbT.
+have lexev' : sorted (@lexPtEv _) evs by move: lexev=> /path_sorted.
+have oks' : all open_cell_side_limit_ok ((fc ++ nos) ++ lno :: lc).
+  have := step_keeps_open_side_limit_default inbox0 oute rfo
+    cbtom adj sval oks; rewrite oe oca_eq.
+  by [].
+by constructor.
+Qed.
+
+Lemma simple_step_common_general_position_invariant
+  bottom top s fop lsto lop fc cc lcc lc le he cls lstc ev
+  lsthe lstx evs :
+  bottom <| top ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s, forall g, inside_box bottom top (left_pt g) &&
+                   inside_box bottom top (right_pt g)} ->
+  open_cells_decomposition (fop ++ lsto :: lop) (point ev) =
+    (fc, cc, lcc, lc, le, he) ->
+  common_general_position_invariant bottom top s
+     (Bscan fop lsto lop cls lstc lsthe lstx)
+     (ev :: evs) ->
+  common_general_position_invariant bottom top s
+     (simple_step fc cc lc lcc le he cls lstc ev)
+    evs.
+Proof.
+move=> boxwf nocs' inbox_s oe.
+move=> [] comi /andP[] lstxlt ltev'.
+have comi' := (simple_step_common_invariant boxwf nocs' inbox_s oe comi).
+have ltev1 : all (fun e =>
+            lst_x _ _ (simple_step fc cc lc lcc le he cls lstc ev) <
+               p_x (point e)) evs &&
+         sorted (fun e1 e2 => p_x (point e1) < p_x (point e2)) evs.
+  rewrite (lstx_eq comi').
+  have oute : out_left_event ev by apply: (out_events comi); rewrite inE eqxx.
+  have [_ [sval' [adj [cbtom rfo]]]] := inv1 comi.
+  have /= /andP[inbox_e inbox_es] := inbox_events comi.
+  have sval : seq_valid
+          (state_open_seq (Bscan fop lsto lop cls lstc lsthe lstx))
+          (point ev).
+    by case sval'; first done.
+  have [{}pal {}puh vl vp nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+    (inside_box_between inbox_e) oe.
+  have := opening_cells_left oute vl vp.
+  rewrite /opening_cells/simple_step/generic_trajectories.simple_step.
+  rewrite -/(opening_cells_aux (point ev) (sort (@edge_below _) (outgoing ev))
+               le he).
+  case oca_eq : opening_cells_aux => [nos lno] /=.
+  have lnoin : lno \in rcons nos lno by rewrite mem_rcons inE eqxx.
+  move => /(_ _ lnoin) ->.
+  move: ltev'; rewrite /= path_sortedE //.
+  by move=> x y z; apply: lt_trans.
+by constructor.
+Qed.
+
+Lemma same_x_point_above_low_lsto bottom top s fop lsto lop cls lstc 
+  ev lsthe lstx evs :
+  lstx = p_x (point ev) ->
+  common_non_gp_invariant bottom top s
+    (Bscan fop lsto lop cls lstc lsthe lstx) (ev :: evs) ->
+  point ev >>> low lsto.
+Proof.
+move=> at_lstx comng.
+have comi := ngcomm comng.
+have lstx_ll : lstx = left_limit lsto.
+  rewrite -[lstx]/(lst_x _ _ (Bscan fop lsto lop cls lstc lsthe lstx)).
+  by rewrite (lstx_eq comi).
+have := lst_side_lex comng.
+set W := (X in size X); rewrite -/W.
+have : open_cell_side_limit_ok lsto.
+  by apply: (allP (sides_ok comi)); rewrite mem_cat inE eqxx orbT.
+rewrite /open_cell_side_limit_ok => /andP[] _ /andP[] + /andP[] + /andP[].
+move=> + + _ +.
+rewrite -/W.
+  case wq : W => [ | p1 [ | p2 ps]] //= A /andP[] _ higherps + /andP[] ll _.
+  move: A => /andP[] _ /andP[] p2x allx.
+  have lx : p_x (last p2 ps) == left_limit lsto.
+    case : (ps) allx => [ | p3 pst] // /allP; apply=> /=.
+    by rewrite mem_last.
+  have samex : p_x (point ev) = p_x (last p2 ps).
+    by rewrite -at_lstx lstx_ll (eqP lx).
+  have cmpy : p_y (last p2 ps) <= p_y p2.
+    case psq : ps => [ | p3 pst] //.
+    apply ltW.
+    rewrite (path_sortedE (rev_trans lt_trans)) psq in higherps.
+    move: higherps=> /andP[] /allP /(_ (p_y (last p3 pst))) + _.
+    rewrite map_f; last by rewrite mem_last.
+    by move=> /(_ isT).
+  move=> /(under_edge_lower_y samex) ->.
+  rewrite -ltNge.
+  apply: (le_lt_trans cmpy).
+  move: ll; rewrite /lexPt.
+  by rewrite lt_neqAle samex (eqP p2x) eq_sym lx /=.
+Qed.
+
+Lemma update_open_cell_common_invariant
+  bottom top s fop lsto lop cls lstc ev
+  lsthe lstx evs :
+  bottom <| top ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s, forall g, inside_box bottom top (left_pt g) &&
+                   inside_box bottom top (right_pt g)} ->
+  lstx = p_x (point ev) ->
+  (point ev) <<< lsthe ->
+  common_non_gp_invariant bottom top s
+     (Bscan fop lsto lop cls lstc lsthe lstx)
+     (ev :: evs) ->
+  common_invariant bottom top s
+     (step (Bscan fop lsto lop cls lstc lsthe lstx) ev)
+    evs.
+Proof.
+move=> bxwf nocs' inbox_s at_lstx under_lsthe comng.
+have comi := ngcomm comng.
+rewrite /step/generic_trajectories.step.
+rewrite /same_x at_lstx eqxx /=.
+rewrite -/(point_under_edge _ _) underW /=; last by [].
+rewrite -/(point ev <<< lsthe) under_lsthe.
+have oute : out_left_event ev.
+  by apply: (out_events comi); rewrite inE eqxx.
+have oute' : {in sort (@edge_below _) (outgoing ev),
+                  forall g, left_pt g == point ev}.
+  by move=> g; rewrite mem_sort; apply: oute.
+have [clae [sval' [adj [cbtom rfo]]]] := inv1 comi.
+have sval : seq_valid (state_open_seq (Bscan fop lsto lop cls lstc lsthe lstx))
+              (point ev).
+  by case: sval'.
+have lstx_ll : lstx = left_limit lsto.
+  rewrite -[lstx]/(lst_x _ _ (Bscan fop lsto lop cls lstc lsthe lstx)).
+  by rewrite (lstx_eq comi).
+have pal : (point ev) >>> low lsto.
+  by exact: (same_x_point_above_low_lsto at_lstx comng).
+have abovelow : p_x (point ev) = lstx -> (point ev) >>> low lsto by [].
+have noc : {in all_edges (fop ++ lsto :: lop) (ev :: evs) &,
+           no_crossing R}.
+  apply: inter_at_ext_no_crossing.
+  by apply: (sub_in2 (edges_sub comi) nocs').
+have lstoin : lsto \in (fop ++ lsto :: lop).
+  by rewrite mem_cat inE eqxx orbT.
+have sok : open_cell_side_limit_ok lsto.
+  by apply: (allP (sides_ok comi)); exact: lstoin.
+have xev_llo : p_x (point ev) = left_limit lsto.
+  by rewrite -at_lstx -(lstx_eq comi).
+have puho : point ev <<< high lsto.
+  move: under_lsthe.
+  rewrite -[lsthe]/(lst_high _ _ (Bscan fop lsto lop cls lstc lsthe lstx)).
+  by rewrite -(high_lsto_eq comi).
+have [vl vh] := (andP (allP sval lsto lstoin)).
+have sll : (1 < size (left_pts lsto))%N.
+  by apply: (size_left_lsto sval lstx_ll (sides_ok comi) (esym at_lstx) pal
+             (underW puho)).
+have ogsub : {subset (outgoing ev) <= [:: bottom, top & s]}.
+  move=> g gin; apply: (edges_sub comi); rewrite /all_edges mem_cat.
+  by apply/orP; right; rewrite events_to_edges_cons mem_cat gin.
+constructor.
+- have := step_keeps_invariant1 cls lstc (inbox_events comi) oute rfo cbtom adj
+          sval
+          (closed_events comi) clae (esym (high_lsto_eq comi)) abovelow noc
+          (lex_events comi).
+  rewrite /step /generic_trajectories.step/same_x -at_lstx eqxx /=.
+  rewrite -/(point_under_edge _ _) underW /=; last by [].
+  by rewrite -/(point ev <<< lsthe) under_lsthe.
+- rewrite -/(update_open_cell lsto ev).
+  case uoc_eq : update_open_cell => [nos lno] /=.
+  have [case1 | case2]:= update_open_cellE2 oute vl vh sok xev_llo sll pal puho.
+    apply/esym.
+    have := opening_cells_left oute vl vh.
+    rewrite /opening_cells; move: case1; case: opening_cells_aux=> [nos' lno'].
+    rewrite uoc_eq /= => <- /(_ lno).
+    by apply; rewrite mem_rcons inE eqxx.
+  move: case2; rewrite uoc_eq /= => ->.
+  by rewrite (add_point_left_limit _ sll).
+- rewrite -/(update_open_cell lsto ev).
+  case uoc_eq : update_open_cell => [nos lno] /=.
+  have [case1 | case2]:= update_open_cellE2 oute vl vh sok xev_llo sll pal puho.
+    rewrite uoc_eq /= in case1; rewrite case1.
+    have := opening_cells_aux_high_last vl vh oute'.
+    case: opening_cells_aux => [lno' nos'] /= => ->.
+    by apply: (high_lsto_eq comi).
+  rewrite uoc_eq /= in case2; rewrite case2.
+  rewrite high_set_left_pts.
+  by apply: (high_lsto_eq comi).
+have llin : low lsto \in [:: bottom, top & s].
+  apply: (edges_sub comi); rewrite /all_edges mem_cat /state_open_seq /=.
+  by rewrite cell_edges_cat mem_cat cell_edges_cons inE eqxx !orbT.
+have hlin : high lsto \in [:: bottom, top & s].
+  apply: (edges_sub comi); rewrite /all_edges mem_cat /state_open_seq /=.
+  by rewrite cell_edges_cat mem_cat cell_edges_cons !inE eqxx !orbT.
+- rewrite -/(update_open_cell lsto ev).
+  case uoc_eq : update_open_cell => [nos lno].
+  rewrite /all_edges /state_open_seq /=.
+  apply: subset_catl; last first.
+    move=> g gin; apply: (edges_sub comi); rewrite /all_edges.
+    by rewrite mem_cat orbC events_to_edges_cons mem_cat gin orbT.
+  move=> g; rewrite cell_edges_cat mem_cat cell_edges_cons 2!inE.
+  rewrite cell_edges_cat mem_cat -!orbA=> /orP[gin | ] .
+    apply: (edges_sub comi); rewrite /state_open_seq /= /all_edges mem_cat.
+    by rewrite cell_edges_cat mem_cat gin.
+  move=> /orP[gin | ].
+  have [c cin gq] : exists2 c, c \in nos & g = high c \/ g = low c.
+    move: gin; rewrite mem_cat=> /orP[] /mapP[c cin gq]; exists c=> //.
+      by right.
+    by left.
+  have := update_open_cellE1 oute vl vh sok xev_llo sll pal puho.
+  rewrite uoc_eq /= => /(_ _ cin) [c' c'in Pc].
+  have /andP [lc'in hc'in] : (low c' \in [:: bottom, top & s]) &&
+           (high c' \in [:: bottom, top & s]).
+    have := opening_cells_subset' llin hlin ogsub vl vh oute.
+    rewrite /opening_cells.
+    move: c'in; case : opening_cells_aux => [nos' lno'] /= c'in main.
+    by rewrite !main // mem_cat map_f ?orbT // mem_rcons inE c'in ?orbT.
+  move: Pc gq=> [-> | [l lv ->]].
+    by move=> [] ->.
+  rewrite high_set_left_pts low_set_left_pts.
+  by move=> [] ->.
+- rewrite orbA=> /orP[ | gin]; last first.
+    apply: (edges_sub comi); rewrite /all_edges mem_cat /state_open_seq /=.
+    by rewrite cell_edges_cat mem_cat cell_edges_cons !inE gin !orbT.
+  have := update_open_cellE2 oute vl vh sok xev_llo sll pal puho.
+  rewrite uoc_eq /=.
+  have := opening_cells_subset' llin hlin ogsub vl vh oute.
+  rewrite /opening_cells.
+  move: opening_cells_aux => [nos' lno'] /= main.
+  move=> [] -> /orP gin.
+    apply: main; rewrite mem_cat; move: gin.
+    by move=> [] /eqP ->; rewrite map_f ?orbT //; rewrite mem_rcons inE eqxx.
+  move: gin; rewrite low_set_left_pts high_set_left_pts=> gin.
+  apply: (edges_sub comi); rewrite /all_edges/state_open_seq /=.
+  rewrite mem_cat cell_edges_cat mem_cat cell_edges_cons !inE.
+  by move: gin=> [] ->; rewrite ?orbT.
+- by move: (closed_events comi)=> /andP[].
+- by move=> e1 e1in; apply: (out_events comi); rewrite inE e1in orbT.
+- by move: (inbox_events comi)=> /andP[].
+- move: (lex_events comi)=> /=.
+  rewrite path_sortedE; last by apply:lexPtEv_trans.
+  by move=> /andP[].
+have xev_ll : p_x (point ev) = left_limit lsto.
+  by rewrite -at_lstx lstx_ll.
+case uocq : (generic_trajectories.update_open_cell _ _ _ _
+  _ _ _ _ _ _ _ _ lsto ev) => [new_opens last_new_open].
+rewrite /state_open_seq/=.
+rewrite -catA -cat_rcons 2!all_cat andbCA.
+move: (sides_ok comi).
+rewrite !all_cat /= andbCA => /andP[] lstook ->; rewrite andbT.
+have sz_lptso := size_left_lsto sval lstx_ll
+    (sides_ok comi) (esym at_lstx) pal (underW puho)
+    => /=.
+have lxlftpts : all (fun x => lexPt x (point ev)) (behead (left_pts lsto)).
+  have := lst_side_lex comng  => /=.
+  case lptsq : (left_pts lsto) => [ | p1 [ | p2 ps]] //= /andP[] p2lex _.
+  rewrite p2lex /=.
+  apply/allP => px pxin.
+  apply: (lexPt_trans _ p2lex).
+  move: (sides_ok comi)=> /allP /(_ _ lstoin) /andP[] _.
+  rewrite lptsq /= => /andP[] /andP[] _ /andP[] p2ll /allP psll.
+  move=> /andP[] /andP[] _ + _.
+  rewrite (path_sortedE (rev_trans (lt_trans)))=> /andP[] /allP cmpy _.
+  rewrite /lexPt (eqP p2ll) (esym (eqP (psll _ pxin))) eqxx.
+  by rewrite (cmpy (p_y px)) ?orbT // map_f.
+apply: (update_open_cell_side_limit_ok oute sval
+    (sides_ok comi) lxlftpts uocq xev_ll puho pal).
+Qed.
+
+Lemma update_open_cell_common_non_gp_invariant
+  bottom top s fop lsto lop cls lstc ev
+  lsthe lstx evs :
+  bottom <| top ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s, forall g, inside_box bottom top (left_pt g) &&
+                   inside_box bottom top (right_pt g)} ->
+  lstx = p_x (point ev) ->
+  (point ev) <<< lsthe ->
+  common_non_gp_invariant bottom top s
+     (Bscan fop lsto lop cls lstc lsthe lstx)
+     (ev :: evs) ->
+  common_non_gp_invariant bottom top s
+     (step (Bscan fop lsto lop cls lstc lsthe lstx) ev)
+    evs.
+Proof.
+move=> bxwf nocs' inbox_s at_lstx under_lsthe comng.
+have comi := ngcomm comng.
+constructor.
+  now apply: update_open_cell_common_invariant.
+rewrite /step/generic_trajectories.step.
+rewrite /same_x at_lstx eqxx /=.
+rewrite -/(point_under_edge _ _) underW /=; last by [].
+rewrite -/(point ev <<< lsthe) under_lsthe.
+case uocq : (generic_trajectories.update_open_cell _ _ _ _ _ _
+  _ _ _ _ _ _ lsto ev) => [nos lno] /=.
+have oute : out_left_event ev.
+  by apply: (out_events comi); rewrite inE eqxx.
+have [clae [sval' [adj [cbtom rfo]]]] := inv1 comi.
+have sval : seq_valid (state_open_seq (Bscan fop lsto lop cls lstc lsthe lstx))
+              (point ev).
+  by case: sval'.
+have lstoin : lsto \in (fop ++ lsto :: lop).
+  by rewrite mem_cat inE eqxx orbT.
+have [vl vh] := (andP (allP sval lsto lstoin)).
+have sok : open_cell_side_limit_ok lsto.
+  by apply: (allP (sides_ok comi)); exact: lstoin.
+have xev_llo : p_x (point ev) = left_limit lsto.
+  by rewrite -at_lstx -(lstx_eq comi).
+have puho : point ev <<< high lsto.
+  move: under_lsthe.
+  rewrite -[lsthe]/(lst_high _ _ (Bscan fop lsto lop cls lstc lsthe lstx)).
+  by rewrite -(high_lsto_eq comi).
+have pal : (point ev) >>> low lsto.
+  by exact: (same_x_point_above_low_lsto at_lstx comng).
+have lstx_ll : lstx = left_limit lsto.
+  rewrite -[lstx]/(lst_x _ _ (Bscan fop lsto lop cls lstc lsthe lstx)).
+  by rewrite (lstx_eq comi).
+have sll : (1 < size (left_pts lsto))%N.
+  by apply: (size_left_lsto sval lstx_ll (sides_ok comi) (esym at_lstx) pal
+             (underW puho)).
+have [case1 | case2]:= update_open_cellE2 oute vl vh sok xev_llo sll pal puho.
+   rewrite /update_open_cell uocq /= in case1.
+   rewrite case1.
+   case oca_eq : (opening_cells_aux _ _ _ _) => [nos1 lno1] /=.
+   have  [sz prf]:= last_opening_cells_left_pts_prefix vl vh puho oute oca_eq.
+   rewrite sz /=.
+   set thenth := nth _ _ _.
+   suff -> : thenth = point ev.
+     rewrite (@path_map _ _ (@point) (@lexPt R) ev evs).
+     exact: (lex_events comi).
+  have := take_nth dummy_pt sz; rewrite prf /thenth.
+  case lpts1 : (left_pts lno1) sz => [ | a [ | b tl]] //= _.
+  by move=> [] _ /esym.
+rewrite /update_open_cell uocq /= in case2.
+rewrite case2 /=.
+rewrite (@path_map _ _ (@point) (@lexPt R) ev evs).
+exact: (lex_events comi).
+Qed.
+
+Lemma simple_step_disjoint_general_position_invariant
+  bottom top s fop lsto lop fc cc lcc lc le he cls lstc ev
+  lsthe lstx evs :
+  bottom <| top ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s, forall g, inside_box bottom top (left_pt g) &&
+                   inside_box bottom top (right_pt g)} ->
+  open_cells_decomposition (fop ++ lsto :: lop) (point ev) =
+    (fc, cc, lcc, lc, le, he) ->
+  disjoint_general_position_invariant bottom top s
+     (Bscan fop lsto lop cls lstc lsthe lstx)
+     (ev :: evs) ->
+  disjoint_general_position_invariant bottom top s
+     (simple_step fc cc lc lcc le he cls lstc ev)
+    evs.
+Proof.
+move=> boxwf nocs' inbox_s oe.
+move=> []; rewrite /state_open_seq/state_closed_seq/=.
+move=> oc_dis c_dis Cinv pw rl.
+have := Cinv=> -[] []; rewrite /state_open_seq/state_closed_seq/=.
+move=> inv1 lstxq lstheq sub_edges cle out_es inbox_es lexev oks gen_pos.
+have := inv1 => -[] clae [] []; first by [].
+move=> sval []adj []cbtom rfo.
+rewrite /simple_step/generic_trajectories.simple_step.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+have Cinv' : common_general_position_invariant bottom top s
+         (Bscan (fc ++ nos) lno lc
+            (cls ++ lstc :: closing_cells (point ev) cc)
+            (close_cell (point ev) lcc) he (p_x (point ev))) evs.
+  have := simple_step_common_general_position_invariant boxwf nocs' inbox_s oe.
+  rewrite /simple_step/generic_trajectories.simple_step.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  by rewrite oca_eq=> /(_ _ _ lsthe lstx); apply.
+have cl_at_left' : {in rcons cls lstc,
+        forall c, right_limit c <= p_x (point ev)}.
+  by move=> c cin; apply: rl; rewrite // inE eqxx.
+have oute : out_left_event ev by apply: out_es; rewrite inE eqxx.
+have := step_keeps_disjoint_default inbox_es oute rfo
+         cbtom adj sval pw oks oc_dis c_dis cl_at_left'.
+rewrite oe oca_eq /= !cat_rcons -!cats1 /= => disjointness.
+have op_cl_dis':
+  {in (fc ++ nos) ++ lno :: lc & rcons (cls ++ lstc ::
+           closing_cells (point ev) cc) (close_cell (point ev) lcc),
+         disjoint_open_closed_cells _}.
+   move=> c1 c2; rewrite -!(cats1, catA)=> c1in c2in.
+   by apply: (proj2 (disjointness)).
+have cl_dis : {in  rcons (cls ++ lstc :: closing_cells (point ev) cc)
+                 (close_cell (point ev) lcc) &, disjoint_closed_cells R}.
+  by rewrite -!(cats1, catA); apply: (proj1 disjointness).
+have nocs : {in bottom :: top :: s &, no_crossing R}.
+  by apply: inter_at_ext_no_crossing.
+have noc : {in all_edges (fop ++ lsto :: lop) (ev :: evs) &,
+                 no_crossing R}.
+  by move=> g1 gt2 g1in g2in; apply: nocs; apply: sub_edges.
+have pwo' : pairwise (@edge_below _)
+           (bottom :: [seq high c | c <- (fc ++ nos) ++ lno :: lc]).
+have := step_keeps_pw_default inbox_es oute rfo cbtom adj sval
+      noc pw.
+  by rewrite oe oca_eq -catA.
+have right_limit_closed' :
+  {in  rcons(cls ++
+          lstc :: closing_cells (point ev) cc) (close_cell (point ev) lcc) &
+     evs, forall c e, right_limit c <= p_x (point e)}.
+  have:= step_keeps_right_limit_closed_default inbox_es cbtom adj
+    sval lexev cl_at_left'.
+  by rewrite oe oca_eq /=.
+by constructor.
+Qed.
+
+Definition start :=
+  start R eq_op le +%R (fun x y => x - y) *%R (fun x y => x / y) 1 edge
+  (@unsafe_Bedge _) (@left_pt _) (@right_pt _).
+
+Lemma start_eq_initial (bottom top : edge) (ev : event') :
+  start ev bottom top = initial_state bottom top [:: ev].
+Proof. by []. Qed.
+
+Definition complete_last_open : edge -> edge -> cell -> cell :=
+  complete_last_open
+    R eq_op le +%R (fun x y => x - y) *%R (fun x y => x / y) edge
+    (@left_pt _) (@right_pt _).
+
+Lemma map_eq [A B : Type] (f : A -> B)  l :
+   List.map f l = [seq f x | x <- l].
+Proof. by []. Qed.
+
+Definition main_process bottom top evs :=
+  match evs with
+  | ev :: evs => scan evs (initial_state bottom top (ev :: evs))
+  | [::] => ([:: start_open_cell bottom top], [::])
+  end.
+
+Lemma complete_process_eq bottom top ev evs :
+  complete_process  R eq_op le +%R (fun x y => x - y) *%R (fun x y => x / y) 1 edge
+  (@unsafe_Bedge _) (@left_pt _) (@right_pt _) (ev :: evs) bottom top =
+  match scan evs (initial_state bottom top (ev :: evs)) with
+   (a, b) => [seq complete_last_open bottom top c | c <- a] ++ b
+  end.
+Proof.  by []. Qed.
+
+
+Lemma complete_disjoint_general_position bottom top s closed open evs :
+  sorted (fun e1 e2=> p_x (point e1) < p_x (point e2)) evs ->
+  bottom <| top ->
+  (* TODO: rephrase this statement in one that is easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s, forall g, inside_box bottom top (left_pt g) &&
+                   inside_box bottom top (right_pt g)} ->
+  all (inside_box bottom top) [seq point e | e <- evs] ->
+  sorted (@lexPtEv _) evs ->
+  {subset flatten [seq outgoing e | e <- evs] <= s} ->
+  {in evs, forall ev, out_left_event ev} ->
+  close_edges_from_events evs ->
+  main_process bottom top evs = (open, closed) ->
+  {in closed &, disjoint_closed_cells R} /\
+  {in open & closed, disjoint_open_closed_cells R}.
+Proof.
+move=> ltev boxwf startok nocs' inbox_s evin lexev evsub out_evs cle.
+have nocs : {in bottom :: top :: s &, no_crossing R}.
+  by apply: inter_at_ext_no_crossing.
+rewrite /main_process/scan.
+case evsq : evs => [ | ev future_events].
+  move=> [] <- <-; split; last by [].
+  by move=> c1 c2; rewrite in_nil.
+have evsn0 : evs != [::] by rewrite evsq.
+have := initial_disjoint_general_position_invariant ltev boxwf startok nocs'
+  evin lexev evsub out_evs cle evsn0.
+rewrite /initial_state evsq.
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos1 lno1] /=.
+elim: (future_events) {oca_eq evsq} (Bscan _ _ _ _ _ _ _)=> [ | ev' fut' Ih].
+  move=> state_f /=; case: state_f=> [] f m l cls lstc lsthe lstx.
+  move=> /[swap] -[] <- <-; case; rewrite /state_open_seq /state_closed_seq /=.
+  move=> dis_op_cl dis_cl *; split; move=> c1 c2 c1in c2in.
+    by apply: dis_cl; rewrite // mem_rcons.
+  by apply: dis_op_cl; rewrite // mem_rcons.
+move=> {evs ltev evin lexev evsub out_evs cle evsn0}.
+move=> [fop lsto lop cls lstc lsthe lstx].
+case; set ops' := (state_open_seq _); set (cls' := state_closed_seq _).
+rewrite /=.
+move=> dis_open_closed dis_cl /[dup] Cinv [] [] inv1 lstxq lstheq sub_edges.
+move=> /[dup] cle /andP[cl_e_fut' cle'] out_fut'.
+move=> /[dup]  inbox_all_events' /andP[inbox_e inbox_all_events] lexevs oks.
+move=> /andP[] /andP[] lstxlte lstx_fut' ltfut' edges_pairwise cl_at_left.
+move: (inv1)=> [] clae [] pre_sval [] adj [] cbtom rfo.
+have sval : seq_valid (fop ++ lsto :: lop) (point ev') by case: pre_sval.
+
+rewrite /=/simple_step; case: ifP=> [_ | ]; last first.
+  move=> /negbFE; rewrite /same_x eq_sym=> /eqP abs; suff: False by [].
+  by move : lstxlte; rewrite abs lt_irreflexive.
+rewrite -/(open_cells_decomposition _ _).
+rewrite /generic_trajectories.simple_step.
+case oe : (open_cells_decomposition _ _) => [[[[[fc cc] lcc] lc] le] he].
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+apply: Ih.
+have :=
+  simple_step_disjoint_general_position_invariant boxwf nocs' inbox_s oe.
+  rewrite /simple_step/generic_trajectories.simple_step.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  rewrite oca_eq=> /(_ _ _ lsthe lstx).
+by apply.
+Qed.
+
+Record edge_covered_general_position_invariant (bottom top : edge)
+ (edge_set : seq edge) (processed_set : seq event')
+ (s : scan_state) (events : seq event') :=
+ { edge_covered_ec : {in processed_set, forall e,
+       {in outgoing e, forall g,
+       edge_covered g (state_open_seq s) (state_closed_seq s)}};
+   processed_covered : {in processed_set, forall e,
+       exists2 c, c \in (state_closed_seq s) &
+           point e \in (right_pts c : seq pt) /\ point e >>> low c}  ;
+   common_inv_ec : common_general_position_invariant bottom top edge_set
+     s events;
+   non_in_ec :
+      {in edge_set & events, forall g e, non_inner g (point e)};
+   uniq_ec : {in events, forall e, uniq (outgoing e)};
+   inj_high : {in state_open_seq s &, injective high};
+   bot_left_cells :
+       {in state_open_seq s & events,
+          forall c e, lexPt (bottom_left_corner c) (point e)};
+   }.
+
+Lemma in_cell_edges_has_cell (s : seq cell) (g : edge) :
+   (g \in cell_edges s) = has (fun c => (g == low c) || (g == high c)) s.
+Proof.
+by elim: s => [ | c0 s Ih] //=; rewrite cell_edges_cons !inE !orbA Ih.
+Qed.
+
+Lemma bottom_left_start bottom top p :
+  inside_box bottom top p ->
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  bottom_left_cells_lex [:: start_open_cell bottom top] p.
+Proof.
+move=> inbox_p startok c; rewrite inE => /eqP ->.
+have := leftmost_points_max startok => llq.
+move: (startok); rewrite /open_cell_side_limit_ok=> /andP[] ln0.
+move=> /andP[] samex _.
+rewrite /bottom_left_corner.
+have /eqP := (allP samex (last dummy_pt (left_pts (start_open_cell bottom top)))
+            (last_in_not_nil _ ln0)).
+rewrite llq.
+rewrite /lexPt=> ->.
+move: inbox_p=> /andP[] _ /andP[] /andP[] + _ /andP[] + _.
+case: (lerP (p_x (left_pt bottom)) (p_x (left_pt top))).
+  by move=> _ _ ->.
+by move=> _ ->.
+Qed.
+
+Lemma initial_edge_covering_general_position
+  bottom top s events:
+  sorted (fun e1 e2=> p_x (point e1) < p_x (point e2)) events ->
+  sorted (@lexPtEv _) events ->
+   bottom <| top ->
+  close_edges_from_events events ->
+  (* TODO: rephrase this statement in a statement that easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall g1 g2, inter_at_ext g1 g2} ->
+  {in s & events, forall g e, non_inner g (point e)} ->
+  all (inside_box bottom top) [seq point e | e <- events] ->
+  {subset flatten [seq outgoing e | e <- events] <= s} ->
+  {in events, forall ev, out_left_event ev} ->
+  {in events, forall ev, uniq (outgoing ev)} ->
+  events != [::] ->
+  edge_covered_general_position_invariant bottom top s
+   [:: (head dummy_event events)]
+   (initial_state bottom top events) (behead events).
+Proof.
+move=> gen_pos lexev wf cle startok nocs' n_inner inbox_es sub_es out_es
+  uniq_out_es evsn0.
+rewrite /initial_state.
+have := initial_intermediate wf startok nocs' inbox_es lexev sub_es
+  out_es cle evsn0.
+have := initial_common_general_position_invariant gen_pos wf startok nocs'
+  inbox_es lexev sub_es out_es cle evsn0.
+case evsq : events evsn0 => [ // | e evs] _.
+case oca_eq: (opening_cells_aux _ _ _ _) => [nos lno].
+lazy zeta; rewrite [head _ _]/= [behead _]/=.
+have oute : out_left_event e by apply: out_es; rewrite evsq inE eqxx.
+move=> Cinv [] ok0 []cbtom0 []adj0 []sval0 []rf0 []inbox_es0 []cle1
+         []out_es1 []clae0 []vb []vt []oe0 []nocs []noc0 []pw0 lexevs.
+have inbox_e : inside_box bottom top (point e).
+  by apply/(@allP pt _ _ inbox_es)/map_f; rewrite evsq inE eqxx.
+have /andP[eab ebt] : (point e >>> bottom) && (point e <<< top).
+  by move: inbox_e=> /andP[].
+have cle0 : close_edges_from_events (e :: evs) by rewrite -evsq.
+move: inbox_es; rewrite evsq=> inbox_es.
+move: Cinv; rewrite/initial_state oca_eq/state_open_seq/state_closed_seq/=.
+move=> /[dup] Cinv; rewrite /state_open_seq/state_closed_seq /=.
+move=> -[] []; rewrite /state_open_seq/state_closed_seq /=.
+move=> inv1 px1 lstheq1 sub1 _ _ _ _ oks1 lexpt1.
+have [clae1 [pre_sval [adj1 [cbtom1 rf1]]]] := inv1.
+set op0 := start_open_cell bottom top.
+have inj_high0 : {in [:: start_open_cell bottom top] &, injective high}.
+  by move=> g1 g2; rewrite !inE=> /eqP -> /eqP ->.
+have uniq1 : {in evs, forall e, uniq (outgoing e)}.
+  by move=> ev evin; apply: uniq_out_es; rewrite evsq inE evin orbT.
+have rf0' : s_right_form ([::] ++ [:: op0]) by [].
+have  btm_left_lex0 :
+  bottom_left_cells_lex [:: start_open_cell bottom top] (point e).
+  by apply: bottom_left_start inbox_e startok.
+have inj_high1 : {in nos ++ [:: lno] &, injective high}.
+  have uniq_e : uniq (outgoing e) by apply: uniq_out_es; rewrite evsq inE eqxx.
+  have := step_keeps_injective_high_default inbox_es oute rf0' cbtom0
+    adj0 sval0 ok0 uniq_e inj_high0 btm_left_lex0.
+  by rewrite oe0 oca_eq.
+have n_inner0 : {in [:: start_open_cell bottom top],
+           forall c, non_inner (high c) (point e)}.
+  move=> c; rewrite inE /non_inner=> /eqP -> /onAbove.
+  by move: inbox_e=> /andP[] /andP[] _ ->.
+have n_inner1 : {in s & evs, forall g e, non_inner g (point e)}.
+  by move=> g ev gin evin; apply: n_inner; rewrite // evsq inE evin orbT.
+have cov1 : {in [:: e], forall e',
+    {in outgoing e', forall g, (edge_covered g (nos ++ [:: lno])
+            [:: close_cell (point e) op0])}}.
+  move=> e'; rewrite inE => /eqP -> {e'}.
+  have := step_keeps_edge_covering_default inbox_es oute rf0' cbtom0 adj0 sval0
+           ok0 inj_high0 btm_left_lex0 n_inner0 oe0 oca_eq=> /=.
+  move=> main g gin.
+  by apply: (main [::]); right.
+have btm_left_lex1 : {in nos ++ [:: lno] & evs,
+          forall c e0, lexPt (bottom_left_corner c) (point e0)}.
+  move=> c ev cin evin.
+  have eev : lexPtEv e ev.
+    move: lexev; rewrite evsq /= path_sortedE; last by apply: lexPtEv_trans.
+    by move=> /andP [] /allP + _; apply.
+  have := step_keeps_btom_left_corners_default inbox_es oute rf0' cbtom0
+    adj0 sval0 noc0 btm_left_lex0; rewrite oe0 oca_eq=> /(_ _ eev).
+  by apply.
+rewrite /state_open_seq/state_closed_seq/=.
+have cov_p1 : {in [:: e], forall e',
+  exists2 c, c \in [:: close_cell (point e) op0] &
+  point e' \in (right_pts c : seq pt)/\ point e' >>> low c}.
+  move=> e'; rewrite inE => /eqP -> {e'}.
+  exists (close_cell (point e) op0); first by rewrite mem_head.
+  split.
+    by exact: (@close_cell_in _ op0 (conj vb vt)).
+  by have [-> _ _] := close_cell_preserve_3sides (point e) op0.
+by constructor.
+Qed.
+
+Lemma edge_covered_sub (g : edge) op1 op2 cl1 cl2 :
+  op1 =i op2 -> cl1 =i cl2 ->
+  edge_covered g op1 cl1 -> edge_covered g op2 cl2.
+Proof.
+move=> eqop eqcl [[opc [cls [P1 [P2 [P3 [P4 P5]]]]]] | ].
+  left; exists opc, cls.
+  split;[ |split;[by [] | split;[by [] | split;[ | by []]]]] .
+    by move=> c; rewrite -eqcl; apply: P1.
+  by rewrite -eqop.
+move=> [pcc [P1 [P2 [P3 [P4 [P5 P6]]]]]].
+right; exists pcc; split;[by [] | split;[ | by []]].
+by move=> c; rewrite -eqcl; apply: P2.
+Qed.
+
+Lemma inside_box_non_inner bottom top (p : pt) :
+  inside_box bottom top p -> non_inner bottom p /\ non_inner top p.
+Proof.
+move=> /andP[] /andP[] absbot abstop _; split.
+  move=> /[dup] /andP[] _ vb; move: absbot; rewrite under_onVstrict // negb_or.
+  by move=> /[swap] ->.
+move=> /[dup] /andP[] _ vt; move: abstop; rewrite strict_nonAunder //.
+by move=> /[swap] ->.
+Qed.
+
+Lemma simple_step_edge_covered_general_position
+  bottom top s cov_set fop lsto lop fc cc lcc lc le he cls lstc ev
+  lsthe lstx evs :
+  bottom <| top ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s, forall g, inside_box bottom top (left_pt g) &&
+                   inside_box bottom top (right_pt g)} ->
+  open_cells_decomposition (fop ++ lsto :: lop) (point ev) =
+    (fc, cc, lcc, lc, le, he) ->
+  edge_covered_general_position_invariant bottom top s
+   cov_set (Bscan fop lsto lop cls lstc lsthe lstx)
+   (ev :: evs) ->
+  edge_covered_general_position_invariant bottom top s
+    (rcons cov_set ev) (simple_step fc cc lc lcc le he cls lstc ev)
+    evs.
+Proof.
+move=> boxwf nocs' inbox_s.
+have nocs : {in bottom :: top :: s &, no_crossing R}.
+  by apply: inter_at_ext_no_crossing.
+set st := Bscan _ _ _ _ _ _ _.
+move=> oe.
+move=> [] covered p_covered /[dup] Cinv [] [] /[dup] inv_s [] clae.
+move=> - [] []; first by [].
+rewrite /state_open_seq/state_closed_seq /= => sval [] adj [] cbtom rfo.
+move=> lstxq lstheq sub_edges cle out_es.
+move=> /[dup] inbox0 /andP[] inbox_e inbox_es lexev.
+move=> oks /andP[] lstxlt pathlt n_inner uniq_evs inj_high btm_left_lex.
+have out_e : out_left_event ev by apply: out_es; rewrite inE eqxx.
+have noc : {in all_edges (state_open_seq st) (ev :: evs) &, no_crossing R}.
+  by move=> g1 g2 g1in g2in; apply: nocs; apply: sub_edges.
+(* TODO: this should not be needed, if we had enough theorems about
+  simple_step. *)
+have lstxneq :  p_x (point ev) != lstx.
+  by move: lstxlt; rewrite lt_neqAle eq_sym=> /andP[] /andP[].
+case oca_eq :
+  (opening_cells_aux (point ev) (sort (@edge_below _) (outgoing ev)) le he) =>
+      [nos lno].
+have Cinv' :=
+  simple_step_common_general_position_invariant boxwf nocs' inbox_s oe Cinv.
+have btm_left_lex_e : {in (state_open_seq st), forall c,
+                         lexPt (bottom_left_corner c) (point ev)}.
+  by move=> c cin; apply: btm_left_lex; rewrite // inE eqxx.
+have n_inner2 : {in state_open_seq st,
+         forall c, non_inner (high c) (point ev)}.
+  move=> c cin.
+  have /sub_edges : high c \in all_edges (state_open_seq st) (ev :: evs).
+    by rewrite 2!mem_cat map_f ?orbT.
+  have /inside_box_non_inner [nib nit] : inside_box bottom top (point ev).
+    by move: inbox0 => /andP[].
+  rewrite !inE => /orP[/eqP -> | /orP [/eqP -> | hcin ]] //.
+  by apply: n_inner; rewrite // inE eqxx.
+have cov' : {in rcons cov_set ev,forall e',
+  {in outgoing e', forall g, edge_covered g (state_open_seq
+                              (simple_step fc cc lc lcc le he cls lstc ev))
+                  (state_closed_seq
+                     (simple_step fc cc lc lcc le he cls lstc ev))}}.
+  have main:= step_keeps_edge_covering_default
+    inbox0 out_e rfo cbtom adj sval oks inj_high btm_left_lex_e n_inner2
+         oe oca_eq.
+  have := main (state_closed_seq st) => {}main.
+  move=> e' e'in g gin.
+  have /main : edge_covered g (fop ++ lsto :: lop) (state_closed_seq st) \/
+         g \in outgoing ev.
+    move: e'in; rewrite -cats1 mem_cat=> /orP[/covered|]; last first.
+      by move: gin=> /[swap]; rewrite inE=> /eqP ->; right.
+    by move=> /(_ _ gin); left.
+  rewrite /state_open_seq /state_closed_seq /=.
+  apply: edge_covered_sub.
+    rewrite /simple_step/generic_trajectories.simple_step.
+    rewrite -/(opening_cells_aux _ _ _ _).
+    by rewrite oca_eq /= -catA.
+  rewrite /simple_step/generic_trajectories.simple_step.
+  rewrite -/(opening_cells_aux _ _ _ _).
+  by rewrite oca_eq /= !cat_rcons -!cats1 -!catA.
+have n_inner' : {in s & evs, forall g e, non_inner g (point e)}.
+  by move=> g e gin ein; apply: n_inner; rewrite // inE ein orbT.
+have uniq' : {in evs, forall e, uniq (outgoing e)}.
+  by move=> g gin; apply: uniq_evs; rewrite inE gin orbT.
+have uniq_ev : uniq (outgoing ev) by apply: uniq_evs; rewrite inE eqxx.
+have inj_high' :
+  {in state_open_seq (simple_step fc cc lc lcc le he cls lstc ev) &,
+     injective high}.
+  have := step_keeps_injective_high_default inbox0 out_e rfo cbtom adj sval
+     oks uniq_ev inj_high btm_left_lex_e.
+  rewrite /simple_step/generic_trajectories.simple_step.
+  rewrite -/(open_cells_decomposition _ _).
+  rewrite -/(opening_cells_aux _ _ _ _).
+  by rewrite oe oca_eq /state_open_seq /= -catA.
+have btm_left_lex' :
+  {in state_open_seq (simple_step fc cc lc lcc le he cls lstc ev) & evs,
+     forall c e, lexPt (bottom_left_corner c) (point e)}.
+  have := step_keeps_btom_left_corners_default inbox0 out_e rfo cbtom adj
+     sval noc btm_left_lex_e.
+  rewrite /simple_step/= /= oe oca_eq /= /state_open_seq /=.
+  rewrite catA=> main.
+  move=> c e cin ein; apply: main=> //=.
+    move: lexev; rewrite path_sortedE; last by apply: lexPtEv_trans.
+    by move=> /andP[] /allP /(_ e ein).
+  move: cin; rewrite /generic_trajectories.simple_step.
+  by rewrite -/(opening_cells_aux _ _ _ _) oca_eq.
+have p_cov' : {in rcons cov_set ev, forall e, exists2 c,
+   c \in state_closed_seq (simple_step fc cc lc lcc le he cls lstc ev) &
+   point e \in (right_pts c : seq pt) /\ point e >>> low c}.
+  have exi := exists_cell cbtom adj (inside_box_between inbox_e).
+  have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+    decomposition_main_properties oe exi.
+  have [{}pal {}puh vle vhe nc]:=
+    decomposition_connect_properties rfo sval adj cbtom
+    (inside_box_between inbox_e) oe.
+  move=> e; rewrite mem_rcons inE=> /orP[]; last first.
+    move=> /p_covered [] c cin pin.
+    rewrite /state_closed_seq/simple_step/generic_trajectories.simple_step.
+    rewrite -/(opening_cells_aux _ _ _ _).
+    rewrite oca_eq /=.
+    exists c; last by [].
+    by rewrite -cats1 /= appE -(cat_rcons lstc) !mem_cat cin.
+  move=> /eqP -> {e}.
+  exists (close_cell (point ev) (head lcc cc)).
+    rewrite /state_closed_seq /simple_step/generic_trajectories.simple_step.
+    rewrite -/(opening_cells_aux _ _ _ _).
+    rewrite oca_eq /= -cats1 -catA /=.
+    rewrite -cat_rcons mem_cat; apply/orP; right.
+    by case: (cc) => [ | ? ?]; rewrite /= mem_head.
+  have hdin : head lcc cc \in fop ++ lsto :: lop.
+    rewrite ocd mem_cat; apply/orP; right.
+    by case: (cc)=> [ | ? ?]; rewrite /= mem_head.
+  split.
+    by apply/close_cell_in/andP/(allP sval).
+  have [-> _ _] := close_cell_preserve_3sides (point ev) (head lcc cc).
+  by rewrite -leq.
+by constructor.
+Qed.
+
+Lemma start_edge_covered_general_position bottom top s closed open evs :
+  sorted (fun e1 e2=> p_x (point e1) < p_x (point e2)) evs ->
+  bottom <| top ->
+  (* TODO: rephrase this statement in one that is easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s, forall g, inside_box bottom top (left_pt g) &&
+                   inside_box bottom top (right_pt g)} ->
+  all (inside_box bottom top) [seq point e | e <- evs] ->
+  sorted (@lexPtEv _) evs ->
+  {subset events_to_edges evs <= s} ->
+  {in evs, forall ev, out_left_event ev} ->
+  close_edges_from_events evs ->
+  {in s & evs, forall g e, non_inner g (point e)} ->
+  {in evs, forall e, uniq (outgoing e)} ->
+  main_process bottom top evs = (open, closed) ->
+  {in events_to_edges evs, forall g, edge_covered g open closed} /\
+  {in evs, forall e, exists2 c, c \in closed &
+      point e \in (right_pts c : seq pt) /\ point e >>> low c}.
+Proof.
+move=> ltev boxwf startok nocs' inbox_s evin lexev evsub out_evs cle
+  n_inner uniq_edges.
+(*
+have nocs : {in bottom :: top :: s &, no_crossing R}.
+  by apply: inter_at_ext_no_crossing.
+*)
+rewrite /start.
+case evsq : evs => [ | ev future_events]; first by split; move=> r_eq ?.
+have evsn0 : evs != [::] by rewrite evsq.
+have := initial_edge_covering_general_position ltev lexev boxwf cle
+  startok nocs' n_inner evin evsub out_evs uniq_edges evsn0.
+rewrite /initial_state evsq /=.
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+set istate := Bscan _ _ _ _ _ _ _.
+move=> istateP req.
+suff main : forall events op cl st cov_set,
+  edge_covered_general_position_invariant bottom top s cov_set st events ->
+  scan events st = (op, cl) ->
+  ({in events_to_edges (cov_set ++ events), forall g, edge_covered g op cl} /\
+  {in cov_set ++ events, forall e, exists2 c, c \in cl &
+    point e \in (right_pts c : seq pt) /\ point e >>> low c}).
+  by move: req; apply: (main _ _ _ _ [:: ev]).
+  move=> {req istateP istate oca_eq lno nos evsn0 evsq future_events ev}.
+  move=> {uniq_edges n_inner out_evs evsub lexev evin startok ltev}.
+  move=> {cle closed open evs}.
+  elim=> [ | ev evs Ih] op cl st cov_set.
+  case: st => fop lsto lop cls lstc lsthe lstx /=.
+  move=> []; rewrite /state_open_seq/state_closed_seq /= => + p_main.
+  move=> main _ _ _ _ _ [] <- <-; rewrite cats0; split.
+    move=> g=> /flatten_mapP[e' /main /[apply]].
+    apply: edge_covered_sub; first by [].
+    by move=> c; rewrite mem_rcons.
+  move=> e=> /p_main [c2 c2in pin2]; exists c2=> //.
+  by move: c2in; rewrite mem_rcons.
+move=> inv0; rewrite -cat_rcons.
+apply: Ih.
+case stq : st => [fop lsto lop cls lstc lsthe lstx].
+rewrite /step/generic_trajectories.step.
+have /andP[/andP[+ _] _] := general_pos (common_inv_ec inv0).
+rewrite lt_neqAle eq_sym => /andP[] lstxneq _.
+rewrite stq /= in lstxneq; rewrite lstxneq.
+rewrite -/(open_cells_decomposition _ _).
+case oe : (open_cells_decomposition _ _) => [[[[[fc cc] lcc] lc] le] he].
+move: (inv0); rewrite stq=> inv1.
+by have := simple_step_edge_covered_general_position boxwf nocs'
+    inbox_s oe inv1.
+Qed.
+
+Record safe_side_general_position_invariant (bottom top : edge)
+ (edge_set : seq edge) (processed_set : seq event')
+ (s : scan_state) (events : seq event') :=
+ { disjoint_ss :
+     disjoint_general_position_invariant bottom top edge_set s events;
+   covered_ss :
+     edge_covered_general_position_invariant bottom top edge_set
+       processed_set s events;
+    left_proc : {in processed_set & events, forall e1 e2,
+                     p_x (point e1) < p_x (point e2)};
+    rf_closed : {in state_closed_seq s, forall c, low c <| high c};
+    diff_edges :
+       {in state_open_seq s ++ state_closed_seq s, forall c, low c != high c};
+    sub_closed :
+      {subset cell_edges (state_closed_seq s) <= bottom :: top :: edge_set};
+   (* TODO : move this to the common invariant. *)
+   left_o_lt :
+        {in state_open_seq s & events,
+          forall c e, left_limit c < p_x (point e)};
+   left_o_b :
+        {in state_open_seq s, forall c, left_limit c <
+              min (p_x (right_pt bottom)) (p_x (right_pt top))};
+   closed_lt :
+        {in state_closed_seq s, forall c, left_limit c < right_limit c};
+   closed_ok :
+        all (@closed_cell_side_limit_ok R) (state_closed_seq s);
+   (* TODO : move this to the disjoint invariant. *)
+   cl_at_left_ss :
+     {in state_closed_seq s & events,
+        forall c e, right_limit c < p_x (point e)};
+   safe_side_closed_edges :
+     {in events_to_edges processed_set & state_closed_seq s, forall g c p,
+         in_safe_side_left p c || in_safe_side_right p c -> ~ p === g};
+   safe_side_open_edges :
+     {in events_to_edges processed_set & state_open_seq s, forall g c p,
+         in_safe_side_left p c -> ~p === g};
+   safe_side_closed_points :
+     {in processed_set & state_closed_seq s, forall e c p,
+         in_safe_side_left p c || in_safe_side_right p c ->
+         p != point e :> pt};
+   safe_side_open_points :
+     {in processed_set & state_open_seq s, forall e c p,
+         in_safe_side_left p c ->
+         p != point e :> pt};
+}.
+
+Lemma events_to_edges_rcons evs (e : event') :
+  events_to_edges (rcons evs e) = events_to_edges evs ++ outgoing e.
+Proof. by rewrite /events_to_edges /= map_rcons flatten_rcons. Qed.
+
+Lemma valid_open_limit (c : cell) p  :
+  valid_edge (low c) p -> valid_edge (high c) p -> p_x p <= open_limit c.
+Proof.
+move=> /andP[] _ lp /andP[] _ hp; rewrite /open_limit.
+by have [A | B] := lerP (p_x (right_pt (low c))) (p_x (right_pt (high c))).
+Qed.
+
+Lemma on_edge_inside_box (bottom top g : edge) p :
+  inside_box bottom top (left_pt g) ->
+  inside_box bottom top (right_pt g) ->
+  p === g ->
+  inside_box bottom top p.
+Proof.
+move=> inl inr pon.
+rewrite /inside_box.
+have -> : p >>> bottom.
+  have la : left_pt g >>> bottom by move: inl=>/andP[] /andP[].
+  have ra : right_pt g >>> bottom by move: inr=>/andP[] /andP[].
+  by have := point_on_edge_above_strict pon la ra.
+have -> : p <<< top.
+  have lu : left_pt g <<< top by move: inl=>/andP[] /andP[].
+  have ru : right_pt g <<< top by move: inr=>/andP[] /andP[].
+  by have := point_on_edge_under_strict pon lu ru.
+move: pon => /andP[] _ /andP[] lp pr.
+move: inl => /andP[] _ /andP[] /andP[] bl _ /andP[] tl _.
+move: inr => /andP[] _ /andP[] /andP[] _ rb /andP[] _ rt.
+rewrite (lt_le_trans bl lp) (lt_le_trans tl lp).
+by rewrite (le_lt_trans pr rb) (le_lt_trans pr rt).
+Qed.
+
+Lemma inside_box_lt_min_right (p : pt) bottom top :
+  inside_box bottom top p ->
+  p_x p < min (p_x (right_pt bottom)) (p_x (right_pt top)).
+Proof.
+move=> /andP[] _ /andP[] /andP[] _ + /andP[] _.
+by case : (ltrP (p_x (right_pt bottom)) (p_x (right_pt top))).
+Qed.
+
+Lemma initial_safe_side_general_position bottom top s events:
+  sorted (fun e1 e2=> p_x (point e1) < p_x (point e2)) events ->
+  sorted (@lexPtEv _) events ->
+   bottom <| top ->
+  close_edges_from_events events ->
+  (* TODO: rephrase this statement in a statement that easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall g1 g2, inter_at_ext g1 g2} ->
+  {in s & events, forall g e, non_inner g (point e)} ->
+  all (inside_box bottom top) [seq point e | e <- events] ->
+  {subset flatten [seq outgoing e | e <- events] <= s} ->
+  {in events, forall ev, out_left_event ev} ->
+  {in events, forall ev, uniq (outgoing ev)} ->
+  events != [::] ->
+  safe_side_general_position_invariant bottom top s
+    [::(head dummy_event events)]
+   (initial_state bottom top events) (behead events).
+Proof.
+move=> gen_pos lexev wf cle startok nocs' n_inner inbox_es sub_es out_es
+  uniq_out_es evsn0.
+have := initial_intermediate wf startok nocs' inbox_es lexev sub_es
+  out_es cle evsn0.
+have := initial_disjoint_general_position_invariant gen_pos wf startok
+  nocs' inbox_es lexev sub_es out_es cle evsn0.
+have := initial_edge_covering_general_position gen_pos lexev wf cle
+  startok nocs' n_inner inbox_es sub_es out_es uniq_out_es evsn0.
+case evsq: events evsn0=> [ | ev evs]; [by [] | move=> evsn0].
+rewrite /initial_state.
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+move=> e_inv d_inv.
+move=> []; set op0 := start_open_cell bottom top.
+rewrite [head _ _]/= [behead _]/=.
+move=> ok0 [] btom0 [] adj0 [] sval0 [] rf0 [] inbox_es0 [] cle0 [] oute0.
+move=> [] clae0 [] vb0 [] vt0 [] oe0 [] noc0 [] noc'0 [] pw0 lexevs.
+have u0 : uniq (outgoing ev) by apply: uniq_out_es; rewrite evsq mem_head.
+have oute : out_left_event ev by apply: out_es; rewrite evsq mem_head.
+have inbox_e : inside_box bottom top (point ev).
+  by have := inbox_es; rewrite evsq => /andP[].
+have /andP [pab put] : (point ev >>> bottom) && (point ev <<< top).
+  by move: inbox_e=> /andP[].
+have rf_closed1 : {in [:: close_cell (point ev) op0], forall c,
+      low c <| high c}.
+  rewrite /close_cell (pvertE vb0) (pvertE vt0) /= => c.
+  by rewrite inE=> /eqP -> /=.
+have dif1 : {in (nos ++ [:: lno]) ++
+                 [:: close_cell (point ev) op0], forall c, low c != high c}.
+  move=> c; rewrite mem_cat=> /orP[].
+    rewrite cats1.
+    have := opening_cells_low_diff_high oute u0 vb0 vt0 pab put.
+    by rewrite /opening_cells oca_eq; apply.
+  rewrite inE /close_cell (pvertE vb0) (pvertE vt0) => /eqP -> /=.
+  by apply/negP=> /eqP abs; move: pab; rewrite abs (underW put).
+have subc1 : {subset cell_edges [:: close_cell (point ev) op0] <=
+    bottom :: top :: s}.
+  move=> c; rewrite !mem_cat !inE=> /orP[] /eqP ->.
+    have [-> _ _] := close_cell_preserve_3sides (point ev) op0.
+    by rewrite eqxx.
+  have [_ -> _] := close_cell_preserve_3sides (point ev) op0.
+  by rewrite eqxx orbT.
+have lte : {in evs, forall e, p_x (point ev) < p_x (point e)}.
+  move: gen_pos; rewrite evsq /=.
+  rewrite path_sortedE; last by move=> ? ? ?; apply: lt_trans.
+  by move=> /andP[] /allP.
+have llt: {in nos ++ [:: lno] & evs, forall c e, left_limit c < p_x (point e)}.
+  move=> c e cin ein.
+  have lte' : p_x (point ev) < p_x (point e) by apply: lte.
+  have := opening_cells_left oute vb0 vt0.
+  by rewrite /opening_cells oca_eq -cats1=> /(_ _ cin) => ->.
+have llop0ltev : left_limit op0 < p_x (point ev).
+  rewrite (leftmost_points_max startok).
+  have := inbox_e=> /andP[] _ /andP[] /andP[] + _ /andP[] + _.
+  by case: (lerP (p_x (left_pt bottom)) (p_x (left_pt top))).
+have lltr : {in [:: close_cell (point ev) op0],
+  forall c, left_limit c < right_limit c}.
+  move=> c; rewrite inE=> /eqP ->.
+  rewrite (@right_limit_close_cell _ (point ev) op0 vb0 vt0).
+  by rewrite left_limit_close_cell.
+have clok: all (@closed_cell_side_limit_ok _) [:: close_cell (point ev) op0].
+  rewrite /= andbT.
+  by apply: close_cell_ok; rewrite // contains_pointE underWC // underW.
+have rllt : {in [:: close_cell (point ev) op0] & evs,
+               forall c e, right_limit c < p_x (point e)}.
+  move=> c e; rewrite inE => /eqP -> ein.
+  by rewrite right_limit_close_cell //; apply: lte.
+(* Main points. *)
+have safe_cl : {in events_to_edges [:: ev] & [:: close_cell (point ev) op0],
+         forall g c p, in_safe_side_left p c || in_safe_side_right p c ->
+         ~ p === g}.
+  move=> g c gin.
+  have lgq : left_pt g = point ev.
+    apply/eqP/oute.
+    by move: gin; rewrite /events_to_edges /= cats0.
+  rewrite inE => /eqP -> p /orP[] pin.
+    move=> /andP[] _ /andP[] + _.
+    rewrite leNgt=> /negP; apply.
+    move: pin=> /andP[] /eqP -> _.
+    by rewrite left_limit_close_cell lgq.
+  move=> pong.
+  move: pin=> /andP[] + /andP[] _ /andP[] _ .
+  rewrite right_limit_close_cell // => /eqP samex.
+  move/negP;apply.
+  suff -> : p = point ev by rewrite close_cell_in.
+  apply/eqP; rewrite pt_eqE samex eqxx/=; apply/eqP.
+  apply: (on_edge_same_point pong) => //.
+  by rewrite -lgq left_on_edge.
+have safe_op : {in events_to_edges [:: ev] & nos ++ [:: lno],
+          forall g c p, in_safe_side_left p c -> ~ p === g}.
+  move=> g c gin cin p pin pong.
+  move: cin; rewrite cats1=> cin.
+  have lgq : left_pt g = point ev.
+    apply/eqP/oute.
+    by move: gin; rewrite /events_to_edges /= cats0.
+  have eong : point ev === g by rewrite -lgq left_on_edge.
+  move: pin=> /andP[] + /andP[] _ /andP[] _.
+  have := opening_cells_left oute vb0 vt0.
+  have := opening_cells_in vb0 vt0 oute.
+  rewrite /opening_cells oca_eq=> /(_ _ cin) evin /(_ _ cin) -> /eqP samex.
+  move/negP; apply.
+  suff -> : p = point ev.
+    by apply: (opening_cells_in vb0 vt0 oute); rewrite /opening_cells oca_eq.
+  apply/eqP; rewrite pt_eqE samex eqxx/=; apply/eqP.
+  apply: (on_edge_same_point pong eong samex) => //.
+have cl_no_event : {in [:: ev] & [:: close_cell (point ev) op0],
+  forall e c (p : pt), in_safe_side_left p c || in_safe_side_right p c ->
+       p != point e}.
+  move=> e c; rewrite !inE => /eqP -> /eqP -> p /orP[].
+    move=> /andP[] xlop0 _.
+    apply/eqP=> pev.
+    move: llop0ltev; rewrite -pev (eqP xlop0).
+    by rewrite left_limit_close_cell lt_irreflexive.
+  move=> /andP[] _ /andP[] _ /andP[] _ /negP it; apply/eqP=> pev.
+  case: it; rewrite pev.
+  by apply: close_cell_in.
+have op_no_event : {in [:: ev] & nos ++ [:: lno],
+         forall e c (p : pt), in_safe_side_left p c -> p != point e}.
+  move=> e c; rewrite !inE=> /eqP ->; rewrite cats1=> cin p pin.
+  apply/negP=> /eqP pev.
+  move: pin=> /andP[] _ /andP[] _ /andP[] _ /negP[] .
+  have := opening_cells_in vb0 vt0 oute; rewrite /opening_cells oca_eq pev.
+  by apply.
+have lt_p_ev :
+  {in [:: ev] & evs, forall e1 e2 : event', p_x (point e1) < p_x (point e2)}.
+  by move=> e1 e2; rewrite inE => /eqP ->; apply: lte.
+have ll_o_b :
+  {in nos ++ [:: lno], forall c,
+       left_limit c < min (p_x (right_pt bottom)) (p_x (right_pt top))}.
+  move=> c cin.
+  have := opening_cells_left oute vb0 vt0; rewrite /opening_cells oca_eq.
+  rewrite -cats1 => /(_ _ cin) ->.
+  by apply: inside_box_lt_min_right.
+by constructor.
+Qed.
+
+Lemma start_safe_sides bottom top s closed open evs :
+  sorted (fun e1 e2=> p_x (point e1) < p_x (point e2)) evs ->
+  bottom <| top ->
+  (* TODO: rephrase this statement in one that is easier to understand. *)
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s, forall g, inside_box bottom top (left_pt g) &&
+                   inside_box bottom top (right_pt g)} ->
+  all (inside_box bottom top) [seq point e | e <- evs] ->
+  sorted (@lexPtEv _) evs ->
+  {subset events_to_edges evs <= s} ->
+  {in evs, forall ev, out_left_event ev} ->
+  close_edges_from_events evs ->
+  {in s & evs, forall g e, non_inner g (point e)} ->
+  {in evs, forall e, uniq (outgoing e)} ->
+  main_process bottom top evs = (open, closed) ->
+ {in closed, forall c,
+     low c <| high c /\
+     low c != high c /\
+     left_limit c < right_limit c /\
+     closed_cell_side_limit_ok c /\
+    forall p : pt,
+     in_safe_side_left p c || in_safe_side_right p c ->
+     {in events_to_edges evs, forall g, ~ p === g} /\
+     {in evs, forall ev, p != point ev}} /\
+  {subset (cell_edges closed) <= [:: bottom, top & s]} /\
+  all (@closed_cell_side_limit_ok R) closed /\
+  size open = 1%N /\ low (head_cell open) = bottom /\
+    high (head_cell open) = top /\
+    {in open & closed, disjoint_open_closed_cells R} /\
+    (evs != [::] ->
+      left_limit (head_cell open) < min (p_x (right_pt bottom))
+      (p_x (right_pt top))).
+Proof.
+move=> ltev boxwf startok nocs' inbox_s evin lexev evsub out_evs cle
+  n_inner uniq_edges.
+have nocs : {in bottom :: top :: s &, no_crossing R}.
+  by apply: inter_at_ext_no_crossing.
+rewrite /main_process/scan/=.
+case evsq : evs => [ | ev future_events]; first by  move=> [] <- <-.
+have evsn0 : evs != [::] by rewrite evsq.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+set istate := Bscan _ _ _ _ _ _ _.
+have : safe_side_general_position_invariant bottom top s [:: ev]
+  istate future_events.
+  have := initial_safe_side_general_position ltev lexev boxwf cle startok
+    nocs' n_inner evin evsub out_evs uniq_edges evsn0.
+  by rewrite evsq /= oca_eq.
+move=> invss req.
+suff main: forall events op cl st processed_set,
+  safe_side_general_position_invariant bottom top s processed_set st events ->
+  scan events st = (op, cl) ->
+  {in cl, forall c,
+    low c <| high c /\
+    low c != high c /\
+    left_limit c < right_limit c /\
+    closed_cell_side_limit_ok c /\
+    forall p : pt, in_safe_side_left p c || in_safe_side_right p c ->
+    {in events_to_edges (processed_set ++ events), forall g, ~ p === g} /\
+         {in processed_set ++ events, forall e', p != point e'}} /\
+  {in op, forall (c : cell) (p : pt), in_safe_side_left p c ->
+         {in events_to_edges (processed_set ++ events), forall g, ~ p === g} /\
+         {in processed_set ++ events, forall e', p != point e'}} /\
+  {subset (cell_edges cl) <= [:: bottom, top & s]} /\
+  all (@closed_cell_side_limit_ok _) cl /\
+  size op = 1%N /\
+  low (head_cell op) = bottom /\
+  high (head_cell op) = top /\
+  {in op & cl, disjoint_open_closed_cells R} /\
+  (left_limit (head_cell op) < min (p_x (right_pt bottom))
+      (p_x (right_pt top))).
+  have [A [B [C [D [E [F [G [H I]]]]]]]] := main _ _ _ _ _ invss req.
+  split; last by [].
+  move=> c cin; move: (A c cin) => [] crf [] difc [] lltr [] clok A'.
+  do 4 (split; first by []).
+  by move=> p pside; have := A' _ pside.
+elim=> [ | {evsq oca_eq istate invss}ev {req}future_events Ih] op cl st p_set.
+  case stq : st => [fop lsto lop cls lstc lsthe lstx] [].
+  move=> d_inv e_inv.
+  set c_inv := common_inv_dis d_inv.
+  rewrite /state_open_seq/state_closed_seq/= => old_lt_fut b_e d_e subc
+     lolt lo_lb rllt clok rl A B C D.
+  rewrite /= => -[] <- <-; rewrite !cats0.
+  split.
+    move=> c cin.
+    split; first by apply: b_e; rewrite mem_rcons.
+    split; first by apply: d_e; rewrite mem_cat mem_rcons cin orbT.
+    split; first by apply: rllt; rewrite mem_rcons.
+    split; first by apply: (allP clok); rewrite mem_rcons.
+    move=> p pin; split.
+      by move=> g gin; apply: (A g c gin); rewrite // mem_rcons.
+    by move=> e ein; apply: (C e c ein); rewrite // mem_rcons.
+  split; last first.
+    split; last first.
+      split.
+        rewrite (eq_all_r (_ : lstc :: cls =i rcons cls lstc)) //.
+        by move=> c; rewrite mem_rcons.
+      (* TODO : find a place for this as a lemma. *)
+      have [[] [] + + _ _ _ _ _ _ _ + _] := c_inv; rewrite /state_open_seq/=.
+      rewrite /state_open_seq/= /close_alive_edges => clae.
+      move=> [] _ [] adj [] cbtom rfo _.
+      have htop : {in fop ++ lsto :: lop, forall c, high c = top}.
+        move=> c cin.
+        have := allP clae _ cin; rewrite /end_edge_ext ?orbF => /andP[] lP.
+        rewrite !inE => /orP[] /eqP hcq; rewrite hcq //.
+        have := d_e c; rewrite mem_cat cin hcq=> /(_ isT).
+        move: lP; rewrite !inE => /orP[] /eqP lcq; rewrite lcq ?eqxx //.
+        move: evin; rewrite evsq /= => /andP[] + _.
+        move=> /[dup]/inside_box_valid_bottom_top vbt.
+        have vb : valid_edge bottom (point ev) by apply: vbt; rewrite inE eqxx.
+        have vt : valid_edge top (point ev).
+          by apply: vbt; rewrite !inE eqxx orbT.
+        move=> /andP[] /andP[] pab put _ tnb.
+        have abs : top <| bottom by rewrite -lcq -hcq; apply: (allP rfo).
+        have := order_edges_strict_viz_point' vt vb abs put.
+        by move: pab; rewrite under_onVstrict // orbC => /[swap] ->.
+      have := inj_high e_inv; rewrite /state_open_seq/= => ijh.
+      have f0 : fop = [::].
+        elim/last_ind: (fop) adj ijh htop => [ // | fs f1 _] + ijh htop.
+        rewrite -cats1 -catA /= => /adjacent_catW[] _ /= /andP[] /eqP f1l _.
+        move: (d_e lsto); rewrite !mem_cat inE eqxx ?orbT => /(_ isT).
+        rewrite -f1l (htop f1); last by rewrite !(mem_rcons, mem_cat, inE) eqxx.
+        by rewrite (htop lsto) ?eqxx // mem_cat inE eqxx ?orbT.
+      have l0 : lop = [::].
+        case lopq: (lop) adj ijh htop => [ // | l1 ls] + ijh htop.
+        move=> /adjacent_catW[] _ /= /andP[] /eqP hl _.
+        move: (d_e l1); rewrite lopq !(mem_cat, inE) eqxx ?orbT => /(_ isT).
+        rewrite -hl (htop l1); last by rewrite !(mem_cat, inE) eqxx !orbT.
+        by rewrite (htop lsto) ?eqxx // mem_cat inE eqxx ?orbT.
+      rewrite f0 l0 /=.
+      move: cbtom; rewrite f0 l0 /= /cells_bottom_top /cells_low_e_top /=.
+      move=> /andP[] /eqP lq /eqP hq.
+      do 3 (split; first by []).
+      split.
+        move=> c1 c2 c1in c2in; apply: (op_cl_dis d_inv);
+        by rewrite /state_open_seq/state_closed_seq  f0 l0 ?mem_rcons.
+      by apply: lo_lb; rewrite mem_cat inE eqxx orbT.
+(* End of lemma *)
+    move=> g; rewrite -[lstc :: cls]/([:: lstc] ++ cls) cell_edges_catC cats1.
+    by apply: subc.
+  move=> c cin p pin.
+  split.
+    by move=> g gin; apply: (B g c gin).
+  by move=> g gin; apply: (D g c gin).
+rewrite /scan/=.
+move=> [] d_inv e_inv old_lt_fut rf_cl d_e subc lolt lo_lb rllt clok rl A B C D.
+set c_inv := common_inv_dis d_inv.
+rewrite /step/generic_trajectories.step/=.
+case stq : st => [fop lsto lop cls lstc lsthe lstx].
+have /andP[/andP[+ _] _] := general_pos c_inv.
+rewrite lt_neqAle=> /andP[] + _.
+rewrite stq eq_sym /= => ->.
+rewrite -/(open_cells_decomposition _ _).
+case oe : (open_cells_decomposition _ _) => [[[[[fc cc] lcc] lc] le] he].
+rewrite /simple_step/generic_trajectories.simple_step/=.
+rewrite -/(opening_cells_aux _ _ _ _).
+case oca_eq : (opening_cells_aux _ _ _ _) => [{}nos {}lno].
+rewrite -(cat_rcons ev).
+apply: Ih.
+have [clae [pre_sval [adj [cbtom rfo]]]] := inv1 (gcomm c_inv).
+move: pre_sval=> [| sval]; first by[].
+have inbox_es := inbox_events (gcomm c_inv).
+have inbox_e : inside_box bottom top (point ev) by move: inbox_es=>/andP[].
+move: (oe); rewrite (_ : fop ++ lsto :: lop = state_open_seq st); last first.
+  by rewrite stq.
+move=> oe'.
+have exi' := exists_cell cbtom adj (inside_box_between inbox_e).
+move: (exi'); rewrite stq => exi.
+have [ocd [lcc_ctn [allct [allnct [flcnct [heq [leq [lein hein]]]]]]]] :=
+  decomposition_main_properties oe' exi'.
+have [{}pal {}puh vl vp nc]:=
+  decomposition_connect_properties rfo sval adj cbtom
+    (inside_box_between inbox_e) oe'.
+have oute : out_left_event ev.
+  by apply: (out_events (gcomm c_inv)); rewrite inE eqxx.
+have oute' :
+  {in (sort (@edge_below _) (outgoing ev)), forall g, left_pt g == point ev}.
+  by move=> g; rewrite mem_sort; apply: oute.
+set rstate := Bscan _ _ _ _ _ _ _.
+have d_inv':
+  disjoint_general_position_invariant bottom top s rstate future_events.
+  move: (d_inv); rewrite stq=> d_inv'.
+  have := simple_step_disjoint_general_position_invariant boxwf nocs'
+      inbox_s oe d_inv'.
+  rewrite /simple_step/generic_trajectories.simple_step/=.
+  by rewrite -/(opening_cells_aux _ _ _ _) oca_eq.
+have e_inv' :edge_covered_general_position_invariant bottom top s
+    (rcons p_set ev) rstate future_events.
+  move: e_inv; rewrite stq=> e_inv.
+  have := simple_step_edge_covered_general_position boxwf nocs'
+      inbox_s oe e_inv.
+  rewrite /simple_step/generic_trajectories.simple_step/=.
+  by rewrite -/(opening_cells_aux _ _ _ _) oca_eq.
+(* Proving that low and high edges of every cell are distinct. *)
+have low_diff_high' :
+  {in state_open_seq rstate ++
+      state_closed_seq rstate, forall c : cell, low c != high c}.
+  move=> c; rewrite mem_cat=> /orP[].
+    rewrite /state_open_seq /= -catA -cat_rcons !mem_cat orbCA.
+    move=> /orP[ | cold]; last first.
+      by apply: d_e; rewrite ocd -cat_rcons !mem_cat orbCA cold orbT.
+    have uo : uniq (outgoing ev) by apply: (uniq_ec e_inv) (mem_head _ _).
+    have := opening_cells_low_diff_high oute uo vl vp pal puh.
+    by rewrite /opening_cells oca_eq; apply.
+  rewrite /state_closed_seq /= -cats1 -!catA /= -cat_rcons.
+  rewrite mem_cat => /orP[cold | ].
+    by apply: d_e; rewrite mem_cat stq /state_closed_seq/= cold orbT.
+  rewrite cats1 -map_rcons=> /mapP[c' c'in ->].
+  have [-> -> _] := close_cell_preserve_3sides (point ev) c'.
+  by apply: d_e; rewrite mem_cat ocd -cat_rcons !mem_cat c'in !orbT.
+(* Provint that closed cells used edges only from the initial set. *)
+have subc' :
+  {subset cell_edges (state_closed_seq rstate) <= [:: bottom, top & s]}.
+  move=> g; rewrite /state_closed_seq/= -cats1 -catA /= -cat_rcons.
+  rewrite cell_edges_cat mem_cat=> /orP[gold | ].
+    by apply: subc; rewrite stq.
+  have subo := edges_sub (gcomm c_inv).
+  rewrite cats1 -map_rcons mem_cat=> /orP[] /mapP[c'] /mapP[c2 c2in ->] ->.
+    have [-> _ _] := close_cell_preserve_3sides (point ev) c2.
+    apply: subo; rewrite !mem_cat; apply/orP; left; apply/orP; left.
+    by rewrite map_f // ocd -cat_rcons !mem_cat c2in orbT.
+  have [_ -> _] := close_cell_preserve_3sides (point ev) c2.
+  apply: subo; rewrite !mem_cat; apply/orP; left; apply/orP; right.
+  by rewrite map_f // ocd -cat_rcons !mem_cat c2in orbT.
+(* Proving that open cells have a left side that is smaller than any
+   event first coordinate. *)
+have loplte : {in state_open_seq rstate & future_events,
+    forall (c : cell) (e : event'), left_limit c < p_x (point e)}.
+  move=> c e; rewrite /state_open_seq/= -catA -cat_rcons => cin ein.
+  move: cin; rewrite !mem_cat orbCA => /orP[ | cold ]; last first.
+    apply: lolt; first by rewrite ocd -cat_rcons !mem_cat orbCA cold orbT.
+    by rewrite inE ein orbT.
+  have := opening_cells_left oute vl vp; rewrite /opening_cells oca_eq=> main.
+  move=> /main=> ->.
+  move: (proj2 (andP (general_pos c_inv))).
+  rewrite /= path_sortedE; last by move=> x y z; apply: lt_trans.
+  by move=> /andP[] /allP /(_ _ ein).
+(* Proving that cells have distinct left and right sides. *)
+have lltr :
+ {in state_closed_seq rstate, forall c : cell, left_limit c < right_limit c}.
+  rewrite /state_closed_seq/= -cats1 -catA /= -cat_rcons.
+  move=> c; rewrite mem_cat=> /orP[cold | ].
+    by apply: rllt; rewrite stq.
+  rewrite cats1 -map_rcons=> /mapP [c' c'in ->].
+  have [vlc' vhc'] : valid_edge (low c') (point ev) /\
+                         valid_edge (high c')(point ev).
+     apply/andP; have := allP sval; rewrite ocd -cat_rcons=> /(_ c'); apply.
+     by rewrite !mem_cat c'in orbT.
+  have := right_limit_close_cell vlc' vhc'=> ->.
+  rewrite left_limit_close_cell lolt //; last by rewrite inE eqxx.
+  by rewrite ocd -cat_rcons !mem_cat c'in orbT.
+(* proving a closed_cell ok invariant. *)
+have clok' : all (@closed_cell_side_limit_ok _) (state_closed_seq rstate).
+  apply/allP; rewrite /state_closed_seq/= -cats1 -catA /= -cat_rcons.
+    move=> c; rewrite mem_cat=> /orP[cin | cin].
+    by apply: (allP clok); rewrite stq.
+  move: cin; rewrite /closing_cells cats1 -map_rcons=> /mapP[c' c'in ->].
+  have ccont : contains_point (point ev) c'.
+    by move: c'in; rewrite mem_rcons inE => /orP[/eqP -> | /allct].
+  have c'in' : c' \in state_open_seq st.
+    by rewrite ocd -cat_rcons !mem_cat c'in orbT.
+  have /(allP sval) /= /andP[vlc' vhc'] := c'in'.
+  have c'ok : open_cell_side_limit_ok c'.
+    by apply: (allP (sides_ok (gcomm c_inv))).
+  by apply close_cell_ok.
+(* proving a right_limit stronger invariant. *)
+have rllte :   {in state_closed_seq rstate & future_events,
+    forall (c : cell) (e : event'), right_limit c < p_x (point e)}.
+  rewrite /state_closed_seq/=.
+  move=> c e cin ein.
+  move: cin; rewrite -cats1 -catA /= -cat_rcons mem_cat=> /orP[cold | cnew].
+    by apply: rl; rewrite ?stq // inE ein orbT.
+  have in_es := inbox_events (gcomm c_inv).
+  have := closing_cells_to_the_left in_es rfo cbtom adj sval.
+  rewrite stq=> /(_ _ _ _ _ _ _ oe)=> -[] main1 main2.
+  have eve : p_x (point ev) < p_x (point e).
+    have:= general_pos c_inv=> /andP[] _ /=.
+    rewrite path_sortedE; last by move=> x y z; apply: lt_trans.
+    by move=> /andP[] /allP /(_ e ein).
+  apply: le_lt_trans eve.
+  move: cnew; rewrite mem_cat=> /orP[cin | ]; last first.
+    by rewrite inE=> /eqP ->.
+  by apply: (main1 _ cin).
+
+have safe_side_bound : {in rcons cls lstc, forall c p,
+       in_safe_side_left p c || in_safe_side_right p c ->
+       p_x p <= right_limit c}.
+  move=> c p cin /orP[] /andP[] /eqP -> _; last by rewrite le_refl.
+  by apply/ltW/rllt; rewrite /state_closed_seq stq.
+have not_safe_event : {in rcons (closing_cells (point ev) cc)
+                                 (close_cell (point ev) lcc), forall c,
+   ~~ (in_safe_side_left  (point ev) c || in_safe_side_right (point ev) c)}.
+  move=> c cin; apply/negP.
+  move: cin; rewrite -map_rcons=> /mapP[c' c'in cq].
+  have c'in' : c' \in state_open_seq st.
+    by rewrite ocd -cat_rcons !mem_cat c'in orbT.
+  move=> /orP[ /andP[] + _ | /andP[] _ /andP[] _ /andP[] _ ].
+    rewrite cq left_limit_close_cell=> /eqP abs.
+    have := lolt c' _ c'in' (mem_head _ _).
+    by rewrite  abs lt_irreflexive.
+  by rewrite cq close_cell_in //; apply/andP/(allP sval).
+have in_safe_side_left_close_cell :
+  {in rcons cc lcc, forall c p, in_safe_side_left p (close_cell (point ev) c) =
+        in_safe_side_left p c}.
+  move=> c cin p; rewrite /in_safe_side_left.
+  have [-> -> ->] := close_cell_preserve_3sides (point ev) c.
+  by rewrite left_limit_close_cell.
+(* Now comes the real important property. *)
+have cl_safe_edge :
+  {in events_to_edges (rcons p_set ev) & state_closed_seq rstate,
+    forall (g : edge) (c : cell) (p : pt),
+    in_safe_side_left p c || in_safe_side_right p c -> ~ p === g}.
+  rewrite events_to_edges_rcons /state_closed_seq/=.
+  move=> g c gin cin p pin.
+  move: cin; rewrite -cats1 -catA /= -cat_rcons mem_cat=> /orP[cold | cnew].
+    move: gin; rewrite mem_cat=> /orP[gold | gnew].
+      (* the edge and the cell are old *)
+      by apply: (A g c); rewrite // stq /state_closed_seq/=.
+  (* the edge is new, the cell is old, I need to prove the events would
+     need to be vertically aligned here. *)
+    have cin' : c \in state_closed_seq st by rewrite stq.
+    have abs := rl _ _ cin' (mem_head _ _).
+    move=> /andP[] _ /andP[] + _.
+    have := out_events (gcomm c_inv) (mem_head _ _) gnew=> /eqP ->.
+  (* TODO : have the same condition, but for the right side of closed cells. *)
+    suff prl : p_x p <= right_limit c.
+      rewrite leNgt=> /negP; apply.
+      by apply: le_lt_trans abs.
+    have cold' : c \in state_closed_seq st by rewrite stq.
+    move: pin => /orP[]; last first.
+      by rewrite /in_safe_side_right => /andP[] /eqP -> _.
+    rewrite /in_safe_side_left=> /andP[] /eqP -> _.
+    by apply/ltW/rllt.
+  (* now the cells are newly closed. *)
+  move: cnew pin; rewrite cats1 /closing_cells -map_rcons.
+  move=> /mapP[c' c'in ->].
+  have c'in' : c' \in state_open_seq st.
+    by rewrite ocd -cat_rcons !mem_cat c'in orbT.
+  move=> /orP[pin | pin].
+    have pin': in_safe_side_left p c'.
+      by move: pin; rewrite in_safe_side_left_close_cell.
+    move: pin=> /andP[]; rewrite left_limit_close_cell => pl _.
+    move: gin; rewrite mem_cat=> /orP[gin | ].
+      by apply: B pin'.
+    move=> /oute /eqP lgq /andP[] _ /andP[]; rewrite lgq leNgt=> /negP[].
+    by rewrite (eqP pl); apply: lolt; rewrite // inE eqxx.
+  have vc' : valid_cell c' (point ev) by apply/andP/(allP sval).
+  have /eqP samex : p_x p == p_x (point ev).
+    by move: pin=> /andP[] + _; rewrite close_cell_right_limit.
+  move: gin; rewrite mem_cat=> /orP[gin | /oute/eqP lgq ]; last first.
+    have peg : point ev === g by rewrite -lgq left_on_edge.
+    move=> pong.
+    have /eqP samey := on_edge_same_point pong peg samex.
+    have pev : p = point ev by apply/eqP; rewrite pt_eqE samex samey eqxx.
+    have := not_safe_event (close_cell (point ev) c').
+    rewrite -[e in in_safe_side_right e _]pev pin orbT.
+    by rewrite /closing_cells -map_rcons map_f // => /(_ isT).
+  move: gin=> /flatten_mapP[e' e'in gin].
+  have := edge_covered_ec e_inv e'in gin=> -[]; last first.
+    move=> [[ | pcc0 pcc] []]; first by [].
+    move=> _ /= [pccsub [pcchigh [_ [_ rlpcc]]]] /andP[] _ /andP[] _.
+    rewrite leNgt=> /negP; apply.
+    rewrite samex -rlpcc; apply:rl; last by rewrite inE eqxx.
+    by apply/pccsub; rewrite /last_cell /= mem_last.
+  move=> [] opc [] pcc [] _ [] opch [] _ [] opco _ abs.
+  have [vlc'p vhc'p] : valid_edge (low c') p /\ valid_edge (high c') p.
+    by move: vc'; rewrite /valid_cell !(same_x_valid _ samex).
+  have pinc' : contains_point' p c'.
+    rewrite /contains_point'.
+    have [<- <- _] := close_cell_preserve_3sides (point ev) c'.
+    by have /andP[_ /andP[] /underW -> /andP[] ->] := pin.
+  have {}opch : high opc = g by apply: opch; rewrite mem_rcons inE eqxx.
+  have [vplc vphc] : valid_edge (low opc) p /\ valid_edge (high opc) p.
+    by rewrite !(same_x_valid _ samex); apply/andP/(allP sval).
+  have rfc : low opc <| high opc by apply: (allP rfo).
+  have cnt : contains_point p opc.
+    rewrite contains_pointE; apply/andP; rewrite under_onVstrict; last first.
+      by have := (allP sval _ opco) => /andP[].
+    rewrite opch abs; split; last by [].
+    apply/negP=> pun.
+    have := order_edges_strict_viz_point' vplc vphc rfc pun.
+    by apply/negP/onAbove; rewrite opch.
+  have pw : pairwise (@edge_below _) [seq high c | c <- state_open_seq st].
+    by move: (pairwise_open d_inv)=> /= /andP[].
+  have [puhc' palc'] : p <<< high c' /\ p >>> low c'.
+    apply/andP;  move: pin=> /andP[] _ /andP[] + /andP[] + _.
+    by have [-> -> _] := close_cell_preserve_3sides (point ev) c' => ->.
+  have : p >>= low opc by move: cnt=> /andP[].
+  rewrite strict_nonAunder // negb_and negbK=> /orP[ | stricter]; last first.
+    have := disoc adj pw (sides_ok (gcomm c_inv)).
+    move=> /(_ opc c' opco c'in') [ab' | ].
+      by move: puhc'; rewrite strict_nonAunder // -ab' opch abs.
+    move=> /(_ p) + ; move=>/negP.
+    rewrite inside_open'E stricter valid_open_limit //.
+    move: cnt; rewrite contains_pointE=> /andP[] _ ->.
+    rewrite samex lolt //=; last by rewrite inE eqxx.
+    rewrite inside_open'E (underW puhc') palc' valid_open_limit //.
+    by rewrite samex lolt // inE eqxx.
+  move=> ponl.
+  have vbp : valid_edge bottom p.
+    by rewrite (same_x_valid _ samex) (inside_box_valid_bottom inbox_e).
+  have vtp : valid_edge top p.
+    rewrite (same_x_valid _ samex) /valid_edge/generic_trajectories.valid_edge.
+    by move: inbox_e=> /andP[] _ /andP[] _ /andP[] /ltW -> /ltW ->.
+  have bottom_b_c' : bottom <| low c'.
+    have [-> | ] := eqVneq bottom (low c'); first by apply: edge_below_refl.
+    have  [s1 [s2]] := mem_seq_split c'in'.
+    elim/last_ind: s1 => [ | s1 op' _] /= => odec.
+      by move: cbtom => /andP[]; rewrite odec /= => /eqP ->; rewrite eqxx.
+    have := adj.
+    rewrite odec cat_rcons=> /adjacent_catW /= [] _ /andP[] /eqP <- _ _.
+    have := pairwise_open d_inv=> /= /andP[] /allP /(_ (high op')) + _.
+    apply; apply/mapP; exists op'=> //.
+    by rewrite // odec !mem_cat mem_rcons inE eqxx.
+  have pab : p >>> bottom.
+    apply/negP=> pub.
+    have:= order_edges_viz_point' vbp vlc'p bottom_b_c' pub.
+    by move: palc'=> /[swap] => ->.
+  have ldifh : low opc != high opc by apply: d_e; rewrite mem_cat opco.
+  have low_opc_s : low opc \in [:: bottom, top & s].
+    by apply: (edges_sub (gcomm c_inv)); rewrite !mem_cat map_f.
+  have high_opc_s : high opc \in [:: bottom, top & s].
+    by apply: (edges_sub (gcomm c_inv)); rewrite !mem_cat map_f ?orbT.
+  have := nocs' (low opc) (high opc) low_opc_s high_opc_s.
+  move=> [Q | ]; first by rewrite Q eqxx in ldifh.
+  have ponh : p === high opc by rewrite opch.
+  have opcok : open_cell_side_limit_ok opc.
+    by apply: (allP (sides_ok (gcomm c_inv))).
+  move=> /(_ _ ponl ponh); rewrite !inE=> /orP[/eqP pleft | /eqP].
+    have : left_limit opc < p_x p.
+      by rewrite samex; apply: lolt; rewrite // inE eqxx.
+    have := left_limit_max opcok.
+    have [_ | ] := lerP (p_x (left_pt (high opc)))(p_x (left_pt (low opc))).
+      by move=> /le_lt_trans /[apply]; rewrite pleft lt_irreflexive.
+    move=> /lt_le_trans /[apply]=> /lt_trans /[apply].
+    by rewrite pleft lt_irreflexive.
+(* Here p is vertically aligned with p_x, but it must be an event,
+   because it is the end of an edge. *)
+  move=> prl.
+  have put : p <<< top.
+    apply: (order_edges_strict_viz_point' vhc'p vtp _ puhc').
+    move: cbtom=> /andP[] _.
+    have := pw.
+    have [s1 [s2 s1q]] := mem_seq_split c'in'.
+    rewrite s1q last_cat /= map_cat pairwise_cat /=.
+    move=> /andP[] _ /andP[] _ /andP[] allabovec' _ /eqP highlast.
+    case s2q : s2 => [ | c2 s3].
+      by rewrite -highlast s2q edge_below_refl.
+    have /(allP allabovec') : (high (last c' s2)) \in [seq high c | c <- s2].
+      by rewrite map_f // s2q /= mem_last.
+    by rewrite highlast.
+  have := (allP clae _ opco)=> /andP[] + _ => /orP[].
+    rewrite !inE => /orP[] /eqP=> ab'.
+      by move: pab; rewrite under_onVstrict // -ab' ponl.
+    by move: put; rewrite strict_nonAunder // -ab' ponl.
+  move=> /hasP[e2 + /eqP pe2]; rewrite inE=> /orP[/eqP e2ev | e2in].
+  (* if e' cannot be ev, because p cannot be ev because of pin *)
+    have := pin=> /andP[].
+    by rewrite prl pe2 e2ev close_cell_in // ?andbF.
+(* if e' is in future_events, then e' and p cannot have the same p_x,
+  because e' and ev don't, but p and e' are at the same point *)
+    have /andP[_ /=]:= general_pos c_inv.
+  rewrite path_sortedE; last by move=> ? ? ?; apply: lt_trans.
+  move=> /andP[] /allP /(_ e2 e2in).
+  by rewrite -pe2 -prl samex ltxx.
+have op_safe_edge :
+  {in events_to_edges (rcons p_set ev) & state_open_seq rstate,
+    forall g c p, in_safe_side_left p c -> ~ p === g}.
+(* We should re-use the proof that was just done. *)
+  move=> g c gin; rewrite /rstate/state_open_seq/=.
+  rewrite -catA -cat_rcons !mem_cat orbCA=> /orP[cnew | cold]; last first.
+    have cin : c \in state_open_seq st.
+      by rewrite ocd -cat_rcons !mem_cat orbCA cold orbT.
+    move: gin; rewrite events_to_edges_rcons mem_cat=> /orP[gold | gnew].
+      by apply: (B _ _ gold cin).
+    move=> p pin /andP[] _ /andP[] pong _.
+    have := lolt _ _ cin (mem_head _ _).
+    move: (pin)=> /andP[] /eqP <- _.
+    rewrite ltNge=> /negP; apply.
+    by move: pong; rewrite (eqP (oute _ gnew)).
+  move=> p pin.
+  have : has (in_safe_side_left p)
+           (opening_cells (point ev) (outgoing ev) le he).
+    by apply/hasP; exists c; rewrite // /opening_cells oca_eq.
+  have := sides_equiv inbox_es oute rfo cbtom adj sval; rewrite stq /=.
+  move=> /(_ _ _ _ _ _ _ oe p) /eqP <- => /hasP[] c' c'in pin'.
+  have := cl_safe_edge _ c' gin; apply.
+    by rewrite /rstate /state_closed_seq/= rcons_cat /= mem_cat inE c'in ?orbT.
+  by rewrite pin' orbT.
+have cl_safe_event :
+  {in rcons p_set ev & state_closed_seq rstate, forall e c (p : pt),
+     in_safe_side_left p c || in_safe_side_right p c -> p != point e}.
+  move=> e c; rewrite mem_rcons inE=> /orP[/eqP -> | ein].
+    move=> cin p pin; apply/negP=> /eqP pev.
+    move: cin.
+    rewrite /rstate/state_closed_seq/= -cats1 -catA /= -cat_rcons mem_cat.
+    move=> /orP[]; last by rewrite cats1=> /not_safe_event; rewrite -pev pin.
+    move=> cin; have cin' : c \in state_closed_seq st by rewrite stq.
+    move: (cin)=> /safe_side_bound/(_ _ pin); rewrite pev leNgt=> /negP; apply.
+    by apply: (rl _ _ cin' (mem_head _ _)).
+  rewrite /rstate/state_closed_seq/= -cats1 -catA /= -cat_rcons mem_cat.
+  move=> /orP[cin | ].
+    have cin' : c \in state_closed_seq st by rewrite stq.
+    by apply: (C _ _ ein cin').
+  rewrite cats1 -map_rcons=> /mapP[c' c'in /[dup] cq ->].
+  have c'in' : c' \in state_open_seq st.
+    by rewrite ocd -cat_rcons !mem_cat c'in orbT.
+  move=> p /orP[] pin.
+    apply: (D e c' ein c'in').
+    by move: pin; rewrite in_safe_side_left_close_cell.
+  have /andP[vlc' vhc'] : valid_edge (low c') (point ev) &&
+                                   valid_edge (high c') (point ev).
+    by apply: (allP sval).
+  move: (pin) => /andP[] + _.
+  rewrite right_limit_close_cell // => /eqP pxq.
+  apply/eqP=> abs.
+  have := old_lt_fut _ _ ein (mem_head _ _).
+  by rewrite -abs pxq lt_irreflexive.
+have op_safe_event :
+{in rcons p_set ev & state_open_seq rstate,
+    forall (e : event') (c : cell) (p : pt),
+    in_safe_side_left p c -> p != point e}.
+  move=> e c ein; rewrite /rstate/state_open_seq/=.
+  rewrite -catA -cat_rcons !mem_cat orbCA=> /orP[cnew | cold]; last first.
+    have cin : c \in state_open_seq st.
+      by rewrite ocd -cat_rcons !mem_cat orbCA cold orbT.
+    move: ein; rewrite mem_rcons inE=> /orP[/eqP -> | eold]; last first.
+      by apply: (D _ _ eold cin).
+    (* use lolt *)
+    have := lolt _ _ cin (mem_head _ _)=> llt p /andP[] /eqP pll _.
+    apply/eqP=> pev.
+    by move: llt; rewrite -pll pev lt_irreflexive.
+  move=> p pin.
+  have : has (in_safe_side_left p)
+           (opening_cells (point ev) (outgoing ev) le he).
+    by apply/hasP; exists c; rewrite // /opening_cells oca_eq.
+  have := sides_equiv inbox_es oute rfo cbtom adj sval; rewrite stq /=.
+  move=> /(_ _ _ _ _ _ _ oe p) /eqP <- => /hasP[] c' c'in pin'.
+  have := cl_safe_event _ c' ein; apply.
+    by rewrite /rstate /state_closed_seq/= rcons_cat /= mem_cat inE c'in ?orbT.
+  by rewrite pin' orbT.
+have old_lt_fut' :
+  {in rcons p_set ev & future_events,
+     forall e1 e2, p_x (point e1) < p_x (point e2)}.
+  move=> e1 e2; rewrite mem_rcons inE=>/orP[/eqP -> | e1old] e2fut; last first.
+    by apply: old_lt_fut; rewrite // inE e2fut orbT.
+  have := general_pos c_inv=> /andP[] _ /=.
+  rewrite path_sortedE; last by move=> ? ? ?; apply: lt_trans.
+  by move=> /andP[] /allP + _; apply.
+have rf_closed1 : {in state_closed_seq rstate, forall c, low c <| high c}.
+  move=> c; rewrite /rstate/state_closed_seq/=.
+  rewrite appE -cat_rcons -cats1 -catA.
+  rewrite mem_cat=> /orP[cin | ].
+    by apply: rf_cl; rewrite /state_closed_seq stq/=.
+  rewrite cats1 -map_rcons=> /mapP[c' c'in ->].
+  have [-> -> _] := close_cell_preserve_3sides (point ev) c'.
+  have [[] + _ _ _ _ _ _ _ _ _] := c_inv.
+  move=> [] _ [] _ [] _ [] _ /allP; apply.
+  by rewrite ocd -cat_rcons !mem_cat c'in orbT.
+have lo_lb' : {in state_open_seq rstate, forall c,
+               left_limit c < min (p_x (right_pt bottom)) (p_x (right_pt top))}.
+  move=>c; rewrite /state_open_seq/= -catA -cat_rcons !mem_cat orbCA.
+  move=> /orP[cnew | cold]; last first.
+    by apply: lo_lb; rewrite ocd -cat_rcons !mem_cat orbCA cold orbT.
+  have := opening_cells_left oute vl vp ; rewrite /opening_cells oca_eq.
+  move=> /(_ _ cnew) ->.
+  by apply: inside_box_lt_min_right.
+by constructor.
+Qed.
+
+(*
+
+Lemma start_cover (bottom top : edge) (s : seq edge) closed open :
+  bottom <| top ->
+  open_cell_side_limit_ok (start_open_cell bottom top) ->
+  {in bottom :: top :: s &, no_crossing R} ->
+  all (inside_box bottom top) [seq left_pt x | x <- s] ->
+  all (inside_box bottom top) [seq right_pt x | x <- s] ->
+  start (edges_to_events s) bottom top = (closed, open) ->
+  forall p, inside_box bottom top p ->
+  has (inside_closed' p) closed || has (inside_open' p) open.
+Proof.
+move=> boxwf boxwf2 nocs leftin rightin; rewrite /start.
+set evs := edges_to_events s.
+have/perm_mem := edges_to_events_no_loss s.
+  rewrite -/evs/events_to_edges/= => stoevs.
+set op0 := [:: Bcell (leftmost_points bottom top) [::] bottom top].
+set cl0 := (X in scan _ _ X).
+have : sorted (@lexPt R) [seq point x | x <- evs].
+  by apply: sorted_edges_to_events.
+have : cells_bottom_top bottom top op0.
+  by rewrite /op0/cells_bottom_top/cells_low_e_top/= !eqxx.
+have : adjacent_cells op0 by [].
+have : s_right_form op0 by rewrite /= boxwf.
+have : close_alive_edges bottom top op0 evs.
+  by rewrite /=/end_edge !inE !eqxx !orbT.
+have : {in cell_edges op0 ++ flatten [seq outgoing i | i <- evs] &,
+         no_crossing R}.
+  rewrite /=; move: nocs; apply sub_in2.
+  move=> x; rewrite !inE => /orP[ -> // | /orP[-> // | ]]; rewrite ?orbT //.
+  by rewrite -stoevs => ->; rewrite ?orbT.
+have : {in evs, forall ev, out_left_event ev}.
+  by apply: out_left_edges_to_events.
+have : close_edges_from_events bottom top evs.
+  by apply: edges_to_events_wf.
+have evsin0 : all (inside_box bottom top)
+    [seq point ev | ev <- evs].
+  apply/allP.
+  have : {subset [seq right_pt g | g <- s] <= inside_box bottom top}.
+    by apply/allP: rightin.
+  have : {subset [seq left_pt g | g <- s] <= inside_box bottom top}.
+    by apply/allP: leftin.
+  by apply: edges_to_events_subset.
+have btm_left0 : {in [seq point e | e <- evs],
+         forall e,  bottom_left_cells_lex op0 e}.
+  move=> ev /[dup] /(allP evsin0) /andP[_ /andP[valb valt]] evin c.
+  rewrite /op0 inE /lexPt /bottom_left_corner=> /eqP -> /=.
+  by apply/orP; left; apply/inside_box_left_ptsP/(allP evsin0).
+have sval0 :
+  evs != nil -> seq_valid op0 (head dummy_pt [seq point ev | ev <- evs]).
+  case evseq : evs => [// | ev evs'] _ /=; rewrite andbT.
+  move: evsin0; rewrite evseq /= => /andP[] /andP[] _ /andP[] ebot etop _.
+  have betW : forall a b c : R, a < b < c -> a <= b <= c.
+    by move=> a b c /andP[] h1 h2; rewrite !ltW.
+  by rewrite /valid_edge !betW.
+have cov0 : forall p, all (lexePt p) [seq point ev | ev <- evs] ->
+         cover_left_of bottom top p op0 cl0.
+  move=> p limrp q inbox_q qp; apply/orP; left; apply/hasP.
+  exists (Bcell (leftmost_points bottom top) nil bottom top).
+    by rewrite /op0 inE eqxx.
+  rewrite inside_open'E.
+  apply/andP; split;[ | apply/andP; split].
+  - by apply: underW; move: inbox_q=> /andP[] /andP[].
+  - by move: inbox_q=> /andP[] /andP[].
+  - rewrite /open_limit /=.
+    case: (ltrP  (p_x (right_pt bottom)) (p_x (right_pt top))) => _.
+    rewrite inside_box_left_ptsP //.
+    by move: inbox_q => /andP[] _ /andP[] /andP[] _ /ltW ->.
+  rewrite inside_box_left_ptsP //.
+  by move: inbox_q => /andP[] _ /andP[] _ /andP[] _ /ltW ->.
+have leftlim0 : {in op0, forall c p, inside_box bottom top p ->
+         left_limit c = p_x p ->
+         contains_point' p c -> has (inside_closed' p) cl0}.
+  move=> c + p; rewrite inE -[Bcell _ _ _ _]/(start_open_cell bottom top).
+  move=> /eqP -> {c}.
+  move/inside_box_left_ptsP/[swap].
+  by rewrite (leftmost_points_max boxwf2)=> ->; rewrite lt_irreflexive.
+move: cov0 evsin0 sval0 btm_left0 leftlim0; move=> {stoevs}.
+elim: evs op0 cl0 => [ | ev evs' Ih]
+   op cl main evsin sval btm_left llim clev oute noc clae rfo adj cbtom sortev.
+  rewrite /= => [][] <- <- p inbox_p.
+  have lexpp : lexePt p p by rewrite lexePt_eqVlt eqxx.
+  by rewrite orbC; apply: (main p isT p inbox_p lexpp).
+rewrite /=.
+case stepeq : (step ev op cl) => [op' cl'].
+move=> scaneq.
+have inbox_e : inside_box bottom top (point ev).
+  by apply: (allP evsin); rewrite map_f // inE eqxx.
+have := sval isT; rewrite /= => sval'.
+have oute' : out_left_event ev by apply: oute; rewrite inE eqxx.
+have btm_left' : bottom_left_cells_lex op (point ev).
+  by apply: btm_left; rewrite inE eqxx.
+have cov : cover_left_of bottom top (point ev) op cl.
+  apply: main=> /=; rewrite lexePt_eqVlt eqxx /=.
+  move: sortev; rewrite /sorted /=.
+  rewrite  (path_sortedE (@lexPt_trans R)) // => /andP[+ _].
+  by apply: sub_all; exact: lexPtW.
+have cov' : forall p : pt,
+    all (lexePt p) [seq point ev0 | ev0 <- evs'] ->
+    cover_left_of bottom top p op' cl'.
+  have := step_keeps_cover sortev cbtom adj inbox_e sval' oute' rfo clae clev
+           noc btm_left' llim stepeq cov.
+  move=> it p; apply: it.
+have evle : forall ev', ev' \in evs' -> lexPt (point ev) (point ev').
+  move=> ev' ev'in.
+  move: sortev=> /=; rewrite (path_sortedE (@lexPt_trans R))=> /andP[]/allP.
+  by move=> /(_ (point ev')) + _; apply; apply map_f.
+have svalr : evs' != [::] ->
+       seq_valid op' (head dummy_pt [seq point ev0 | ev0 <- evs']).
+  case evs'eq : evs' => [// | a q] /= _.
+  have inbox_a : inside_box bottom top (point a).
+    by apply: (allP evsin); rewrite evs'eq !inE eqxx orbT.
+  have eva : lexPt (point ev) (point a).
+    by apply: evle; rewrite evs'eq inE eqxx.
+  have limra : forall e', e' \in evs' -> lexePt (point a) (point e').
+    rewrite evs'eq => e'; rewrite inE => /orP[/eqP -> | e'q ].
+      by rewrite lexePt_eqVlt eqxx.
+    move: sortev=> /=; rewrite evs'eq=> /path_sorted/=; rewrite path_sortedE.
+      by move=>/andP[]/allP/(_ (point e') (map_f (@point _) e'q))/lexPtW.
+    exact: lexPt_trans.
+  have := step_keeps_valid inbox_a inbox_e eva oute' rfo cbtom adj sval' clae
+            clev limra stepeq.
+  by [].
+have btm_leftr:
+   {in [seq point e | e <- evs'], forall e, bottom_left_cells_lex op' e}.
+  have btm_left2 :=
+    step_keeps_left_pts_inf inbox_e oute' rfo sval' adj cbtom clae clev
+           noc btm_left' stepeq.
+  by move=> evp /mapP [ev' ev'in ->]; apply/btm_left2/evle.
+have evsinr : all (inside_box bottom top) [seq point ev' | ev' <- evs'].
+  by move: evsin; rewrite /= => /andP[].
+have clevr : close_edges_from_events bottom top evs'.
+  by move: clev; rewrite /= => /andP[].
+have outer :{in evs', forall ev0 : event, out_left_event ev0}.
+  by move: oute; apply: sub_in1=> x xin; rewrite inE xin orbT.
+have nocr : {in cell_edges op' ++ flatten [seq outgoing i | i <- evs'] &,
+     no_crossing R}.
+  move: noc; apply: sub_in2=> x.
+  rewrite mem_cat=> /orP[].
+    move/(step_sub_open_edges cbtom adj sval' oute' inbox_e stepeq)=> it.
+    by rewrite /= /cell_edges catA -(catA _ _ (outgoing ev)) mem_cat it.
+  by move=> xinf; rewrite /= !mem_cat xinf !orbT.
+have claer : close_alive_edges bottom top op' evs'.
+  by have := step_keeps_closeness inbox_e oute' rfo cbtom adj sval' clev
+      clae stepeq.
+have rfor : s_right_form op'.
+  have noc1: {in  cell_edges op ++ outgoing ev &, no_crossing R}.
+    move: noc; apply sub_in2=> x.
+    rewrite mem_cat=> /orP[it| xino].
+      by rewrite /= /cell_edges catA 2!mem_cat it.
+    by rewrite /= !mem_cat xino !orbT.
+  by apply: (step_keeps_right_form cbtom adj inbox_e sval' noc1 _ _ stepeq).
+have adjr : adjacent_cells op'.
+  by have := step_keeps_adjacent inbox_e oute' sval' cbtom stepeq adj.
+have cbtomr : cells_bottom_top bottom top op'.
+  by apply: (step_keeps_bottom_top inbox_e sval' adj cbtom oute' stepeq).
+have sortev' : sorted (@lexPt R) [seq point x | x <- evs'].
+  by move: sortev; rewrite /= => /path_sorted.
+have llim' : {in op', forall c p, inside_box bottom top p ->
+                  left_limit c = p_x p ->
+                  contains_point' p c -> has (inside_closed' p) cl'}.
+  by apply: (step_keeps_cover_left_border cbtom
+         adj inbox_e sval' oute' rfo clae
+       clev noc btm_left' stepeq llim).
+by have := Ih _ _ cov' evsinr svalr btm_leftr llim' clevr outer nocr claer
+  rfor adjr cbtomr sortev' scaneq.
+Qed.
+
+Lemma middle_disj_last fc cc lcc lc nos lno:
+ open = fc ++ cc ++ lcc :: lc ->
+  adjacent_cells (fc ++ nos ++ lno :: lc) ->
+  s_right_form  (fc ++ nos ++ lno :: lc)->
+  low (head lno nos) =low (head lcc cc) ->
+  high lno = high lcc ->
+  {in [seq high c | c <- nos], forall g, left_pt g == (point e)} ->
+  {in rcons nos lno &, disjoint_open_cells R} ->
+   {in fc ++ nos ++ lno :: lc &, disjoint_open_cells R}.
+Proof.
+move=> ocd adjn rfon lecnct hecnct lefts ndisj.
+move: pwo=> /= /andP[] _ pwo'.
+have:= disoc adj pwo'.
+Qed.
+
+
+
+Lemma disjoint_open_parts fc cc lcc lc nos lno :
+   open = fc ++ cc ++ lcc :: lc ->
+  close_alive_edges (fc ++ nos ++ lno :: lc) future_events ->
+  low (head lcc cc) <| high lcc ->
+   low (head lcc cc) = low (head lno nos) ->
+   high lcc = high lno ->
+  {in rcons nos lno &, disjoint_open_cells R} ->
+  {in fc ++ nos ++ lno :: lc &, disjoint_open_cells R}.
+Proof.
+move=> ocd clae_new low_high.
+have lfcbot : fc != [::] -> low (head dummy_cell fc) = bottom.
+  move: cbtom; rewrite ocd.
+  by case: (fc) => [// | /= ca ?] /andP[] /andP[] _ /=/eqP.
+have higfc : fc != nil -> high (last dummy_cell fc) = low (head lcc cc).
+  elim/last_ind : (fc) ocd => [// |s c' _] /= ocd.
+  move: adj; rewrite ocd cat_rcons last_rcons =>/adjacent_catW[] _ /=.
+  by case: (cc) => [ | cc0 cc'] /= /andP[] /eqP ->.
+move=> le_cnct.
+move=> he_cnct.
+have adjnew : adjacent_cells (fc ++ nos ++ lno :: lc).
+  rewrite (_ : fc ++ nos ++ lno :: lc =
+                fc ++ (rcons nos lno) ++ lc);last first.
+    by rewrite -cats1 -!catA.
+  a d m i t.
+have rfnew : s_right_form (fc ++ nos ++ lno :: lc).
+  a d m i t.
+apply: (@middle_disj_last _ cc lcc)=> //.
+
+*)
+End working_environment.
diff --git a/theories/civt.v b/theories/civt.v
index a67007e..0cf0f63 100644
--- a/theories/civt.v
+++ b/theories/civt.v
@@ -55,7 +55,7 @@ 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_wpmul2r//.
+  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.
diff --git a/theories/conv.v b/theories/conv.v
index 03ffb97..46b2a86 100644
--- a/theories/conv.v
+++ b/theories/conv.v
@@ -68,7 +68,7 @@ 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_wpmul2r ?invr_ge0//.
+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.
@@ -157,7 +157,7 @@ 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 ler_add; rewrite -subr_ge0.
+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.
@@ -209,7 +209,7 @@ have c0: forall x y : R, 0 <= x -> 0 <= y -> (x : R^o) <| t |> y = 0 -> x = 0 /\
       by move=>/eqP->.
    move=>x0 y0 c0.
    suff: 0 < (x : R^o) <| t |> y by rewrite c0 ltxx.
-   rewrite /conv -(addr0 0) ; apply ltr_le_add.
+   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.
@@ -225,7 +225,7 @@ End Conv.
 
 Section between.
 Variable R : realType.
-Let Plane := pair_vectType (regular_vectType R) (regular_vectType R).
+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.
@@ -255,13 +255,21 @@ 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=>/=; have ->: forall (a: R) (b: (regular_vectType (Real.ringType R))), a *: b = a*b by lazy.
-   - by rewrite -mulrA [_^-1*_]mulrC divff // mulr1.
-   - by rewrite mulrC mulrA -e mulrC mulrA [_^-1*_]mulrC divff // mul1r.
+   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=>/=; have ->: forall (a: R) (b: regular_vectType (Real.ringType R)), a *: b = a*b by lazy.
-- by rewrite mulrC mulrA e mulrC mulrA [_^-1*_]mulrC divff // mul1r.
-- by rewrite -mulrA [_^-1*_]mulrC divff // mulr1.
+   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,
diff --git a/theories/convex.v b/theories/convex.v
index 464edc8..e9af65b 100644
--- a/theories/convex.v
+++ b/theories/convex.v
@@ -1,5 +1,7 @@
-From mathcomp Require Import all_ssreflect all_algebra vector reals ereal classical_sets boolp Rstruct.
-From infotheo Require Import convex Reals_ext.
+From HB Require Import structures.
+From mathcomp Require Import all_ssreflect all_algebra vector mathcomp_extra.
+From mathcomp Require Import reals ereal classical_sets boolp Rstruct lra.
+From infotheo Require Import ssrR Reals_ext realType_ext fdist convex.
 Require Import preliminaries.
 
 Import Order.POrderTheory Order.TotalTheory GRing.Theory Num.Theory preliminaries.
@@ -8,8 +10,6 @@ Local Open Scope ring_scope.
 
 Require Import Reals.
 Local Close Scope N_scope.
-Local Close Scope R_scope.
-Delimit Scope R_scope with coqR.
 Delimit Scope nat_scope with N.
 Delimit Scope int_scope with Z.
 Delimit Scope ring_scope with R.
@@ -25,8 +25,7 @@ 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}.
-move=>Aconv.
-by exists A; apply CSet.Mixin.
+by move=> Aconv; exists A; constructor; constructor.
 Defined.
 
 Lemma is_convex_setI (C D : {convex_set E}) : is_convex_set (C `&` D).
@@ -39,76 +38,74 @@ Qed.
 Lemma hullX (F : convType) (C : set E) (D : set F) : hull (C `*` D) = hull C `*` hull D.
 Proof.
 rewrite eqEsubset; split.
-   move=>+ [n][g][d][gCD]-> =>_.
+   move=>+ [n][/=g][/=d][gCD]-> =>_.
    rewrite Convn_pair; split=>/=;
-      exists n; [exists (fst \o g) | exists (snd \o g)]; exists d; split=> // + [i] _ <- =>_ /=;
+      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->]=>_ _.
+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; rewrite !S1_Convn big_prod_ord/=.
   apply eq_big => // i _.
-  rewrite -(scale1pt (scalept _ _)) scaleptA// -(FDist.f1 e).
-  move: (@mulr_suml R_ringType _ (index_enum [finType of 'I_m]) (mem 'I_m)
-    (fun i => nneg_ff e i) (nneg_ff d i)); rewrite -RmultE => ->.
-  simple refine (let h : nneg_fun 'I_m := _ in _).
-     exists (fun j => nneg_ff e j * nneg_ff d i)%coqR=>j.
-     exact: ssrR.mulR_ge0.
-  have -> : (\sum_(j in 'I_m) (nneg_ff e j) * (nneg_ff d i) =
-             \sum_(i in 'I_m) nneg_f h i)%coqR.
-     by apply eq_big => // j _; rewrite fdist_prodE.
+  rewrite -(scale1pt (scalept _ _)) scaleptA // -[(1 * d i)%coqR]/(1 * d i) -(FDist.f1 e).
+  rewrite mulr_suml.
+  have @h : nneg_fun 'I_m.
+    (* BUG HB.pack *)
+    exists (fun j => e j * d i)%coqR => j.
+    by apply: ssrR.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 [finType of 'I_n * 'I_m] |
+  have -> : (\sum_(a in {: 'I_n * 'I_m} |
                    a \in preim (@unsplit_prod _ m) (pred1 (Ordinal (unsplit_prodp i j))))
-             nneg_ff (fdist_prod d (fun=> e)) a =
-             \sum_(a in [finType of 'I_n * 'I_m] | a \in pred1 (i, j))
-             nneg_ff (fdist_prod d (fun=> e)) a)%coqR.
+              (fdist_prod d (fun=> e)) a =
+             \sum_(a in {: 'I_n * 'I_m} | a \in pred1 (i, j))
+              (fdist_prod d (fun=> e)) a)%coqR.
      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/= ssrR.mulRC; congr (scalept _ (S1 (g _))).
-  by move: (unsplit_prodK (i, j)) => /(congr1 fst)/esym.
+  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).
-move: (@mulr_suml R_ringType _ (index_enum [finType of 'I_n]) (mem 'I_n)
-  (fun i=> nneg_ff d i) (nneg_ff e j)); rewrite -RmultE => ->.
-simple refine (let h : nneg_fun 'I_n := _ in _).
-   exists (fun i=> nneg_ff d i * nneg_ff e j)%coqR => i.
-   exact: ssrR.mulR_ge0.
-have -> : (\sum_(i in 'I_n) nneg_ff d i * nneg_ff e j = \sum_(i in 'I_n) nneg_f h i)%coqR.
-   by apply eq_big=>// i _; rewrite fdist_prodE.
+rewrite -(scale1pt (scalept _ _)) scaleptA// -[(1 * e j)%coqR]/(1 * e j) -(FDist.f1 d).
+rewrite mulr_suml.
+
+have @h : nneg_fun 'I_n.
+(* BUG HB.pack *)
+   exists (fun i => d i * e j)%coqR => i.
+   by apply: ssrR.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 [finType of 'I_n * 'I_m] |
+have -> : (\sum_(a in {: 'I_n * 'I_m} |
    a \in preim (unsplit_prod (n:=m)) (pred1 (Ordinal (unsplit_prodp i j))))
-         nneg_ff (fdist_prod d (fun=> e)) a =
+          (fdist_prod d (fun=> e)) a =
    \sum_(a in
-   [finType of 'I_n * 'I_m] | a \in pred1 (i, j))
-      nneg_ff (FDist.f (fdist_prod d (fun=> e))) a)%coqR.
+   {: 'I_n * 'I_m} | a \in pred1 (i, j))
+       (FDist.f (fdist_prod d (fun=> e))) a)%coqR.
    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/= ssrR.mulRC; congr (scalept _ (S1 (f _))).
-by move:(unsplit_prodK (i, j))=>/(congr1 snd)/esym.
+rewrite (big_pred1 (i, j))// fdist_prodE/=; congr (scalept _ (S1 (f _))).
+by move:(unsplit_prodK (i, j))=>/(congr1 Datatypes.snd)/esym.
 Qed.
 
 End convex.
-
-Lemma add_affine (E : lmodType R_ringType) : affine (fun p : E * E => p.1 + p.2).
+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_ringType) (t : R) : affine (fun x : E => t *: x).
+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_ringType.
+Variable E F: lmodType R.
 Variable f : {linear E -> F}.
 
 Local Open Scope fun_scope.
@@ -150,26 +147,41 @@ 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_ringType.
+Variable E: lmodType R.
 
 Local Open Scope fun_scope.
 Local Open Scope ring_scope.
 Local Open Scope convex_scope.
 
-Lemma probinvn1 : probinvn 1 = 2^-1 :> R_numFieldType.
+Lemma probinvn1 : probinvn 1 = (1 / 2%R : R)%:pr.
 Proof.
-rewrite /R_numFieldType /GRing.inv /= /Rinvx.
-case:ifP=>// /negbFE.
-by rewrite/Rdefinitions.IZR intr_eq0.
+apply: val_inj => /=.
+by rewrite div1R.
 Qed.
 
-Lemma onem_half: onem 2^-1 = 2^-1.
+Lemma onem_half: onem 2^-1 = 2^-1 :> R.
 Proof.
-have ne20: (2 : R_ringType) != 0 by rewrite intr_eq0.
-apply (mulfI ne20).
-by rewrite mulrBr mulr1 divff// -pmulrn mulr2n -addrA subrr addr0.
+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;
@@ -178,8 +190,11 @@ Lemma ext_carac (A : {convex_set E}) (x: E): x \in A -> [<-> x \in ext A;
   face A [set x]].
 Proof.
 move=>xA.
-have ne20: (2 : R_ringType) != 0 by rewrite intr_eq0.
-have ge20: (0 : R_ringType) <= 2 by apply mulrz_ge0=>//; exact ler01.
+have ne20: (2 : R) != 0.
+  rewrite [X in X != _](_ : _ = 2%:R)//.
+  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).
@@ -192,43 +207,44 @@ split.
       apply /esym; apply h=>//; last by left.
       rewrite xe convC; congr (v <| _ |> u).
       apply val_inj=>/=.
-      rewrite probinvn1 /onem.
-      by apply/eqP; rewrite subr_eq -(div1r 2) -splitr.
+      set tmp : R := (1 + 1)%:R.
+      rewrite (_ : tmp = 2%R)//.
+      rewrite coqRE.
+      by rewrite onem_half.
       move: xe=> -> + _.
       move=> /(congr1 (fun x => 2 *: x)).
-      rewrite scalerDr probinvn1 onem_half 2!scalerA divff// 2!scale1r.
-      by rewrite -pmulrn mulr2n scalerDl scale1r=>/addrI/esym.
+      rewrite scalerDr probinvn1/=.
+      rewrite div1R coqRE.
+      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 / (t : R_ringType) <= 2^-1.
+   wlog: u v t xext xA uA ux vA vx / Prob.p t <= 2^-1.
       move=>h.
-      have [tle|tle] := leP (t : R_ringType) (2^-1); first exact: (h u v t).
+      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 ler_sub=>//.
+      rewrite -onem_half; apply: lerB=>//.
       exact/ltW.
    move=>tle.
-   have t01: ssrR.leRb (Rdefinitions.IZR BinNums.Z0) (2%:R*(t : R_ringType)) &&
-  ssrR.leRb (2*(t : R_ringType)) (Rdefinitions.IZR (BinNums.Zpos 1%AC)).
-      apply/andP; split; apply/ssrR.leRP/RleP.
-         apply mulr_ge0=>//.
-         by apply/RleP/prob_ge0.
-      by move:tle=>/(ler_wpmul2l ge20); rewrite divff.
+   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*(t : R_ringType))/2 = t.
+      have tE: (2*(Prob.p t : R))/2 = Prob.p t.
          by rewrite mulrAC divff// mul1r.
       rewrite -{2}tE.
       congr Rdefinitions.RbaseSymbolsImpl.Rmult.
-      rewrite/R_unitRing/GRing.inv/=/Rinvx.
-      case:ifP=>//.
-      by rewrite ne20.
+      by rewrite coqRE//.
    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)).
@@ -268,7 +284,7 @@ split => //.
   by apply (Gface x).
 Qed.
 
-Definition supporting_hyperplane (A : set E) (f: {linear E -> R^o}) (a: R_ringType) :=
+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)).
 
@@ -280,7 +296,7 @@ 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_ringType) :
+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.
@@ -288,32 +304,31 @@ 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=>/(_ (GRing.comp_linear f (GRing.opp_linear E)) (- a)).
-      have hf' (x : E) : x \in A -> GRing.comp_linear f (GRing.opp_linear E) x <= - a.
-        by move=> xA /=; rewrite -scaleN1r linearZZ scaleN1r ler_oppl opprK; apply hf.
-      have hex': exists x : E, x \in A /\ GRing.comp_linear f (GRing.opp_linear E) x = - 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 _ (convex_set_of (is_convex_set1 (a : GRing.regular_lmodType R_ringType)))))).
+      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 : (t : R_ringType) != 0.
+   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 < (t : R_ringType) by rewrite lt0r t0=>/=; exact/RleP.
-   move: tx=>/(f_equal (fun x=> (t : R_ringType)^-1 *: (x - (onem t) *: v))).
+   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_pdivl_mull// addrC -subr_ge0 -addrA -mulNr -{1}[a]mul1r -mulrDl scaleNr -scalerN -mulrDr; apply mulr_ge0.
-      exact/RleP.
+   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: ssrR.leRb (Rdefinitions.IZR BinNums.Z0) ((f v - a) / (f v - f u))%R &&
-  ssrR.leRb ((f v - a) / (f v - f u))%R (Rdefinitions.IZR (BinNums.Zpos 1%AC)).
-      apply/andP; split; apply/ssrR.leRP/RleP.
+   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_pdivr_mulr// mul1r -subr_ge0 opprB addrAC addrCA subrr addr0 subr_ge0.
+         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.
@@ -322,7 +337,7 @@ have : forall x y, x \in A -> y \in A -> f x < a -> a < f y -> False.
       rewrite/= affine_conv/=/conv/=.
       move: fufv; rewrite lt0r=>/andP [fufv _].
       apply (mulfI fufv).
-      rewrite/GRing.regular_lmodType/GRing.scale/=.
+      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.
@@ -351,35 +366,41 @@ Qed.
 End face.
 Section cone.
 
-Variable E: lmodType R_ringType.
+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 : R_ringType) *: a | t in (@setT Rpos) & a in A] `<=` A)%classic.
+  ([set (t : R) *: a | t in (@setT Rpos) & 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_ringType) != 0 by rewrite intr_eq0.
-have /RltP/ssrR.ltRP gt20: (0 : R_ringType) < 2 by rewrite ltr0z.
+have ne20: (2 : R) != 0.
+  rewrite [X in X != _](_ : _ = 2%:R)//.
+  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 (Rpos.mk gt20)=>//; exists u.
    have vA2: A (2 *: v) by apply Acone; exists (Rpos.mk gt20)=>//; exists v.
    move:Aconv=>/asboolP/(_ _ _ (probinvn 1) uA2 vA2); congr A.
-   by rewrite/conv/= probinvn1 onem_half 2!scalerA mulrC divff// 2!scale1r.
+   rewrite probinvn1/=.
+   rewrite /conv/=.
+   rewrite div1R coqRE.
+   by rewrite onem_half 2!scalerA mulVf// 2!scale1r.
 apply/asboolP.
 move=>x y t xA yA.
-move:(prob_ge0 t)=>/RleP; rewrite le0r=>/orP; case.
+move:(prob_ge0 t); rewrite le0r=>/orP; case.
    by rewrite/conv/= =>/eqP ->; rewrite scale0r add0r onem0 scale1r.
-move=>/RltP/ssrR.ltRP t0; move: (prob_le1 t)=>/RleP; rewrite -subr_ge0 le0r=>/orP; case.
+move=> t0; move: (prob_le1 t); rewrite -subr_ge0 le0r=>/orP; case.
    by rewrite subr_eq0 /conv/= =>/eqP <-; rewrite onem1 scale0r addr0 scale1r.
-move=>/RltP/ssrR.ltRP t1; apply Aconv; exists ((t : R_ringType) *: x);
+move=> t1; apply Aconv; exists ((Prob.p t : R) *: x);
    [| exists ((onem t) *: y) ]=>//; apply Acone.
   by exists (Rpos.mk t0)=>//; exists x.
 by exists (Rpos.mk t1)=>//; exists y.
@@ -389,7 +410,7 @@ Qed.
 (* 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 -> Rpos),
-  \sum_i (k i : R_ringType) *: (s i) = a /\ (range s `<=` A)%classic].
+  \sum_i (k i : R) *: (s i) = a /\ (range s `<=` A)%classic].
 
 Lemma cone0_of_cone0 (A: set E): cone0 (cone0_of A).
 Proof.
@@ -398,47 +419,48 @@ rewrite scaler_sumr; exists n, s, (fun i => mulRpos t (k i)); split => //.
 by apply congr_big=>// i _; apply /esym; apply scalerA.
 Qed.
 
-Lemma cone0_of_hullE (A: set E): cone0_of A = [set (t : R_ringType) *: a | t in (@setT Rpos) & a in (hull A)]%classic.
+Lemma cone0_of_hullE (A: set E): cone0_of A = [set (t : R) *: a | t in (@setT Rpos) & a in (hull A)]%classic.
 Proof.
 rewrite eqEsubset; split=>x.
-   move=>[n [s [k [<- kA]]]]; set t := \sum_i (k i : R_ringType).
-   have k0' (i : 'I_n.+1) : true -> 0 <= (k i : R_ringType) by move=> _; apply/ltW/RltP/Rpos_gt0.
+   move=>[n [s [k [<- kA]]]]; set t := \sum_i (k i : R).
+   have k0' (i : 'I_n.+1) : true -> 0 <= (k i : R) by move=> _; apply/ltW/RltP/Rpos_gt0.
    have: 0 <= t by apply sumr_ge0.
    rewrite le0r=>/orP; case.
       move=>/eqP /psumr_eq0P; move=> /(_ k0') /(_ ord0 Logic.eq_refl) k00; exfalso.
       by move:(Rpos_gt0 (k ord0))=>/RltP; rewrite k00 ltxx.
    move=>t0.
-   have tk0: forall i, Rdefinitions.Rle (Rdefinitions.IZR BinNums.Z0) ([ffun i => t^-1 * k i] i).
-      by move=>i; rewrite ffunE; apply/RleP/mulr_ge0; [ apply ltW; rewrite invr_gt0 | apply k0' ].
+   have tk0: forall i, (Rdefinitions.IZR BinNums.Z0 <= [ffun i => t^-1 * k i] i).
+      by move=>i; rewrite ffunE; apply/mulr_ge0; [ apply ltW; rewrite invr_gt0 | apply k0' ].
    have tk1 : \sum_(i < n.+1) [ffun i => t^-1 * k i] i = 1.
       transitivity (\sum_(i < n.+1) t^-1 * k i).
          by apply congr_big=>// i _; rewrite ffunE.
       rewrite -mulr_sumr mulrC divff//.
       by move:t0; rewrite lt0r=>/andP[].
-   move:(t0)=>/RltP/ssrR.ltRP t0'; exists (Rpos.mk t0')=>//; exists (t^-1 *: \sum_i (k i : R_ringType) *: s i).
-      exists n.+1, s, (@FDist.make _ (finfun (fun i=> t^-1 * k i)) tk0 tk1); split=> //.
+   move:(t0)=> t0'; exists (Rpos.mk t0')=>//; exists (t^-1 *: \sum_i (k i : R) *: s i).
+      exists n.+1, s, (@FDist.make _ _ (finfun (fun i=> t^-1 * k i)) 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 (@mathcomp_extra.bigID_idem _ _ _ _ _ _ _ _ (fun i=> 0 < d i)); [| apply addrA | apply addrC | apply addr0 ].
-have ->: \sum_(i | true && ~~ (0 < d i)) (t : R_ringType) *: (d i *: s i) = \sum_(i | true && ~~ (0 < d i)) 0 *: 0.
+rewrite avgnrE scaler_sumr.
+rewrite (@bigID_idem _ _ _ _ _ _ (fun i=> 0 < d i))/=; [| exact: addr0].
+have ->: \sum_(i | true && ~~ (0 < d i)) (t : R) *: (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)=>/RleP->; rewrite orbF=>/eqP->.
+   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 [finType of 'I_n] | 0 < d i] as I; move: HeqI=>/esym HeqI.
+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_ringType); rewrite (@mathcomp_extra.bigID_idem _ _ _ _ _ _ _ _ (fun i=> 0 < d i)); [| apply addrA | apply addrC | apply addr0 ].
+   exfalso; move: (FDist.f1 d) (oner_neq0 R); rewrite (@bigID_idem _ _ _ _ _ _ (fun i=> 0 < d i))/=; [|apply addr0 ].
    rewrite -big_filter HeqI big_nil/=.
-   have ->: forall x, Rdefinitions.RbaseSymbolsImpl.Rplus Rdefinitions.RbaseSymbolsImpl.R0 x = 0+x by [].
-   have ->: Rdefinitions.IZR (BinNums.Zpos 1%AC) = 1 by [].
    rewrite add0r=><- /eqP; apply.
-   transitivity (\sum_(i < n | true && ~~ (0 < d i)) (0*0:R_ringType)).
+   transitivity (\sum_(i < n | true && ~~ (0 < d i)) (0*0:R)).
       2: by rewrite -mulr_sumr mul0r.
-   by apply congr_big=>// i /= dile; move: (FDist.ge0 d i)=>/RleP; rewrite le0r mul0r=>/orP; case=> [ /eqP // | ]; move: dile=>/[swap]->.
-have: subseq (i::I) (index_enum [finType of 'I_n]) by rewrite -HeqI; apply filter_subseq.
+   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]].
@@ -449,7 +471,7 @@ simple refine (ex_intro _ _ _).
    simple refine (Rpos.mk _).
       exact (d (nth ord0 (i :: I) j)).
    rewrite -HeqI.
-   apply/ssrR.ltRP/RltP/(@nth_filter _ (fun i=> 0 < d i)).
+   apply/(@nth_filter _ (fun i=> 0 < d i)).
    by rewrite HeqI.
 split.
    rewrite [in RHS]HeqI.
@@ -476,18 +498,18 @@ End cone.
 Section Fun.
 
 Variable E: convType.
-Variable f: E -> \bar R_ringType.
+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),
-  f (x <|t|> y) <= EFin (t : R_ringType) * f x + EFin (onem t)%R * f y.
+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), x <> y ->
-  f (x <|t|> y) < EFin (t : R_ringType) * 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 ->
@@ -498,16 +520,18 @@ Lemma fconvex_max_ext (C: {convex_set E}) (x: E):
 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)=>/RleP; rewrite le0r=>/orP; case.
+move: (prob_ge0 t); rewrite le0r=>/orP; case.
    by move=>/eqP/val_inj ->; right; rewrite conv0.
 move=>t0.
-move: (prob_le1 t)=>/RleP; rewrite -subr_ge0 le0r=>/orP; case.
-   have->: Rdefinitions.IZR (BinNums.Zpos 1%AC) = Prob.p (1%R)%:pr by [].
-   by rewrite subr_eq0=>/eqP/val_inj <-; left; rewrite conv1.
+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: ssrR.ltRb (Rdefinitions.IZR BinNums.Z0) t &&
-       ssrR.ltRb t (Rdefinitions.IZR (BinNums.Zpos 1%AC)).
-   by apply/andP; split; apply/ssrR.ltRP/RltP.
+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).
@@ -515,8 +539,8 @@ have fle: (Prob.p t)%:E * f u + (onem (Prob.p t))%:E * f v <= 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/RleP/prob_le1.
-   apply (@lee_add R_realDomainType); rewrite (@lee_pmul2l R_realDomainType)//= lte_fin.
+      - by rewrite subr_ge0; apply/prob_le1.
+   apply (@lee_add R); rewrite (@lee_pmul2l R)//= lte_fin.
    by rewrite subr_gt0.
 by move=>/(Order.POrderTheory.le_lt_trans fle); rewrite ltxx.
 Qed.
diff --git a/theories/counterclockwise.v b/theories/counterclockwise.v
index fd273f2..461feb6 100644
--- a/theories/counterclockwise.v
+++ b/theories/counterclockwise.v
@@ -1,6 +1,6 @@
 Require Export axiomsKnuth.
 From mathcomp Require Import all_ssreflect ssralg matrix ssrnum vector reals.
-From mathcomp Require Import normedtype order.
+From mathcomp Require Import normedtype order lra.
 
 Set Implicit Arguments.
 Unset Strict Implicit.
@@ -24,7 +24,7 @@ Local Open Scope ring_scope.
 
 Section Plane.
 Variable R : realType.
-Definition Plane := pair_vectType (regular_vectType R) (regular_vectType R).
+Definition Plane : vectType _ := (R^o * R^o)%type.
 
 (* ------------------ Definitions ------------------- *)
 
@@ -89,7 +89,11 @@ 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. by rewrite develop_det /scalar_product /=; ring. Qed.
+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.
@@ -176,7 +180,7 @@ Lemma scalar_product_swap (p q : Plane) :
 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/=; ring. Qed.
+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 +
@@ -246,7 +250,7 @@ case p0: (p == 0).
    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 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.
@@ -329,7 +333,7 @@ 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_paddr; [| by apply mulr_gt0].
+apply ltr_wpDr; [| by apply mulr_gt0].
 by apply addr_ge0; apply mulr_ge0=>//; apply ltW.
 Qed.
 
@@ -347,7 +351,7 @@ 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_pdivr_mull _ _ p0) mulrA -(ltr_pdivl_mulr _ _ q0) [_^-1*_]mulrC -(ltr_pdivr_mull _ _ q0) mulrA -(ltr_pdivl_mulr _ _ r0) [_^-1*_]mulrC -(ltr_pdivr_mull _ _ p0) mulrA -(ltr_pdivl_mulr _ _ r0) [_^-1*_]mulrC=>qlt rlt; exact (lt_trans qlt rlt).
+         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.
diff --git a/theories/desc.v b/theories/desc.v
index af0a51e..30e5ffa 100644
--- a/theories/desc.v
+++ b/theories/desc.v
@@ -1,5 +1,5 @@
 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 binomial  bigop ssralg poly ssrnum ssrint rat archimedean.
 From mathcomp Require Import polyrcf.
 Require Import pol.
 
@@ -649,7 +649,7 @@ Definition inv2 (p : {poly R}) :=
 
 (* initial definition said nothing on b *)
 Definition one_root1 (p : {poly R}) (a b : R) :=
-  exists c d k, 
+  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)) &
@@ -672,9 +672,9 @@ 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 ler_add2r; apply: le_trans (_ : z * (k * (z - y)) <= _).
-  by rewrite - mulrA  ler_wpmul2r // mulr_ge0 // subr_ge0.
-by rewrite ler_wpmul2l ? incf ?xy ? yz//;apply:(le_trans x0). 
+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) *)
@@ -682,7 +682,7 @@ Qed.
 Lemma all_pos_positive (p : {poly R}) x:
   all_ge0 p -> 0 <= x -> p.[x] >= 0.
 Proof.
-move=> h x0; rewrite horner_coef. 
+move=> h x0; rewrite horner_coef.
 apply: sumr_ge0 => [] [i his _] /=.
 apply: mulr_ge0; rewrite ?exprn_ge0 //; apply: (allP h); exact: mem_nth.
 Qed.
@@ -693,8 +693,8 @@ Lemma all_pos_increasing (p : {poly R}):
 Proof.
 move=>  posp x y le0x le0y lexy; rewrite !horner_coef.
 apply: ler_sum => [] [i ihs] /= _.
-apply: ler_wpmul2l => //; first by apply: (allP posp); exact: mem_nth.
-by apply: ler_expn2r.
+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 ->
@@ -773,14 +773,14 @@ Lemma one_root2_shift p a b:
 Proof.
 move=>  [ck [/andP [x1a kp] neg sl]].
 exists (a + ck.1,ck.2); split.
-    by rewrite  ltr_add2l x1a kp.
+    by rewrite ltrD2l x1a kp.
   move=> x /= abxax1; rewrite -(addrNK a x) - horner_shift_poly.
-  by rewrite neg // ltr_subr_addl ler_subl_addl.
+  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 ? ler_add2r // ler_subr_addr  addrC.
+by apply: sl; rewrite ?lerD2r // lerBrDr  addrC.
 Qed.
 
 Lemma one_root1_shift p a b c:
@@ -789,16 +789,16 @@ Lemma one_root1_shift p a b c:
 Proof.
 move=>  [x1 [x2 [k [/and4P [ax1 x1x2 x2b kp] pos neg sl]]]].
 exists (c + x1); exists (c + x2); exists k.
-rewrite ! ltr_add2l; split => //; first by apply /and4P.
+rewrite !ltrD2l; split => //; first by apply /and4P.
     move=> x cp; rewrite - (addrNK c x).
-    rewrite -horner_shift_poly pos ? ler_sub_addl  ? ltr_sub_addl //.
+    rewrite -horner_shift_poly pos ? lerBDl  ? ltrBDl //.
   move=> x cp; rewrite - (addrNK c x).
-  by rewrite -horner_shift_poly neg // ltr_subr_addl ltr_subl_addl.
+  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 ? ler_add2r // ?ler_subr_addr? ler_subl_addr //  addrC.
+by rewrite sl ?lerD2r // ?lerBrDr? lerBlDr //  addrC.
 Qed.
 
 Lemma one_root1_scale p a b c:
@@ -808,20 +808,20 @@ 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_pmul2l cp).
+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_pdivl_mulr // mulrC  ler_pdivr_mulr //(mulrC x1).
+    by rewrite ltr_pdivlMr // mulrC ler_pdivrMr //(mulrC x1).
   move=> x cpp.
   rewrite (t x) -horner_scaleX_poly neg //.
-  by rewrite ltr_pdivl_mulr // mulrC ltr_pdivr_mulr // (mulrC b).
+  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_pdivl_mulr // mulrC.
-  by rewrite ler_wpmul2r // ltW.
-by rewrite ler_pdivr_mulr // mulrC.
+    by rewrite ler_pdivlMr // mulrC.
+  by rewrite ler_wpM2r // ltW.
+by rewrite ler_pdivrMr // mulrC.
 Qed.
 
 End DescOnOrderedField.
@@ -836,7 +836,7 @@ 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) => // _.
+  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.
@@ -851,7 +851,7 @@ move => haposp eps eps0; rewrite /inv2 /=.
     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_spaddr // mulr_ge0 //.
+  split => //; rewrite h3x h4x !hornerE ltr_pwDr // mulr_ge0 //.
   by rewrite all_pos_positive.
 (* case a < 0 *)
 rewrite -oppr_gt0 in ha.
@@ -866,10 +866,10 @@ rewrite -oppr_gt0 in ha.
   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)  ler_add2l ltW.
+    have aux: t <= t+d by rewrite - {1}(addr0 t) lerD2l ltW.
     have xtd:= (le_trans xt aux).
-    rewrite  mulrDr -addrAC addrC ltr_spaddl ?(mulr_gt0 (ppos _ xtd) dp)//.
-    rewrite !ler_add2r (ler_pmul2r (lt_le_trans xp xt)).
+    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.
@@ -879,9 +879,9 @@ rewrite -oppr_gt0 in ha.
   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) /= ler_add2r /=.
-    apply: (@le_trans _ _ (p.[x] * y)); last by rewrite ler_wpmul2r.
-    rewrite  // mulrC - ler_pdivr_mulr // ltW //.
+    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.
@@ -892,36 +892,36 @@ rewrite -oppr_gt0 in ha.
   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_pmul2l  pv) => posv.
+  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 ltr_addl /=.
+  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 ler_add2r /=.
+    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_wpmul2r => //; apply: H2 => //;apply: (le_trans cmp').
-       by rewrite ler_wpmul2l // ltW.
+       by apply: ler_wpM2r => //; apply: H2 => //;apply: (le_trans cmp').
+       by rewrite ler_wpM2l // ltW.
     apply: le_trans (_ : p.[x] * y <= _).
-      by rewrite ler_wpmul2r //; apply: H1.
+      by rewrite ler_wpM2r //; apply: H1.
     apply: le_trans (_ : p.[x] * (v + d) <= _); last first.
-      rewrite ler_wpmul2r //; first exact: le_trans yvd.
+      rewrite ler_wpM2r //; first exact: le_trans yvd.
       rewrite H2 //; first (by apply: (lexx x)); by  apply:ltW.
-    by rewrite ler_wpmul2l // 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 ler_addl subr_ge0 //.
-  rewrite -! addrA ler_add2l.
+    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 *)
@@ -934,7 +934,7 @@ 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_pmul pb (le_trans wz sw) pa st).
+    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].
@@ -946,17 +946,17 @@ split.
     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_pdivl_mulr _ _ gx0) => lpve.
+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_pmul2r gx0);apply: (ler_pmul (ltW gx0) (ltW gpx0) xv).
+   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_pmul2l (mulr_gt0 gv0 gpv0) v x).
+by rewrite (ler_pM2l (mulr_gt0 gv0 gpv0) v x).
 Qed.
 
 Lemma desc  (p: {poly R}): alternate p -> one_root2 p 0.
@@ -982,7 +982,7 @@ case: (ltrP a 0) => ha alt1.
   move:(slope_product_x (ltW xp) (lexx 0) slp xyz).
   move/andP :xyz => [xy yz].
   rewrite mulr0 add0r; apply: le_trans.
-  by apply: (ler_wpmul2r _ (pmon _ _ (lexx x) xy xy)); rewrite subr_ge0.
+  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}.
@@ -993,8 +993,8 @@ 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_maxr lexx.
-have v1v2: v1 < v2 by rewrite /v2 - addrA (ltr_addl v1).
+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.
@@ -1002,11 +1002,11 @@ have pos1:0 <= p.[v1 + v].
     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  ler_addl.
-  rewrite - (ler_addr (- p.[v1]));apply: le_trans (incr _ _ aa).
+  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 !ler_addl v0 ler01.
+  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.
@@ -1030,8 +1030,8 @@ 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_wpmul2r //; first by rewrite subr_ge0.
-rewrite mulrC - (double_half (k * v1 )) -/k' - addrA ler_addl.
+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.
@@ -1049,21 +1049,21 @@ 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' ltr_addl oppr_gt0 pmulr_llt0 // ?invr_gt0.
+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 - (ler_add2r (- q.[x1])) add0r; apply: le_trans (sl _ _ aux).
+  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_maxr lexx orbT.
-have u1: 1 <= u' by rewrite le_maxr lexx.
+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_pdivr_mulr // ler_pemulr //.
+   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 ltr_addl.
+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).
@@ -1086,18 +1086,18 @@ 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 => yn0.
+  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 le_minl lexx.
+have blty: b <= y by  rewrite /b ge_min lexx.
 have b'b: b' < b.
-  rewrite lt_minr (le_lt_trans b'y' y'y) /= - ltr_subl_addl addrN.
+  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_pdivl_mull _ _ cp0) mulrC ler_subl_addl le_minl lexx orbT.
+  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.
@@ -1116,7 +1116,7 @@ have res1:pos_in_interval 0 b^-1 (horner p).
   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_pinv.
+    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).
@@ -1134,7 +1134,7 @@ have res2: neg_in_interval1 a^-1 1 (horner p).
   by rewrite mulr_gt0 // subr_gt0.
 exists b^-1, a^-1, k'.
 split => //.
-  rewrite k'p ibp ltf_pinv// (inv_compr ltr01 a0) invr1.
+  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].
@@ -1167,32 +1167,32 @@ 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_pinv.
+have xzi: z^-1 < x^-1 by rewrite ltf_pV2.
 have pa : x1 <=  z^-1.
-  by rewrite (le_trans x1a)// -(invrK a)// lef_pinv// posrE invr_gt0.
+  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_pinv.
+  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_wpmul2l.
-rewrite mulrDl; apply: ler_add; last first.
+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_pmul2r; last by apply: exprn_gt0; rewrite invr_gt0.
+  rewrite ler_pM2r; last by apply: exprn_gt0; rewrite invr_gt0.
   apply: le_trans pd.
-  rewrite ![k * _]mulrC mulrAC ler_pmul2r //.
+  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_pmul2r /=; last by rewrite subr_gte0.
-  apply: le_trans (_ : x1 / z <= _); first rewrite ler_pmul2l //=.
-  by rewrite ler_pmul2r ?invr_gt0.
+  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//.
@@ -1201,33 +1201,33 @@ 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 lter_oppl oppr0  mulr_ge0 //?(ltW k'p)// subr_gte0 /= ltW.
+   by rewrite mulNr lterNl oppr0 mulr_ge0 //?(ltW k'p)// subr_gte0 /= ltW.
   by rewrite mulr_le0 // ltW.
-rewrite mulNr lter_oppl -mulNr opprD  opprK addrC.
+rewrite mulNr lterNl -mulNr opprD opprK addrC.
 have rpxe : q.[x^-1] <= e.
-  have bvx' : x^-1 <= b by rewrite -(invrK b)// lef_pinv.
+  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) (ler_add clb')//.
+  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_wpmul2l // ?subr_gte0.
+  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_wpmul2l; first exact: ltW.
+  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_pmul2r // subr_gte0.
-rewrite mulrA ler_pmul2r; last by rewrite subr_gte0.
+  by rewrite ler_pM2r // subr_gte0.
+rewrite mulrA ler_pM2r; last by rewrite subr_gte0.
 rewrite /= /e  divfK ?lterr //.
 Qed.
 
diff --git a/theories/desc1.v b/theories/desc1.v
index 8458ce5..f1724f0 100644
--- a/theories/desc1.v
+++ b/theories/desc1.v
@@ -174,7 +174,7 @@ 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
+by case: (d<0); case: (b<0); case: (c<0); rewrite ?mulrNN ? mulr1 ?mul1r ?ltr01
     ?ltrN10 ? ltr10 ? ltr0N1 ?addn0 ? addnS ?addn0//=; move => ->.
 Qed.
 
@@ -594,7 +594,9 @@ have q2: all (root q) l.
 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 2! (big_nth 0) 2! big_mkord; apply: eq_bigr => i _.
+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.
diff --git a/theories/desc2.v b/theories/desc2.v
index e621a0e..0dc145e 100644
--- a/theories/desc2.v
+++ b/theories/desc2.v
@@ -197,7 +197,7 @@ 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
+by case: (d<0); case: (b<0); case: (c<0); rewrite ?mulrNN ? mulr1 ?mul1r ?ltr01
     ?ltrN10 ? ltr10 ? ltr0N1 ?addn0 ? addnS ?addn0//=; move => ->.
 Qed.
 
@@ -282,7 +282,9 @@ have q2: all (root q) l.
 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 2! (big_nth 0) 2! big_mkord; apply: eq_bigr => i _.
+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.
diff --git a/theories/door_crossing.v b/theories/door_crossing.v
index 3605d6c..7067e18 100644
--- a/theories/door_crossing.v
+++ b/theories/door_crossing.v
@@ -1,4 +1,5 @@
-From mathcomp Require Import all_ssreflect all_algebra all_real_closed reals.
+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.
 
@@ -13,15 +14,14 @@ Local Open Scope ring_scope.
 
 Section sandbox.
 
-Lemma poly_coord {R : rcfType} 
-  (c : pair_vectType (regular_vectType R) (regular_vectType R))
+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
@@ -47,7 +47,7 @@ Proof. by rewrite /= /conv addrC. Qed.
   bezier c 2 t =  (bernp 0 1 2 0) *: c 0%N. *)
 
 Lemma bezier_bernstein2 c t :
-  bezier c 2 t = 
+  bezier c 2 t =
     \sum_(i < 3) (bernp 0 1 2 i).[t] *: c i.
 Proof.
 rewrite !big_ord_recr big_ord0 /= add0r.
@@ -87,9 +87,9 @@ rewrite -!addrA -!scalerDl.
 congr (_ *: _ + _ *: _); ring.
 Qed.
 
-Record edge := Bedge 
+Record edge := Bedge
   { left_pt : Plane R;
-    right_pt : Plane R; 
+    right_pt : Plane R;
     edge_cond : left_pt.1 < right_pt.1}.
 
 Record cell :=
@@ -161,7 +161,7 @@ Qed.
 
 Fail Check (fun (x : vert_edge) (l : seq vert_edge) => x \in l).
 
-Canonical vert_edge_eqType := EqType vert_edge (EqMixin vert_edge_eqP).
+HB.instance Definition _ := hasDecEq.Build _ vert_edge_eqP.
 
 Fixpoint seq_to_intervals_aux [A : Type] (a : A) (s : seq A) :=
 match s with
@@ -177,12 +177,12 @@ 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 (fst p).2 (snd p).2) 
+  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 (fst p).2 (snd p).2) 
+  map (fun p => Build_vert_edge lx (p.1).2 (p.2).2)
    (seq_to_intervals (rev (right_pts c))).
 
 Definition dummy_vert_edge :=
@@ -192,7 +192,7 @@ 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) => 
+Check fun (v : vert_edge)(c : cell) =>
    v \in cell_safe_exits_left c.
 
 Lemma detDM2 (l p1 p2 q1 q2 r1 r2 : R) :
@@ -286,7 +286,7 @@ have vxright : ve_x v = right_limit c.
   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]. 
+  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.
@@ -397,7 +397,7 @@ have vxright : ve_x v = right_limit c.
   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]. 
+  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.
@@ -447,8 +447,8 @@ 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) : 
+
+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.
@@ -466,7 +466,7 @@ rewrite invrN !(mulrN, mulNr).
 rewrite mulfVK //; ring.
 Qed.
 
-Lemma vert_projl (p q r : Plane R) : 
+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.
@@ -498,9 +498,9 @@ 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 * 
+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)).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].
@@ -761,7 +761,7 @@ have [P1 | P2] := ltrP t u.
   have t'int : 0 <= t' < 1.
     apply/andP; split.
       rewrite /t'; apply divr_ge0; lra.
-    rewrite /t' ltr_pdivr_mulr; 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.
@@ -776,7 +776,7 @@ have [P1 | P2] := ltrP t u.
     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 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.
@@ -791,7 +791,7 @@ have [P1 | P2] := ltrP t u.
     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 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.
@@ -836,7 +836,7 @@ have [t1 | tn1] := eqVneq t 1.
 have t'int : 0 < t' < 1.
   rewrite /t'; apply/andP; split.
     apply: divr_gt0; lra.
-  by rewrite ltr_pdivr_mulr; 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'));
@@ -847,7 +847,7 @@ 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 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.
@@ -862,7 +862,7 @@ apply/andP; split.
   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 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.
@@ -904,7 +904,7 @@ Qed.
 
 Definition midpoint (a b : Plane R) := a <| 1/2 |> b.
 
-Definition mkedge_aux (a b : Plane R) : {e : edge | 
+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.
@@ -923,7 +923,7 @@ 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) : 
+  (a b c : Plane R) :
   option bool :=
 match fuel with
 | O => None
@@ -934,7 +934,7 @@ match fuel with
   else if
      point_under_edge top_edge (mkedge a b) ||
      point_under_edge top_edge (mkedge b c)
-  then 
+  then
     Some false
   else
     let b' := midpoint a b in
@@ -1003,7 +1003,7 @@ 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: 
+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 ->
@@ -1030,11 +1030,11 @@ have tmp1 : t ^ 2 * c'.2 * (b.1 - a.1) =
   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.
+rewrite !tmp tmp1 /=.
 ring.
 Qed.
 
-Lemma safe_bezier_ccw_corner_side (a b c : Plane R) (v : vert_edge) 
+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 ->
@@ -1074,9 +1074,10 @@ set p' := (p.1, (left_pt e).2 + (p.1 - (left_pt e).1) /
 have := diff_vert_y ecnd'=> /(_ p p' erefl) /eqP.
 rewrite subr_eq=> /eqP ->; rewrite /p' /=.
 rewrite addrA (addrC _ (left_pt e).2) -!addrA.
-rewrite ler_add2.
-rewrite addrC -ler_subr_addl mulrAC addrN.
-rewrite pmulr_lle0 // invr_gt0; lra.
+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) :
@@ -1128,3 +1129,5 @@ apply: conv_num_ltr=> //.
   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
index f81fe6c..b5dc593 100644
--- a/theories/encompass.v
+++ b/theories/encompass.v
@@ -111,7 +111,7 @@ End spec.
 Module SpecKA (KA : KnuthAxioms).
 Section Dummy.
 Variable R : realType.
-Let plane := pair_vectType (regular_vectType R) (regular_vectType R).
+Let plane : vectType _ := (R^o * R^o)%type.
 
 Let oriented := KA.OT (R:=R).
 Let Ax1 := KA.Axiom1 (R:=R).
diff --git a/theories/events.v b/theories/events.v
new file mode 100644
index 0000000..454b308
--- /dev/null
+++ b/theories/events.v
@@ -0,0 +1,515 @@
+From HB Require Import structures.
+From mathcomp Require Import all_ssreflect all_algebra.
+Require Export Field.
+Require Import math_comp_complements.
+Require Import generic_trajectories points_and_edges.
+
+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.
+
+Section working_environment.
+
+Variable R : realFieldType.
+
+Notation pt := (pt R).
+Notation edge := (edge R).
+Notation p_x := (p_x R).
+Notation p_y := (p_y R).
+
+Notation event := (event R edge).
+Notation point := (point R edge).
+Notation outgoing := (outgoing R edge).
+
+Definition event_eqb (ea eb : event) : bool :=
+  (point ea == point eb :> pt) && (outgoing ea == outgoing eb).
+
+Lemma event_eqP : Equality.axiom event_eqb.
+Proof.
+rewrite /Equality.axiom.
+move => [pta outa] [ptb outb] /=.
+rewrite /event_eqb/=.
+have [/eqP <- | /eqP anb] := boolP (pta == ptb :> pt).
+  have [/eqP <- | /eqP anb] := boolP (outa == outb).
+    by apply: ReflectT.
+  by apply : ReflectF => [][].
+by apply: ReflectF=> [][].
+Qed.
+
+HB.instance Definition _ := hasDecEq.Build _ event_eqP.
+
+Notation Bevent := (Bevent _ _).
+(* As in insertion sort, the add_event function assumes that event are
+  sorted in evs (lexicographically, first coordinate, then second coordinate
+  of the point.  On the other hand, no effort is made to sort the various
+  edges in each list.  *)
+Fixpoint add_event (p : pt) (e : edge) (inc : bool) (evs : seq event) :
+  seq event :=
+  match evs with
+  | nil => if inc then [:: Bevent p [::]]
+           else [:: Bevent p [:: e]]
+  | ev1 :: evs' =>
+    let p1 := point ev1 in
+    if p == p1 then
+      if inc then Bevent p1 (outgoing ev1) :: evs'
+      else Bevent p1 (e :: outgoing ev1) :: evs' else
+    if p_x p < p_x p1 then
+      if inc then
+        Bevent p [::] :: evs else
+        Bevent p [:: e] :: evs
+    else if (p_x p == p_x p1) && (p_y p < p_y p1) then
+       if inc then
+         Bevent p [::] :: evs else
+         Bevent p [:: e] :: evs else
+    ev1 :: add_event p e inc evs'
+  end.
+
+Lemma add_event_step (p : pt) (e : edge) (inc : bool) (evs : seq event) :
+  add_event p e inc evs =
+  match evs with
+  | nil => if inc then [:: Bevent p [::]]
+           else [:: Bevent p [:: e]]
+  | ev1 :: evs' =>
+    let p1 := point ev1 in
+    if p == p1 then
+      if inc then Bevent p1 (outgoing ev1) :: evs'
+      else Bevent p1 (e :: outgoing ev1) :: evs' else
+    if p_x p < p_x p1 then
+      if inc then
+        Bevent p [::] :: evs else
+        Bevent p [:: e] :: evs
+    else if (p_x p == p_x p1) && (p_y p < p_y p1) then
+       if inc then
+         Bevent p [::] :: evs else
+         Bevent p [:: e] :: evs else
+    ev1 :: add_event p e inc evs'
+  end.
+Proof. by case: evs. Qed.
+
+(* We should be able to prove that the sequence of events produced by
+  edges to events is sorted lexicographically on the coordinates of
+  the points. *)
+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.
+
+Section proof_environment.
+Variable bottom top : edge.
+
+Definition lexPtEv (e1 e2 : event) : bool :=
+  lexPt (point e1) (point e2).
+
+Definition lexePtEv (e1 e2 : event) : bool :=
+  lexePt (point e1) (point e2).
+
+Definition event_close_edge ed ev : bool :=
+right_pt ed == point ev.
+
+Definition end_edge edge events : bool :=
+  has (event_close_edge edge) events.
+
+Definition close_out_from_event ev future : bool :=
+  all (fun edge => end_edge edge future) (outgoing ev).
+
+Fixpoint close_edges_from_events events : bool :=
+  match events with
+  | [::] => true
+  | ev :: future_events => close_out_from_event ev future_events && close_edges_from_events future_events
+  end.
+
+Lemma close_edges_from_events_step events :
+  close_edges_from_events events = match events with
+  | [::] => true
+  | ev :: future_events => close_out_from_event ev future_events && close_edges_from_events future_events
+  end.
+Proof. by case: events. Qed.
+
+Lemma lexPtEv_trans : transitive lexPtEv.
+Proof. by move=> e2 e1 e3; rewrite /lexPtEv; apply: lexPt_trans. Qed.
+
+Lemma lexePtEv_trans : transitive lexePtEv.
+Proof. by move=> e1 e2 e3; rewrite /lexePtEv; apply: lexePt_trans. Qed.
+
+Lemma event_close_edge_on g e:
+  event_close_edge g e -> (point e) === g.
+Proof.  by move=> /eqP <-; apply: right_on_edge. Qed.
+
+Definition out_left_event ev :=
+  {in outgoing ev, forall e, left_pt e == point(ev)}.
+
+Lemma outleft_event_sort e :
+  out_left_event e ->
+  forall ed, ed \in sort (@edge_below R) (outgoing e) -> left_pt ed == point e.
+Proof.
+move=> outleft ed edin; apply: outleft.
+by have <- := perm_mem (permEl (perm_sort (@edge_below _) (outgoing e))).
+Qed.
+
+Lemma close_out_from_event_sort event future :
+  close_out_from_event event future ->
+  all (end_edge^~ future) (sort (@edge_below R) (outgoing event)).
+Proof.
+move/allP=> outP; apply/allP=> x xin; apply outP.
+by have <- := perm_mem (permEl (perm_sort (@edge_below R) (outgoing event))).
+Qed.
+
+Definition events_to_edges := flatten \o (map outgoing).
+
+Lemma events_to_edges_cons e evs :
+  events_to_edges (e :: evs) = outgoing e ++ events_to_edges evs.
+Proof. by []. Qed.
+
+Lemma out_left_event_on e :
+  out_left_event e -> {in outgoing e, forall g, point e === g}.
+Proof.
+move=> outs g gin; rewrite -(eqP (outs _ gin)); apply: left_on_edge.
+Qed.
+
+Lemma sort_edge_below_sorted s :
+  {in s &, @no_crossing _} ->
+  sorted (@edge_below R) (sort (@edge_below R) s).
+Proof.
+move=> noc.
+have /sort_sorted_in : {in s &, total (@edge_below _)}.
+  by move=> x1 x2 x1in x2in; apply/orP/noc.
+by apply; apply: allss.
+Qed.
+
+Lemma sorted_outgoing le he e : 
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  point e >>> le ->
+  point e <<< he ->
+  out_left_event e ->
+  {in le :: he :: outgoing e &, no_crossing R} ->
+  sorted (@edge_below R) (le :: sort (@edge_below R) (outgoing e)).
+Proof.
+ set ctxt := (le :: he :: _); move=> vl hl above under outs noc.
+have lein : le \in ctxt by rewrite /ctxt inE eqxx.
+have hein : he \in ctxt by rewrite /ctxt !inE eqxx ?orbT.
+have osub : {subset outgoing e <= ctxt}.
+  by move=> g gin; rewrite /ctxt !inE gin ?orbT.
+have [ls us noc''] :=
+   outgoing_conditions above under lein hein vl hl osub noc outs.
+have /sort_sorted_in tmp : {in le :: outgoing e &, total (@edge_below R)}.
+  move=> e1 e2; rewrite !inE =>/orP[/eqP -> |e1in ]/orP[/eqP -> |e2in].
+  - by rewrite edge_below_refl.
+  - by rewrite ls.
+  - by rewrite ls ?orbT.
+  by apply/orP/noc''.
+rewrite /=; case oeq : (sort (@edge_below R) (outgoing e)) => [// | g1 gs] /=.
+rewrite ls; last first.
+  have <- := perm_mem (permEl (perm_sort (@edge_below R) (outgoing e))).
+  by rewrite oeq inE eqxx.
+rewrite -[X in is_true X]/(sorted _ (g1 :: gs)) -oeq tmp //.
+by apply/allP=> x xin /=; apply/orP; right; exact: xin.
+Qed.
+
+Definition events_non_inner (evs : seq event) :=
+  {in evs &,
+    forall ev1 ev2,
+    {in outgoing ev1, forall g, non_inner g (point ev2)}}.
+
+Lemma add_event_preserve_first p e inc ev evs :
+  (0 < size (add_event p e inc (ev :: evs)))%N /\
+  (point (head ev (add_event p e inc (ev :: evs))) = p \/
+   point (head ev (add_event p e inc (ev :: evs))) = point ev).
+Proof.
+rewrite /=.
+case: ev => [p1 o1].
+have [/eqP -> | /eqP pnp1] := boolP(p == p1).
+  by split; case: inc => //=; left.
+have [pltp1 /= | pnltp1] := boolP(p_x p < p_x p1).
+  split.
+    by case: inc.
+  by case:inc; left.
+have [/eqP pxqpx1 /= | pxnpx1 /=] := boolP (p_x p == p_x p1).
+  have [/eqP pyltpy1 /= | pynltpy1 /=] := boolP (p_y p < p_y p1).
+    by case:inc; (split;[ | left]).
+  by split;[ | right].
+by split;[ | right].
+Qed.
+
+Lemma add_event_sort p e inc evs : sorted lexPtEv evs ->
+  sorted lexPtEv (add_event p e inc evs).
+Proof.
+elim: evs => [ | ev1 evs Ih /=].
+  by case: inc.
+move=> path_evs.
+have [/eqP pp1 | /eqP pnp1] := boolP(p == point ev1).
+  case: inc Ih.
+    by case: evs path_evs => [ | ev2 evs'].
+  by case: evs path_evs => [ | ev2 evs'].
+move/path_sorted/Ih: (path_evs) {Ih} => Ih.
+have [ pltp1 | pnltp1] /= := boolP(p_x p < p_x (point ev1)).
+  by case: inc {Ih}=> /=; (apply/andP; split=> //); rewrite /lexPtEv /lexPt /= pltp1.
+have [/eqP pp1 | pnp1'] /= := boolP (p_x p == p_x (point ev1)).
+  have pyneq : p_y p != p_y (point ev1).
+    apply/eqP=> pp1'; case pnp1.
+    move: p (point ev1) {pnp1 Ih pnltp1} pp1 pp1'.
+    by move=> [a b][c d] /= -> ->.
+  have [ pltp1 | pnltp1'] /= := boolP(p_y p < p_y (point ev1)).
+    by case: (inc); rewrite /= path_evs andbT /lexPtEv /lexPt /= pp1 eqxx pltp1 orbT.
+  have p1ltp : p_y (point ev1) < p_y p.
+    by rewrite ltNge le_eqVlt negb_or pyneq pnltp1'.
+  case evseq : evs => [ | [p2 o2] evs2].
+    by case: (inc)=> /=; rewrite /lexPtEv /lexPt /= pp1 eqxx p1ltp orbT.
+  rewrite -evseq.
+  case aeq : (add_event p e inc evs) => [ | e' evs3].
+    have := add_event_preserve_first p e inc
+           (Bevent p2 o2) evs2.
+      by rewrite -evseq aeq => [[]].
+  case: (add_event_preserve_first p e inc
+          (Bevent p2 o2) evs2)=> _.
+  rewrite -evseq aeq /= => [] [eqp | eqp2].
+    apply/andP; split; last by move: Ih; rewrite aeq.
+    by rewrite /lexPtEv /lexPt eqp pp1 eqxx p1ltp orbT.
+  apply/andP; split; last by move: Ih; rewrite aeq.
+  move: path_evs; rewrite evseq /= andbC => /andP[] _.
+  by rewrite /lexPtEv /= eqp2.
+have p1ltp : p_x (point ev1) < p_x p.
+  by rewrite ltNge le_eqVlt negb_or pnp1' pnltp1.
+case evseq : evs => [ | [p2 o2] evs2].
+  by case: (inc)=> /=; rewrite /lexPtEv /lexPt /= p1ltp.
+case aeq : (add_event p e inc evs) => [ | e' evs3].
+  case: (add_event_preserve_first p e inc
+       (Bevent p2 o2) evs2).
+  by rewrite -evseq aeq.
+case: (add_event_preserve_first p e inc
+     (Bevent p2 o2) evs2) => _.
+have path_e'evs3 : path lexPtEv e' evs3 by move: Ih; rewrite aeq.
+rewrite -evseq aeq /= => [][e'p | e'p2]; rewrite path_e'evs3 andbT.
+  by rewrite /lexPtEv /lexPt e'p p1ltp.
+by move: path_evs; rewrite evseq /= andbC /lexPtEv e'p2=> /andP[].
+Qed.
+
+Lemma sorted_edges_to_events s :
+   sorted (@lexPt R) [seq point x | x <- edges_to_events s].
+Proof.
+have /mono_sorted -> : {mono point : x y / lexPtEv x y >-> lexPt x y} by [].
+by elim: s => [ | g s Ih] //=; do 2 apply: add_event_sort.
+Qed.
+
+End proof_environment.
+
+Lemma add_event_preserve_ends p e inc evs ed :
+  end_edge ed evs ->
+  end_edge ed (add_event p e inc evs).
+Proof.
+rewrite /end_edge /=.
+elim: evs => [// | ev evs Ih] /= /orP[|];
+  repeat (case: ifP => _);
+   rewrite /=/event_close_edge /=; try (move=> -> //); rewrite ?orbT //.
+by move=> ?; rewrite Ih ?orbT.
+Qed.
+
+Lemma add_event_inc evs ed :
+  end_edge ed (add_event (right_pt ed) ed true evs).
+Proof.
+elim: evs => [ | ev evs Ih] /=.
+  by rewrite /end_edge /event_close_edge eqxx.
+case: ifP=> [/eqP <- | ].
+  by rewrite /end_edge /= /event_close_edge /= eqxx.
+repeat (case: ifP=> _); rewrite /end_edge/=/event_close_edge ?eqxx //.
+move=> _; move: Ih; rewrite /end_edge/=/event_close_edge => ->.
+by rewrite !orbT.
+Qed.
+
+Lemma close_edges_from_events_inc evs p ed :
+ close_edges_from_events evs ->
+ close_edges_from_events (add_event p ed true evs).
+Proof.
+elim: evs => /= [ // | ev evs Ih /andP [clev clevs]].
+move: Ih=> /(_ clevs) Ih.
+case: ifP=> _ /=; first by rewrite clevs andbT; exact clev.
+case: ifP=> _ /=; first by rewrite clevs andbT; exact clev.
+case: ifP=> _ /=; first by rewrite clevs andbT; exact clev.
+rewrite Ih andbT.
+apply/allP=> ed' edin'.
+move: (allP clev ed' edin').
+by move=> it; rewrite add_event_preserve_ends // /end_edge it.
+Qed.
+
+Lemma add_edge_close_edges_from_events evs ed :
+  close_edges_from_events evs ->
+  close_edges_from_events
+    (add_event (left_pt ed) ed false (add_event (right_pt ed) ed true evs)).
+Proof.
+have no_eq : left_pt ed == right_pt ed = false.
+    by apply/negP=> /eqP abs_eq; have := edge_cond ed; rewrite abs_eq ltxx.
+elim: evs => [/= _ | ev evs Ih].
+  rewrite no_eq edge_cond /=.
+  by rewrite /close_out_from_event /= /end_edge/=/event_close_edge eqxx.
+move=> tmp; rewrite /= in tmp; case/andP: tmp=> [clev clevs].
+move: Ih=> /(_ clevs) Ih.
+have : end_edge ed (add_event (right_pt ed) ed true (ev :: evs)).
+  by apply: add_event_inc.
+rewrite [add_event (right_pt _) _ _ _]add_event_step.
+lazy zeta.
+case: ifP=> [/eqP <- /= | cnd1].
+  rewrite no_eq edge_cond /=.
+  rewrite /close_out_from_event /= /end_edge/=/event_close_edge.
+  rewrite eqxx /= clevs andbT=> _; exact: clev.
+case: ifP=> cnd2 /=.
+  rewrite no_eq edge_cond /=.
+  rewrite /close_out_from_event /= => -> /=; rewrite clevs andbT; exact: clev.
+case: ifP=> cnd3 ended /=.
+  rewrite no_eq edge_cond.
+  rewrite close_edges_from_events_step.
+  apply/andP; split; last by rewrite /= clev clevs.
+  by move: ended; rewrite /= /close_out_from_event /= andbT.
+case: ifP=> cnd4.
+  rewrite close_edges_from_events_step /close_out_from_event/=.
+  rewrite close_edges_from_events_inc ?andbT ?clevs //.
+  apply/andP; split; last first.
+    apply/allP=> x xin.
+    move/allP: clev=> /(_ x xin) closed.
+    by rewrite add_event_preserve_ends ?orbT.
+  by rewrite add_event_inc.
+case: ifP=> cnd5.
+  rewrite close_edges_from_events_step; apply/andP; split.
+    by move: ended; rewrite /= /close_out_from_event /= andbT.
+  rewrite close_edges_from_events_step; apply/andP; split.
+    apply/allP=> x xin; apply: add_event_preserve_ends.
+    by move/allP: clev=> /(_ x xin).
+  by apply: close_edges_from_events_inc.
+case: ifP=> cnd6.
+  rewrite close_edges_from_events_step; apply/andP; split.
+    by move: ended; rewrite /close_out_from_event /= andbT.
+  rewrite close_edges_from_events_step; apply/andP; split.
+    apply/allP=> x xin; apply: add_event_preserve_ends.
+    by move/allP: clev=> /(_ x xin).
+  by apply: close_edges_from_events_inc.
+rewrite close_edges_from_events_step; apply/andP; split.
+  rewrite /close_out_from_event.
+  apply/allP=> x xin.
+  do 2 apply:add_event_preserve_ends.
+  by move/allP: clev; apply.
+by apply: Ih.
+Qed.
+
+Lemma edges_to_events_wf (bottom top : edge)(s : seq edge) :
+  close_edges_from_events (edges_to_events s).
+Proof.
+elim : s => [ // | e s Ih /=].
+by apply: add_edge_close_edges_from_events.
+Qed.
+
+Lemma edges_to_events_no_loss (s : seq edge) :
+  perm_eq s (events_to_edges (edges_to_events s)).
+Proof.
+have add_inc evs p ed:
+  perm_eq (events_to_edges evs)
+    (events_to_edges (add_event p ed true evs)).
+  elim: evs => [/= | ev evs Ih]; first by apply: perm_refl.
+  rewrite /events_to_edges /=.
+  by repeat (case: ifP=> _ //=); rewrite perm_cat2l Ih.
+have add_out evs p ed:
+  perm_eq (ed :: events_to_edges evs)
+     (events_to_edges (add_event p ed false evs)).
+  elim: evs => [/= | ev evs]; first by apply: perm_refl.
+  rewrite /events_to_edges /= => Ih.
+  repeat (case: ifP => //=); move => ? ? ?.
+  rewrite -[ed :: outgoing ev ++ _]/([:: ed] ++ outgoing ev ++ _).
+  by rewrite perm_catCA perm_cat2l Ih.
+elim: s => /= [// | ed s Ih]; rewrite -(perm_cons ed) in Ih.
+apply/(perm_trans Ih)/(perm_trans _ (add_out _ (left_pt ed) _)).
+by rewrite perm_cons; apply: add_inc.
+Qed.
+
+Lemma edges_to_events_no_crossing s :
+  {in s &, no_crossing R} ->
+  {in events_to_edges (edges_to_events s) &, no_crossing R}.
+Proof.
+by apply: sub_in2=> x; rewrite (perm_mem (edges_to_events_no_loss s)).
+Qed.
+
+Lemma out_left_add_event p g b evs:
+    p = (if b then right_pt g else left_pt g) ->
+    {in evs, forall ev, out_left_event ev} ->
+    {in add_event p g b evs, forall ev, out_left_event ev}.
+Proof.
+move=> ->.
+elim: evs => [ | ev evs Ih] acc.
+  move=> /= ev; case:b; rewrite inE => /eqP -> e //=.
+  by rewrite inE => /eqP ->; rewrite eqxx.
+rewrite /=; case: ifP=> [/eqP pev | ] ev'.
+  case bval: (b); rewrite /= inE => /orP[/eqP ev'ev | ev'inevs].
+  - have -> : ev' = ev by rewrite ev'ev; case: (ev).
+    by apply: acc; rewrite inE eqxx.
+  - by apply: acc; rewrite inE ev'inevs orbT.
+  - move=> g2; rewrite ev'ev /= inE=> /orP[/eqP -> | ].
+    * by rewrite -pev bval eqxx.
+    by apply: acc; rewrite inE eqxx.
+  by apply: acc; rewrite inE ev'inevs orbT.
+case: ifP => [athead | later].
+  case bval: (b) => ev2; rewrite inE => /orP[].
+  - by move/eqP=> -> g2.
+  - by apply: acc.
+  - by move/eqP=> -> g2 /=; rewrite inE=> /eqP ->; rewrite eqxx.
+  by apply: acc.
+case: ifP => [athead' | later'].
+  case bval: (b) => ev2; rewrite inE => /orP[].
+  - by move/eqP=> -> g2.
+  - by apply: acc.
+  - by move/eqP=> -> g2 /=; rewrite inE=> /eqP ->; rewrite eqxx.
+  by apply: acc.
+move=> ev2; rewrite inE=> /orP[/eqP -> | ev2intl].
+  by apply: acc; rewrite inE eqxx.
+apply: Ih=> //.
+by move=> ev3 ev3in; apply: acc; rewrite inE ev3in orbT.
+Qed.
+
+Lemma out_left_edges_to_events s:
+  {in edges_to_events s, forall ev, out_left_event ev}.
+Proof.
+elim: s => [// | g s Ih] /=.
+have Ih' := @out_left_add_event (right_pt g) g true _ erefl Ih.
+by have Ih'' := @out_left_add_event (left_pt g) g false _ erefl Ih'.
+Qed.
+
+Lemma add_event_point_subset (s : mem_pred pt) p g b evs :
+  {subset ([seq point ev | ev <- evs] : seq pt) <= s} ->
+  p \in s ->
+  {subset ([seq point ev | ev <- add_event p g b evs] : seq pt) <= s}.
+Proof.
+elim: evs => [ | ev evs Ih].
+  by move=> _ pin /=; case: ifP => /= bval p'; rewrite inE=> /eqP ->.
+move=> cnd pin.
+  have cnd' : {subset ([seq point ev' | ev' <- evs] : seq pt) <= s}.
+  by move=> p' p'in; apply: cnd; rewrite inE p'in orbT.
+have Ih' := Ih cnd' pin; clear Ih.
+have evin : point ev \in s by apply: cnd; rewrite !inE eqxx.
+rewrite /=; (repeat (case: ifP=> _))=> p'; rewrite /= !inE;
+  (repeat(move=>/orP[])); try solve[move=> /eqP -> // | by apply: cnd'].
+apply: Ih'.
+Qed.
+
+Lemma edges_to_events_subset (s : mem_pred pt) (gs : seq edge) :
+  {subset [seq left_pt g | g <- gs] <= s} ->
+  {subset [seq right_pt g | g <- gs] <= s} ->
+  {subset ([seq point ev | ev <- edges_to_events gs] : seq pt) <= s}.
+Proof.
+elim: gs => [// | g gs Ih].
+rewrite /=.
+move=> cndl cndr.
+have cndl' : {subset [seq left_pt g | g <- gs] <= s}.
+  by move=> x xin; apply: cndl; rewrite inE xin orbT.
+have cndr' : {subset [seq right_pt g | g <- gs] <= s}.
+  by move=> x xin; apply: cndr; rewrite inE xin orbT.
+have cndleft : left_pt g \in s by apply: cndl; rewrite inE eqxx.
+have cndright : right_pt g \in s by apply: cndr; rewrite inE eqxx.
+have Ih' := Ih cndl' cndr'; clear Ih.
+by apply: add_event_point_subset;[apply: add_event_point_subset | ].
+Qed.
+
+End working_environment.
diff --git a/theories/extraction_command.v b/theories/extraction_command.v
index ab2c479..5c0ee72 100644
--- a/theories/extraction_command.v
+++ b/theories/extraction_command.v
@@ -1,4 +1,4 @@
-From trajectories Require Import smooth_trajectories.
+From trajectories Require Import generic_trajectories smooth_trajectories.
 Require Import QArith.
 
 Extraction "smooth_trajectories" smooth_point_to_point example_bottom example_top
diff --git a/theories/generic_trajectories.v b/theories/generic_trajectories.v
index 30e997d..8ea815c 100644
--- a/theories/generic_trajectories.v
+++ b/theories/generic_trajectories.v
@@ -1,5 +1,6 @@
 From mathcomp Require Import all_ssreflect.
-Require Import ZArith List String OrderedType OrderedTypeEx FMapAVL.
+Require Import ZArith (* List *) String OrderedType OrderedTypeEx FMapAVL.
+Require Import shortest_path.
 
 Notation head := seq.head.
 Notation sort := path.sort.
@@ -31,8 +32,6 @@ Notation sort := path.sort.
 
 Notation seq := list.
 
-Module natmap := FMapAVL.Make Nat_as_OT.
-
 Section generic_implementation.
 
 (* In the original development R has type numFieldType and the various
@@ -52,6 +51,10 @@ 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.
@@ -79,7 +82,7 @@ Definition dummy_pt := ({| p_x := R1; p_y := R1|}).
 
 Definition dummy_edge := Bedge dummy_pt dummy_pt.
 
-Definition dummy_cell := 
+Definition dummy_cell :=
   {| left_pts := nil; right_pts := nil; low := dummy_edge; high := dummy_edge|}.
 
 Definition dummy_event :=
@@ -146,11 +149,11 @@ Definition valid_edge e p := (R_leb (p_x (left_pt e)) (p_x p)) &&
 (* TODO: check again the mathematical formula after replacing the infix     *)
 (* operations by prefix function calls. *)
 Definition vertical_intersection_point (p : pt) (e : edge) : option pt :=
-  if valid_edge e p then 
+  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))))) 
+    (R_sub (p_x (right_pt e)) (p_x (left_pt e)))))
      (p_y (left_pt e))))
     else None.
 
@@ -190,9 +193,9 @@ 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 (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 (left_pt e2) e1) &&
    negb (point_strictly_under_edge (right_pt e2) e1)).
 
 Definition contains_point (p : pt) (c : cell)  : bool :=
@@ -202,8 +205,8 @@ Definition close_cell (p : pt) (c : cell) :=
   match vertical_intersection_point p (low c),
         vertical_intersection_point p (high c) with
   | None, _ | _, None => c
-  | Some p1, Some p2 => 
-    Bcell (left_pts c) (no_dup_seq (p1 :: p :: p2 :: nil)) (low c) (high 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 :=
@@ -215,7 +218,7 @@ Definition pvert_y (p : pt) (e : edge) :=
   | None => R0
   end.
 
-Fixpoint opening_cells_aux (p : pt) (out : seq edge) (low_e high_e : edge) 
+Fixpoint opening_cells_aux (p : pt) (out : seq edge) (low_e high_e : edge)
   : seq cell * cell :=
   match out with
   | [::] =>
@@ -249,7 +252,7 @@ if open_cells is c :: q then
 else
   None.
 
-Fixpoint open_cells_decomposition_rec open_cells pt : 
+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
@@ -279,9 +282,7 @@ Record scan_state :=
 
 Definition update_closed_cell (c : cell) (p : pt) : cell :=
   let ptseq := right_pts c in
-  let newptseq :=
-    (belast (head dummy_pt ptseq) (behead ptseq)) ++
-    [:: p; seq.last dummy_pt ptseq] 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) :=
@@ -337,7 +338,7 @@ 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, 
+     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
@@ -349,7 +350,7 @@ Definition step (st : scan_state) (e : event) : scan_state :=
      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 
+   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
@@ -427,79 +428,8 @@ Definition edges_to_cells bottom top edges :=
   complete_process (edges_to_events edges) bottom top.
 
 (* SECOND PART : computing a path in the cell graph *)
-(* This code is taken from github.com/ybertot/breadth_first_search.
-   the proof of this code is probably complete in that repository. *)
-
-Section bfs.
-
-Variable (state move : Type).
-Variable (state_fmap : Type).
-Variable find : state_fmap -> state -> option move.
-Variable add : state_fmap -> state -> move -> state_fmap.
-Variable (step : state -> list (state * move)).
-Variable (state_eq_dec : forall s1 s2 : state, {s1 = s2}+{s1 <> s2}).
-
-Variable map_order : state_fmap -> state_fmap -> Prop.
-Hypothesis map_order_wf : well_founded map_order.
-Hypothesis add_order : forall map s v,
-  find map s = None -> map_order (add map s v) map.
-Hypothesis map_order_trans : forall map2 map1 map3,
-  map_order map1 map2 -> map_order map2 map3 -> map_order map1 map3.
-
-Fixpoint bfs_aux (w w2 : list (state * move))
-  (sufficient : state)
-  (settled : state_fmap) : (list (state * move) * state_fmap) :=
-match w with
-| (s, m) :: w' =>
-  match find settled s with
-  | Some _ => bfs_aux w' w2 sufficient settled
-  | None =>
-    if state_eq_dec s sufficient then
-      (nil, add settled s m)
-    else
-    bfs_aux w' (step s ++ w2) sufficient (add settled s m)
-  end
-| nil => (w2, settled)
-end.
-
-Fixpoint bfs (fuel : nat) (w : list (state * move)) (settled : state_fmap) 
-  (sufficient : state)
-  (round : nat) :
-  (state_fmap * nat) + (list (state * move) * state_fmap) :=
-  match fuel with
-  | O => inr (w, settled)
-  | S p =>
-    match bfs_aux w nil sufficient settled with
-    | (nil, s) => inl (s, round)
-    | (w, s) => bfs p w s sufficient (round + 1)
-    end
-  end.
-
-  (* We then explain how we build a path using the database. *)
-Fixpoint make_path (db : state_fmap)
-(targetb : state -> bool) (play : state -> move -> option state)
-(x : state) (fuel : nat) :=
-match fuel with
-| O => None
-| S p =>
-if targetb x then
-  Some nil
-else
-  match find db x with
-  | None => None
-  | Some m =>
-    match play x m with
-    | Some y =>
-      match make_path db targetb play y p with
-      | None => None
-      | Some l => Some (m :: l)
-      end
-   | None => None
-   end
-  end
-end.
-
-End bfs.
+(* 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
@@ -513,6 +443,9 @@ Definition vert_edge_eqb (v1 v2 : vert_edge) :=
   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
@@ -528,108 +461,223 @@ 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))) 
+  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 (rev (right_pts c))).
-
-Definition all_doors (cells : seq cell) : seq (vert_edge * nat) :=
-  List.concat
-    (List.map (fun i => List.map (fun v => (v, i))
-                  (cell_safe_exits_right (nth i cells dummy_cell)))
-         (seq.iota 0 (List.length cells))).
+  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 door_right_cell (cells : seq cell) (v : vert_edge) :=
-  find (fun i => existsb (fun v' => vert_edge_eqb v v')
-           (cell_safe_exits_left (nth i cells dummy_cell)))
-     (seq.iota 0 (List.length 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.
+
+Definition left_limit (c : cell) := p_x (seq.head dummy_pt (left_pts c)).
 
-(* connection from left to right is obtained by computing an intersection. *)
-Definition lr_connected (c1 c2 : cell) : bool :=
-  existsb (fun v => existsb (fun v' => vert_edge_eqb v v')
-                       (cell_safe_exits_left c2))
-       (cell_safe_exits_right c1).
+Definition right_limit c := p_x (seq.head dummy_pt (right_pts c)).
 
-Definition bi_connected c1 c2 :=
-  lr_connected c1 c2 || lr_connected c2 c1.
+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))).
+
+(* 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 bfs_find : natmap.t nat -> nat -> option nat :=
-  (fun m k => natmap.find k m).
-
-Definition bfs_add : natmap.t nat -> nat -> nat -> natmap.t nat :=
-  (fun m k v => natmap.add k v m).
-
-Definition reverse_step cells cell_i : seq (nat * nat) :=
-  map (fun i => (i, cell_i))
-    (filter (fun c_i => bi_connected (nth c_i cells dummy_cell)
-                       (nth cell_i cells dummy_cell))
-     (seq.iota 0 (List.length cells))).
-
-(* To compute a path between two cells we use as input the list of cells
-   and indices of two cells in this list (source and target).  This builds
-   a table.  This table construction is interrupted as soon as a path
-   from source_i to target_i is found, and this path is guaranteed to be
-   of minimal length in terms of numbers of cells encountered. The result
-   is in a sum type, where only the right variant would mean that no path
-   has been found before exhaustion of some fuel.  But here, it is assumed
-   that the fuel (length of cells) is going to be enough to find all cells
-   connected to target_i. *)
-Definition cell_connection_table (cells : seq cell) (source_i target_i : nat) :=
-    bfs _ _ _ bfs_find bfs_add (reverse_step cells) eq_nat_dec
-    (List.length cells) ((target_i, target_i) :: nil) (natmap.empty nat)
-    source_i 0.
-
-Definition cell_path (cells : seq cell) (source_i target_i : nat) :
-  option (seq nat) :=
-  match cell_connection_table cells source_i target_i with
-  | inr _ => None
-  | inl (table, _) =>
-    make_path _ _ _ bfs_find table (fun c_i => Nat.eqb c_i target_i)
-      (fun n1 n2 => Some n2) source_i (List.length cells)
+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.
 
-(* Given two cells, we define the door from one cell to the other to
-  be the common edge between these cells.  In example known so far, there
-  is only one such door, but this may change in the future.  For now, we
-  take arbitrarily the first one we find (the top one or the bottom one
-  depending on the exits are ordered).  If the two cells are not adjacent,
-  dummy_vert_edge is returned.  Maybe this should be made safer by returning
-  an option type. *)
-Definition lr_door (c1 c2 : cell) : vert_edge :=
-  head dummy_vert_edge
-     (filter (fun x => existsb (fun x' => vert_edge_eqb x x')
-                  (cell_safe_exits_left c2)) (cell_safe_exits_right c1)).
-
-Definition left_limit (c : cell) := p_x (seq.last dummy_pt (left_pts c)).
-
-Definition right_limit c := p_x (seq.last dummy_pt (right_pts c)).
-
-(* This function is like lr_door, but it is more precise, as it
-  can be applied when the doors are connected but not lr_connected as it
-  returns None in case the two given cells are not adjacent. *)
-Definition common_vert_edge (c1 c2 : cell) : option vert_edge:=
-  if R_eqb (right_limit c1) (left_limit c2) then
-    find (fun v => existsb (fun v' => vert_edge_eqb v v')
-                      (cell_safe_exits_left c2))
-      (cell_safe_exits_right c1)
-  else
-    find (fun v => existsb (fun v' => vert_edge_eqb v v')
-                      (cell_safe_exits_left c1))
-      (cell_safe_exits_right c2).
+(* 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).
 
 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)) 
@@ -637,209 +685,166 @@ Definition cell_center (c : cell) :=
     (midpoint (head dummy_pt (left_pts c))
               (seq.last dummy_pt (right_pts c))).
 
+(* 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; cell_indices : seq nat}.
+  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).
 
-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).
 
-(* This function assumes a straight line to the door is safe.  For annotations
-  it supposes the first cell index corresponds to the cell containing p.
-  It returns nil if there is no door, and nil or a faulty edge if
-  the other conditions are not met. *)
-Definition point_to_door (cells : seq cell) (p : annotated_point) (c1i c2i : nat) :
-   seq (annotated_point * annotated_point) :=
-let c1 := nth c1i cells dummy_cell in
-let c2 := nth c2i cells dummy_cell in
-match common_vert_edge c1 c2 with
-  Some v =>
-    if (R_eqb (p_x (apt_val p)) (ve_x v)) && negb (on_vert_edge (apt_val p) v) then
-      (p, Apt (cell_center c1) (c1i::nil)) ::
-      (Apt (cell_center c1) (c1i :: nil), Apt (vert_edge_midpoint v) (c1i :: c2i :: nil)) :: 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, Apt (vert_edge_midpoint v) (c1i :: c2i :: nil)) :: nil
-| None => nil
-end.
+       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).
 
-(* This function creates a safe path from the door between
-  c1 and c2 and the door between c2 and c3.  When op1 and op2
-  are not provided, midpoints are used as path anchors,
-  when p1 and p2 are provided they are used instead.
-  This function assumes that p1 and p2 are members of the
-  respective doors (c1-c2) and (c2-c3) *)
-Definition to_next_door (op1 op2 : option pt)
-  (cells : seq cell)
-  (c1i c2i c3i : nat) : seq (annotated_point * annotated_point) :=
-let c2 := nth c2i cells dummy_cell in
-let p1 := match op1 with
-          | Some p1 => p1
-          | None =>
-            match common_vert_edge (nth c1i cells dummy_cell) c2 with
-            | Some v => vert_edge_midpoint v
-            | None => dummy_pt
-            end
-          end in
-let p2 := match op2 with
-          | Some p2 => p2
-          | None =>
-            match common_vert_edge c2 (nth c3i cells dummy_cell) with
-            | Some v => vert_edge_midpoint v
-            | None => dummy_pt
-            end
-          end in
-if R_eqb (p_x p1) (p_x p2) then
-  let intermediate_point :=
-    Apt (cell_center c2) (c2i :: nil) in
-  (Apt p1 (c1i :: c2i :: nil), intermediate_point) ::
-  (intermediate_point, Apt p2 (c2i :: c3i :: nil)) :: nil
-else
-  (Apt p1 (c1i :: c2i :: nil), Apt p2 (c2i :: c3i :: nil)) :: nil.
-
-(* Given a sequence of cells c_i, and a sequence of indices i1, i2, ... 
-   (where the ... are refered to as tl), we want to create a list of
-   points, making it possible to move from door to door so that the all
-   all list of points is describes a broken line moving from the door
-   between i1 and i2 to the door between the last two elements of
-   (i1, i2, & tl).  Adding paths to the first and last doors will make it
-   easy to have a path from any point in cell i1 to any point in the last
-   cell of (i1, i2, & tl). when optional points are provided, they
-   are points in the first and last door. *)
-Fixpoint door_to_door (cells : seq cell)
-  (i1 i2 : nat) (opt_source opt_target : option pt)(tl : seq nat) :
-  seq (annotated_point * annotated_point) :=
-  match tl with
-  | nil => nil
-  | i3 :: nil =>
-    to_next_door opt_source opt_target cells i1 i2 i3
-  | i3 :: tl' =>
-    let tail_path := door_to_door cells i2 i3 None opt_target tl' in
-    to_next_door opt_source None cells i1 i2 i3 ++ tail_path
-  end.
-
-(* This function computes a path (broken line) between a point
-  in a cell and a point in another cell, going through the midpoint of
-  the door between the two cells.  the points are annotated with the
-  constraint they have to satisfied: the cells of which they have to
-  be members of. This annotation is important because smoothing will
-  replace these points with other points that have to satisfy the same
-  constraint. *)
-Definition path_adjacent_cells (cells : seq cell) (source target : pt)
-  (source_i target_i : nat) : option (seq (annotated_point * annotated_point)) :=
-  let source_cell := nth source_i cells dummy_cell in
-  let target_cell := nth target_i cells dummy_cell in
-  match common_vert_edge source_cell target_cell with
-  | Some v => 
-    Some ((Apt source (source_i :: nil), 
-           Apt (vert_edge_midpoint v) (source_i :: target_i :: nil)) ::
-              (Apt (vert_edge_midpoint v) (source_i :: target_i :: nil),
-               Apt target (target_i :: nil)) :: nil)
-  | None => None
-  end.
-
-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))).
-
-(* find_origin_cells returns a list of cell indices. *)
-(* If the list is empty, it should mean that the point is not in the
-  safe part of the work space (it is either outside the box or on
-  one of the obstacle edges).  If the list has only one element,
-  the point is inside the indexed cell.  If the list has two
-  elements, this means that the point is in the door between the
-  two indexed cells. *)
-Definition find_origin_cells (cells : seq cell) (p : pt) : seq nat :=
-  match find (fun i => strict_inside_closed p (nth i cells dummy_cell))
-         (seq.iota 0 (List.length cells)) with
-  | Some n => n :: nil
-  | None =>
-    head nil
-    (List.map (fun av => snd av ::
-                match door_right_cell cells (fst av) with
-                | Some rc => rc :: nil
-                | None => nil
-                end)
-      (filter (fun av => on_vert_edge p (fst av)) (all_doors cells)))
-  end.
-
-Definition intersection (s1 s2 : seq nat) :=
-  filter (fun e => existsb (fun e' => Nat.eqb e e')
-                      s2) s1.
-
-Definition point_to_point
- (cells : seq cell) (source target : pt) :
-  option (seq (annotated_point * annotated_point)) :=
-let source_is := find_origin_cells cells source in
-let target_is := find_origin_cells cells target in
-if Nat.ltb 0 (List.length source_is) && Nat.ltb 0 (List.length target_is) then
-  if Nat.ltb 0 (List.length (intersection source_is target_is)) then
-    Some ((Apt source source_is, Apt target target_is) :: nil)
-  else
-    let ocp := cell_path cells (head 0%nat source_is) (head 0%nat target_is) in
-    match ocp with
-    Some cp =>
-      (* The first element of the path is (head 0 source_is), *)
-      if 2 <=? List.length cp then
-      (* looking
-         at a length larger than 2 actually means the path has at least 3 fenceposts
-         and at least 2 intervals:
-         head source_is (nth 0 cp 0)  (nth 1 cp 0)
-         so there are (at least) 2 doors. *)
-        if existsb (Nat.eqb (nth 0 cp 0%nat)) source_is then
-        (* It can only be the case that the source is on a door, and
-         that the two cells concerned with the first hop are the
-         two cells of this door.  In this case, there is no need
-         to draw a first path element from from the source point to the
-         vertical edge midpoint, since the first point is already
-         on the door, and that the target is not in the second cell
-         of the path, so the length of cp is strictly larger than 2 *)
-           if existsb (Nat.eqb (nth (List.length cp - 2) cp 0%nat)) target_is then
-             (* Here target_is is in the penultimate cell of the path *)
-             Some (door_to_door cells (head 0%nat source_is) (nth 0 cp 0%nat)
-                 (Some source) (Some target) (seq.behead cp (* (seq.behead cp) *)))
-           else
-             Some (door_to_door cells (head 0%nat source_is) (nth 0 cp 0%nat) (Some source) None
-                 (seq.behead cp) ++
-                 path_reverse (point_to_door cells (Apt target target_is)
-                    (nth (List.length cp - 1) cp 0%nat)
-                    (nth (List.length cp - 2) cp 0%nat)))
+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 existsb (Nat.eqb (nth ((List.length cp) - 2) cp 0%nat)) target_is then
-             Some ((point_to_door cells (Apt source source_is) (head 0%nat source_is)
-                        (nth 0 cp 0%nat)) ++
-             door_to_door cells (head 0%nat source_is) (nth 0 cp 0%nat) None (Some target)
-                 (seq.behead cp))
+          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
-             Some (point_to_door cells (Apt source source_is) (head 0%nat source_is) (nth 0 cp 0%nat) ++
-             door_to_door cells (head 0%nat source_is) (nth 0 cp 0%nat) None None
-                 (seq.behead cp) ++
-                 path_reverse (point_to_door cells (Apt target target_is)
-                    (nth (List.length cp - 1) cp 0%nat)
-                    (nth (List.length cp - 2) cp 0%nat)))
+            p2
       else
-      (* if cp has length 1, then there is only one door. if one of the
-         point is on the door, it can be connected to the other, *)
-         match common_vert_edge (nth (head 0%nat source_is) cells dummy_cell)
-                                (nth (head 0%nat target_is) cells dummy_cell) with
-         | Some v =>
-           if on_vert_edge source v || on_vert_edge target v then
-              Some ((Apt source source_is, Apt target target_is) :: nil)
-           else
-              Some (point_to_door cells (Apt source source_is) (head 0%nat source_is)
-                 (head 0%nat target_is) ++
-                   path_reverse (point_to_door cells (Apt target target_is)
-                        (head 0%nat source_is) (head 0%nat target_is)))
-         | None => None
-         end
-  | None => None
+        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
-else
-None.
+| _ => 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.
@@ -857,9 +862,9 @@ None.
 Fixpoint break_segments (s : seq (annotated_point * annotated_point)) :
   seq (annotated_point * annotated_point) :=
   match s with
-  | (Apt p1 a1, Apt p2 a2) :: tl =>
-    (Apt p1 a1, Apt (midpoint p1 p2) (intersection a1 a2)) ::
-    (Apt (midpoint p1 p2) (intersection a1 a2), Apt p2 a2) ::
+  | (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. 
@@ -923,12 +928,12 @@ Fixpoint check_bezier_ccw (fuel : nat) (v : vert_edge)
 match fuel with
 | O => None
 | S p =>
-  let top_edge := Bpt (ve_x v)  (ve_top v) in
-  if negb (point_under_edge top_edge (Bedge a c)) then
+  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_edge (Bedge a b) ||
-     point_under_edge top_edge (Bedge b c)
+     point_under_edge top_of_edge (Bedge a b) ||
+     point_under_edge top_of_edge (Bedge b c)
   then 
     Some false
   else
@@ -955,12 +960,12 @@ Fixpoint check_bezier_cw (fuel : nat) (v : vert_edge)
 match fuel with
 | O => None
 | S p =>
-  let bot_edge := Bpt (ve_x v)  (ve_bot v) in
-  if point_strictly_under_edge bot_edge (Bedge a c) then
+  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_edge (Bedge a b)) ||
-     negb (point_strictly_under_edge bot_edge (Bedge b c))
+     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
@@ -996,19 +1001,14 @@ end.
 Definition fuel_constant := 20.
 
 Fixpoint check_curve_element_and_repair
-  (fuel : nat) (cells : seq cell) (e : curve_element) :
+  (fuel : nat) doors (e : curve_element) :
    seq curve_element :=
 match e with
 | straight p1 p2 => straight p1 p2 :: nil
 | bezier p1 p2 p3 =>
-  if Nat.eqb (List.length (cell_indices p2)) 2 then
-    let i1 := nth 0 (cell_indices p2) 0%nat in
-    let i2 := nth 1 (cell_indices p2) 0%nat in
-    let vedge := match common_vert_edge 
-         (nth i1 cells dummy_cell) (nth i2 cells dummy_cell) with
-      Some v => v
-      | None => dummy_vert_edge
-      end in
+  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
@@ -1030,16 +1030,17 @@ match e with
           match fuel with
           | S p =>
             straight p1 
-               (Apt (midpoint (apt_val p1) (apt_val p2)) (cell_indices p1))
+               (Apt (midpoint (apt_val p1) (apt_val p2)) 
+                    None (cell_indices p1))
               ::
-              check_curve_element_and_repair p cells
-                (bezier (Apt (midpoint (apt_val p1) (apt_val p2))
+              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)) (cell_indices p3)))
+                 (Apt (midpoint (apt_val p2) (apt_val p3)) None (cell_indices p3)))
               ++
               straight (Apt (midpoint (apt_val p2) (apt_val p3))
-                    (cell_indices p3)) p3 :: nil
+                    None (cell_indices p3)) p3 :: nil
           | _ =>
             straight p1 p2 :: straight p2 p3 :: nil
           end
@@ -1051,13 +1052,25 @@ end.
 
 Definition smooth_from_cells (cells : seq cell)
   (initial final : pt) : seq curve_element :=
-  match point_to_point cells initial final with
-  | Some s => List.concat
-       (List.map (check_curve_element_and_repair fuel_constant cells)
+  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
diff --git a/theories/hulls.v b/theories/hulls.v
index 507361d..650a1be 100644
--- a/theories/hulls.v
+++ b/theories/hulls.v
@@ -40,7 +40,7 @@ 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=> //; first by move=>_; exact ler01.
+split=> //.
 - by rewrite big_ord_recl big_ord0 addr0.
 - by move=> d [i _ <-].
 - by rewrite big_ord_recl big_ord0 scale1r addr0.
@@ -256,14 +256,14 @@ 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 (GRing.zero _))// (nth_map (GRing.zero _))// opprD [-_ - - _]addrC -!addrA; congr GRing.add; rewrite addrA subrr add0r.
+      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 (GRing.zero _))// subrr subr0 -[l`_i]scale1r.
+      - 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 (GRing.zero _)).
+      by rewrite -scalerBr (nth_map 0).
    move:h=>/(_ l'); rewrite size_map; apply.
       - rewrite map_inj_uniq=>//; apply addIr.
       - by [].
@@ -280,7 +280,7 @@ wlog: l lu ls ll f f0 f1 i ilt / l`_i == 0%R.
       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 (GRing.zero _))// subrr.
+      - 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.
diff --git a/theories/infra.v b/theories/infra.v
index 125f04f..710e47a 100644
--- a/theories/infra.v
+++ b/theories/infra.v
@@ -1,3 +1,4 @@
+From HB Require Import structures.
 From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq order.
 From mathcomp Require Import choice fintype finfun ssrfun bigop ssralg.
 (*Require Import orderedalg.*)
@@ -34,8 +35,7 @@ Proof.
   rewrite /eqp; case e: ((p ?= q))%positive=> // _; exact: Pcompare_Eq_eq.
 Qed.
 
-Canonical Structure eqp_Mixin := EqMixin eqpP.
-Canonical Structure eqp_eqType := Eval hnf in EqType positive eqp_Mixin.
+HB.instance Definition _ := hasDecEq.Build _ eqpP.
 
 Definition p_unpickle n := Some (Pos.pred (P_of_succ_nat n)).
 
@@ -45,22 +45,19 @@ Proof.
   by rewrite pred_o_P_of_succ_nat_o_nat_of_P_eq_id.
 Qed.
 
-Definition p_countMixin  := CountMixin p_pick_cancel.
-Definition p_choiceMixin := CountChoiceMixin p_countMixin.
+HB.instance Definition _ := @PCanIsCountable _ _ _ _ p_pick_cancel.
 
-Canonical Structure p_choiceType :=
+(*Canonical Structure p_choiceType :=
   Eval hnf in ChoiceType positive p_choiceMixin.
 Canonical Structure p_countType :=
-  Eval hnf in CountType positive p_countMixin.
+  Eval hnf in CountType positive p_countMixin.*)
 
 (* Structures on Z *)
 
 Lemma eqzP : Equality.axiom Zeq_bool.
 Proof. by move=> z1 z2;  apply: (iffP idP); move/Zeq_is_eq_bool. Qed.
 
-Canonical Structure Z_Mixin := EqMixin eqzP.
-Canonical Structure Z_eqType := Eval hnf in EqType Z Z_Mixin.
-
+HB.instance Definition _ := hasDecEq.Build _ eqzP.
 
 Definition z_code (z : Z) :=
   match z with
@@ -99,6 +96,9 @@ Proof.
   by move=> x; rewrite /z_pickle /z_unpickle pickleK z_codeK.
 Qed.
 
+HB.instance Definition _ := @PCanIsCountable _ _ _ _ z_pick_cancel.
+
+(*
 Definition z_countMixin  := CountMixin z_pick_cancel.
 Definition z_choiceMixin := CountChoiceMixin z_countMixin.
 
@@ -106,7 +106,7 @@ Canonical Structure z_choiceType :=
   Eval hnf in ChoiceType Z z_choiceMixin.
 Canonical Structure z_countType :=
   Eval hnf in CountType Z z_countMixin.
-
+*)
 
 Lemma ZplusA : associative Zplus.
 Proof. by exact Zplus_assoc. Qed.
@@ -123,11 +123,7 @@ Proof. exact Zplus_opp_l. Qed.
 Lemma ZplusrN : right_inverse 0%Z Z.opp Zplus.
 Proof. exact Zplus_opp_r. Qed.
 
-Definition Z_zmodMixin :=
-  ZmodMixin ZplusA ZplusC Zplus0 ZplusNr.
-
-Canonical Structure Z_zmodType :=
-  Eval hnf in ZmodType Z Z_zmodMixin.
+HB.instance Definition _ := @GRing.isZmodule.Build Z _ _ _ ZplusA ZplusC Zplus0 ZplusNr.
 
 (* Z Ring *)
 Lemma ZmultA : associative Zmult.
@@ -151,16 +147,12 @@ Proof. exact: Zmult_plus_distr_r. Qed.
 Lemma nonzeroZ1 : 1%Z != 0%Z.
 Proof. by []. Qed.
 
-Definition Z_ringMixin :=
-  RingMixin ZmultA Zmult1q Zmultq1 Zmult_addl Zmult_addr nonzeroZ1.
-
-Canonical Structure Z_ringType :=
-  Eval hnf in RingType Z Z_ringMixin.
+HB.instance Definition _ := @GRing.Zmodule_isRing.Build Z _ _ ZmultA Zmult1q Zmultq1 Zmult_addl Zmult_addr nonzeroZ1.
 
 Lemma ZmultC : commutative Zmult.
 Proof. exact: Zmult_comm. Qed.
 
-Canonical Structure Z_comRingType := ComRingType Z ZmultC.
+HB.instance Definition _ := @GRing.Ring_hasCommutativeMul.Build Z ZmultC.
 
 (* Warning : an antisymmetric an a transitive predicates are
 present in loaded Relations.Relation_Definition *)
@@ -202,12 +194,7 @@ Qed.
 Lemma  Zinv_out : {in predC Zunit, Zinv =1 id}.
 Proof. exact. Qed.
 
-Definition Z_comUnitRingMixin :=  ComUnitRingMixin ZmulV unitZPl Zinv_out.
-
-Canonical Structure Z_unitRingType :=
-  Eval hnf in UnitRingType Z Z_comUnitRingMixin.
-
-Canonical Structure Z_comUnitRing := Eval hnf in [comUnitRingType of Z].
+HB.instance Definition _ := GRing.ComRing_hasMulInverse.Build Z ZmulV unitZPl Zinv_out.
 
 Lemma Z_idomain_axiom : forall x y : Z,
   x * y = 0 -> (x == 0) || (y == 0).
@@ -216,7 +203,7 @@ move=> x y; rewrite -[x * y]/(Zmult x y); move/Zmult_integral; case=> -> //=.
 by rewrite eqxx orbT.
 Qed.
 
-Canonical Structure Z_iDomain := Eval hnf in IdomainType Z Z_idomain_axiom.
+HB.instance Definition _ := @GRing.ComUnitRing_isIntegral.Build Z Z_idomain_axiom.
 
 Lemma Zlt_def (x y : Z) : (x <? y)%Z = (y != x) && (x <=? y)%Z.
 Proof.
@@ -236,13 +223,8 @@ Lemma Z_display : Datatypes.unit. Proof. exact: tt. Qed.
   @LePOrderMixin Z_eqType Z.leb Z.ltb Zlt_def Zle_bool_refl Zle_bool_antisymb Zle_bool_transb.
 Canonical Z_porderType := POrderType Z_display Z Z_OrderedRingMixin.*)
 
-Definition Z_OrderedRingMixin2 :=
-  LeOrderMixin Zlt_def (fun _ _ => erefl) (fun _ _ => erefl) Zle_bool_antisymb Zle_bool_transb Zle_total.
-
-Canonical z_porderType := POrderType Z_display Z Z_OrderedRingMixin2.
-Canonical z_latticeType := LatticeType Z Z_OrderedRingMixin2.
-Canonical z_distrLatticeType := DistrLatticeType Z Z_OrderedRingMixin2.
-Canonical z_orderType := OrderType Z Z_OrderedRingMixin2.
+HB.instance Definition _ :=
+  @Order.isOrder.Build Z_display Z _ _ _ _ Zlt_def (fun _ _ => erefl) (fun _ _ => erefl) Zle_bool_antisymb Zle_bool_transb Zle_total.
 
 (*Canonical Structure Z_OrderedRingType :=
   Eval hnf in OIdomainType Z Z_OrderedRingMixin.
diff --git a/theories/intersection.v b/theories/intersection.v
index 7baa8d0..74335e7 100644
--- a/theories/intersection.v
+++ b/theories/intersection.v
@@ -56,7 +56,7 @@ 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 : regular_lmodType R) = t * u by [].
+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.
@@ -109,7 +109,7 @@ 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 : regular_lmodType R) = t*u by [].
+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=>//.
@@ -232,8 +232,8 @@ wlog : a b t u lab t01 ltab u01 luab / (t == 0) && (u == 1).
      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; eexists; apply/andP; split => //.
-     by apply between_conv; eexists; apply/andP; split => //.
+       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.
@@ -299,7 +299,7 @@ have : [exists i : 'I_(size l), det l`_i l`_i.+1mod (b <| sup I |> a) <= 0].
   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.
+      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.
@@ -307,7 +307,7 @@ have : [exists i : 'I_(size l), det l`_i l`_i.+1mod (b <| sup I |> a) <= 0].
   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: meets_ge => i abgt; rewrite lee_fin; apply: (mulr_ge0 (la _)).
+    apply: Order.TLatticeTheory.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.
@@ -318,7 +318,7 @@ have : [exists i : 'I_(size l), det l`_i l`_i.+1mod (b <| sup I |> a) <= 0].
     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: meets_inf.
+    by move:abgt0; rewrite invr_gt0=>abgt; exact: Order.TLatticeTheory.meets_inf.
   rewrite {2}[det a _ _]det_cyclique (le_trans _ (la i))// mulr_ge0_le0 //.
   by move:t01 => /andP[].
 move=> /existsP[i] iable0.
diff --git a/theories/isolate.v b/theories/isolate.v
index 362f268..2270bb4 100644
--- a/theories/isolate.v
+++ b/theories/isolate.v
@@ -1,5 +1,6 @@
+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.
+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.
@@ -147,7 +148,7 @@ Section count_root_correct.
 
 Variable R : archiFieldType.
 
-Definition R' := RealAlg.alg_of_rcfType R.
+(*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') :
@@ -168,9 +169,9 @@ have twon0 : (1 + 1 != 0 :> R').
 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_pmul2r // invr_gt0.
+ 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_pmul2r // invr_gt0.
+ 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.
@@ -318,13 +319,13 @@ 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.*)
 
-Canonical root_info_eqMixin (R : eqType) := EqMixin (root_info_eqP R).
+HB.instance Definition _ := hasDecEq.Build _ (root_info_eqP R).
 
-Canonical root_info_eqType (R : eqType) :=
+(*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.
+Prenex Implicits root_info_eqP.*)
 
 
 (* NB(rei): typing issue with {realclosure _}
@@ -353,11 +354,11 @@ 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_pmul2r twogt0) mulfVK.
+ 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_pmul2r twogt0) mulfVK.
+ 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.
diff --git a/theories/math_comp_complements.v b/theories/math_comp_complements.v
new file mode 100644
index 0000000..a65e6de
--- /dev/null
+++ b/theories/math_comp_complements.v
@@ -0,0 +1,291 @@
+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.
+
+Fixpoint seq_subst {A : eqType}(l : seq A) (b c : A) : seq A :=
+  match l with
+  | nil => nil
+  | a :: tl =>
+    if a == b then (c :: seq_subst tl b c) else (a :: seq_subst tl b c)
+  end.
+
+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.
+
+Lemma seq_subst_eq0  {A : eqType} (l : seq A) b c :
+  (seq_subst l b c == [::]) = (l == [::]).
+Proof. by case : l => [ | a l] //=; case: ifP. 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.
+elim: l1 => [ // | a l1 Ih] /=.
+by case: ifP=> [ab | anb]; rewrite Ih.
+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.
+rewrite -size_eq0 => /negP sizebneq0 /=.
+apply  /negP.
+rewrite -size_eq0 !size_cat /= !addn_eq0 .
+apply  /negP /andP => [] /andP .
+move => /andP [] _ /andP [] sizebeq0.
+by rewrite sizebeq0 in sizebneq0.
+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 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.
+
+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/no_crossing.v b/theories/no_crossing.v
index 0d81e85..5e71a20 100644
--- a/theories/no_crossing.v
+++ b/theories/no_crossing.v
@@ -104,7 +104,7 @@ Definition have_crossing (e1 e2 : edge) : bool :=
   else
    (* The two edges are parallel.  They may still touch. *)
    if negb (Qeq_bool 
-             (area3 (left_pt e1) (left_pt e2) (right_pt e2)) 0) then
+             (area3 _ Qplus Qminus Qmult (left_pt e1) (left_pt e2) (right_pt e2)) 0) then
      true
    else
      (Qlt_bool (p_x (left_pt e2)) (p_x (left_pt e1)) &&
@@ -256,8 +256,10 @@ Lemma cnt14 :
 Proof. easy. Qed.
 
 Import String.
+(*
 Compute example_test (List.concat (List.map outgoing evs14))
              (Bpt 1.2 (-0.8)) (Bpt (-1) (0.4)) nil.
+*)
 Compute (concat "
 " (postscript_header ++
    display_edge 300 400 70 example_bottom ::
diff --git a/theories/opening_cells.v b/theories/opening_cells.v
new file mode 100644
index 0000000..9a70026
--- /dev/null
+++ b/theories/opening_cells.v
@@ -0,0 +1,1430 @@
+From mathcomp Require Import all_ssreflect all_algebra.
+Require Export Field.
+Require Import math_comp_complements
+  generic_trajectories points_and_edges events cells.
+
+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.
+
+Section working_environment.
+
+Variable R : realFieldType.
+
+Notation pt := (pt R).
+Notation p_x := (p_x R).
+Notation p_y := (p_y R).
+Notation Bpt := (Bpt R).
+Notation edge := (edge R).
+Notation event := (event R edge).
+Notation point := (point R edge).
+Notation outgoing := (outgoing R edge).
+
+Notation cell := (cell R edge).
+Notation low := (low R edge).
+Notation high := (high R edge).
+Notation left_pts := (left_pts R edge).
+Notation right_pts := (right_pts R edge).
+
+Notation dummy_pt := (dummy_pt R 1).
+Notation dummy_edge := (dummy_edge R).
+Notation dummy_cell := (dummy_cell R 1 edge (@unsafe_Bedge R)).
+
+(*
+Fixpoint opening_cells_aux (p : pt) (out : seq edge) (low_e high_e : edge) 
+  : seq cell * cell :=
+  match out with
+  | [::] =>
+      let op0 := vertical_intersection_point p low_e in
+      let op1 := vertical_intersection_point 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_intersection_point 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.
+*)
+
+Definition opening_cells_aux :=
+  opening_cells_aux R eq_op le +%R (fun x y => x - y) *%R (fun x y => x / y)
+  1 edge (@unsafe_Bedge R) (@left_pt R) (@right_pt R).
+
+Lemma opening_cells_aux_eqn p out low_e high_e :
+  opening_cells_aux p out low_e high_e =
+  match out with
+  | [::] =>
+      let op0 := vertical_intersection_point p low_e in
+      let op1 := vertical_intersection_point 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_intersection_point 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] : seq pt)) [::] low_e c :: s, nc)
+  end
+end.
+Proof.  by case: out. Qed.
+
+Definition opening_cells (p : pt) (out : seq edge) (l h : edge) : seq cell :=
+   let (s, c) := opening_cells_aux p (sort (@edge_below R) out) l h in
+   rcons s c.
+
+Section proof_environment.
+Variables bottom top : edge.
+
+Notation extra_bot := (extra_bot bottom).
+Notation close_alive_edges := (close_alive_edges bottom top).
+Notation cells_bottom_top := (cells_bottom_top bottom top).
+Notation inside_box := (inside_box bottom top).
+Notation open_cell_side_limit_ok := (@open_cell_side_limit_ok R).
+Notation seq_low_high_shift := (@seq_low_high_shift R).
+Notation cover_left_of := (@cover_left_of _ bottom top).
+
+Section opening_cells.
+
+Lemma opening_cells_left p out le he :
+  {in out, forall g, left_pt g == p} ->
+  valid_edge le p ->
+  valid_edge he p ->
+  {in opening_cells p out le he, forall c, left_limit c = p_x p}.
+Proof.
+move=> outl vle vhe; rewrite /opening_cells.
+rewrite /opening_cells_aux.
+have : forall g, g \in sort (@edge_below _) out -> left_pt g == p.
+  by move=> g; rewrite mem_sort; apply: outl.
+elim: (sort _ _) le vle => [ | g1 gs Ih] le vle {}outl c /=.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite /= pvertE // pvertE //=.
+  by case: ifP=> _; case: ifP=> _; rewrite inE /left_limit => /eqP ->.
+have outl' : forall g, g \in gs -> left_pt g == p.
+  by move=> g gin; apply outl; rewrite inE gin orbT.
+rewrite /=.
+have vg1 : valid_edge g1 p.
+  by rewrite -(eqP (outl g1 _)) ?valid_edge_left // inE eqxx.
+move: Ih; case oca_eq : (generic_trajectories.opening_cells_aux _ _ _ _) => [s c'] /(_ _ vg1 outl').
+rewrite oca_eq => Ih.
+rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+rewrite pvertE //=.
+rewrite inE => /orP[/eqP -> | ]; first by rewrite /left_limit; case : ifP.
+by apply: Ih.
+Qed.
+
+Lemma opening_cells_low_diff_high p out le he :
+  {in out, forall g, left_pt g == p} ->
+  uniq out ->
+  valid_edge le p ->
+  valid_edge he p ->
+  p >>> le ->
+  p <<< he ->
+  {in opening_cells p out le he, forall g, low g != high g}.
+Proof.
+move=> outl u vle vhe pal puh; rewrite /opening_cells.
+have {outl} : {in sort (@edge_below _) out, forall g, left_pt g == p}.
+  by move=> g; rewrite mem_sort; apply: outl.
+have {u} : uniq (sort (@edge_below _) out) by rewrite sort_uniq.
+move=> u outl.
+have : le != head he (sort (@edge_below _) out).
+  case: (sort _ _) outl => [ | g1 gs] /=.  
+    move=> _; apply/eqP=> abs; move: puh; rewrite -abs strict_nonAunder// andbC.
+    by rewrite (negbTE pal).
+  move=> /(_ g1 (mem_head _ _)) /eqP lg1q; apply/eqP=> abs.
+  by move: pal; rewrite abs under_onVstrict -lg1q ?valid_edge_left ?left_on_edge.
+elim: (sort _ _) le vle {pal} u outl => [ | g1 gs Ih] le /= vle + + ledif.
+  rewrite /= => _ _.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite (pvertE vle) (pvertE vhe).
+  by case: ifP=> _; case: ifP=> _ /= g; rewrite inE=> /eqP -> /=.
+move=> /andP[] gnin u outl.
+have /eqP lg1q : left_pt g1 == p by apply: outl; rewrite inE eqxx.
+have {}outl : {in gs, forall g, left_pt g == p}.
+  by move=> g gin; apply: outl; rewrite inE gin ?orbT.
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+rewrite (pvertE vle).
+have vg1 : valid_edge g1 p by rewrite -lg1q valid_edge_left.
+have g1nhe : g1 != he.
+  apply/eqP=> abs.
+  by move: puh; rewrite -abs strict_nonAunder // -lg1q ?left_on_edge.
+have g1dif : g1 != head he gs.
+  apply/eqP=> abs; move: gnin.
+  have : head he gs \in he :: gs.
+    by case: (gs) => [ | ? ?]; rewrite /= !inE !eqxx ?orbT.
+  rewrite -abs inE=> /orP[/eqP {}abs _ | ->]; last by [].
+  by rewrite abs eqxx in g1nhe.
+have := Ih g1 vg1 u outl g1dif; rewrite oca_eq=> {}Ih.
+move=> g; rewrite /= inE=> /orP [/eqP -> /= | ]; first by [].
+apply: Ih.
+Qed.
+
+Lemma opening_cells_seq_edge_shift p s c oe le he :
+  {in oe, forall g, left_pt g == p} ->
+  valid_edge le p -> valid_edge he p ->
+  opening_cells_aux p oe le he = (s, c) ->
+  le :: [seq high i | i <- rcons s c] =
+  rcons [seq low i | i <- rcons s c] he.
+Proof.
+move=> + + vh.
+elim: oe le s c => [ | g1 oe Ih] le s c leftg vl /=.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  by rewrite pvertE // pvertE // => -[] <- <- /=.
+have vg1 : valid_edge g1 p.
+  by rewrite -(eqP (leftg g1 _)) ?valid_edge_left // inE eqxx.
+have leftg' : {in oe, forall g, left_pt g == p}.
+  by move=> g gin; apply: leftg; rewrite inE gin orbT.
+have := Ih _ _ _ leftg' vg1; case: (opening_cells_aux _ _ _ _)=> [s' c'].
+move=> /(_ s' c' erefl) {}Ih.
+rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+by rewrite pvertE // => -  [] <- <- /=; congr (_ :: _).
+Qed.
+
+Lemma opening_cells_aux_subset c' s' c p s le he:
+  valid_edge le p -> valid_edge he p ->
+  {in s, forall g, left_pt g == p} ->
+  opening_cells_aux p s le he = (s', c') ->
+  c \in rcons s' c' ->
+  (low c \in le :: s) && (high c \in he :: s).
+Proof.
+move=> + vhe.
+elim: s c' s' le => [ | g1 s Ih] c' s' le /= vle lsp.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite pvertE // pvertE // => - [] <- <-.
+  by do 2 (case: ifP=> _); rewrite /= inE=> /eqP -> /=; rewrite !inE !eqxx.
+have vg1 : valid_edge g1 p.
+  by rewrite -(eqP (lsp g1 _)) ?valid_edge_left // inE eqxx.
+have lsp' : {in s, forall g, left_pt g == p}.
+  by move=> g gin; rewrite lsp // inE gin orbT.
+have := Ih _ _ _ vg1 lsp'; case: (opening_cells_aux _ _ _ _)=> [s1 c1].
+move=> /(_ _ _ erefl) {} Ih.
+rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+rewrite pvertE // => - [] <- <- /=; rewrite inE=> /orP[/eqP -> /= | ].
+  by rewrite !inE ?eqxx ?orbT.
+rewrite inE; move=>/Ih/andP[] ->; rewrite orbT andTb.
+by rewrite !inE orbCA => ->; rewrite orbT.
+Qed.
+
+
+(*TODO : check all uses of opening_cells_aux_subset for potential uses
+  of this simpler lemma. *)
+Lemma opening_cells_subset c p s le he :
+  valid_edge le p -> valid_edge he p ->
+  {in s, forall g, left_pt g == p} ->
+  c \in opening_cells p s le he ->
+  (low c \in le :: s) && (high c \in he :: s).
+Proof.
+move=> vle vhe lsp.
+rewrite /opening_cells.
+case oca_eq : (opening_cells_aux _ _ _ _) => [so co] cin.
+have lsp' : {in sort (@edge_below _) s, forall g, left_pt g == p}.
+  by move=> g; rewrite mem_sort; apply: lsp.
+have := opening_cells_aux_subset vle vhe lsp' oca_eq cin.
+by rewrite !inE !mem_sort.
+Qed.
+
+(*
+Lemma opening_cells_aux_nnil p s le he :
+  valid_edge le p -> valid_edge he p ->
+  {in s, forall g, left_pt g == p} ->
+  opening_cells_aux p s le he != nil.
+Proof.
+by move=> + vhe; case: s => [ | g1 s] vle lsp; rewrite /= pvertE // ?pvertE.
+Qed.
+*)
+
+Lemma opening_cells_aux_high p s le he :
+  valid_edge le p -> valid_edge he p ->
+  {in s, forall g, left_pt g == p} ->
+  [seq high i | i <- (opening_cells_aux p s le he).1] = s.
+Proof.
+move=> vle vhe lsp.
+elim: s le vle lsp => [ | g1 s Ih] le vle lsp.
+  rewrite /= -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  by rewrite /= pvertE // pvertE.
+have vg1 : valid_edge g1 p.
+  by rewrite -(eqP (lsp g1 _)) ?valid_edge_left // inE eqxx.
+have lsp' : {in s, forall g, left_pt g == p}.
+  by move=> g gin; apply: lsp; rewrite inE gin orbT.
+rewrite /= -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+rewrite pvertE //.
+by have := Ih _ vg1 lsp'; case: (opening_cells_aux _ _ _ _) => [s' c'] /= ->.
+Qed.
+
+Lemma opening_cells_aux_high_last p s le he :
+  valid_edge le p -> valid_edge he p ->
+  {in s, forall g, left_pt g == p} ->
+  high (opening_cells_aux p s le he ).2 = he.
+Proof.
+move=> + vhe; elim: s le => [ /= | g1 s Ih] le vle lsp.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  by rewrite pvertE // pvertE.
+have vg1 : valid_edge g1 p.
+  by rewrite -(eqP (lsp g1 _)) ?valid_edge_left // inE eqxx.
+have lsp' : {in s, forall g, left_pt g == p}.
+  by move=> g gin; apply: lsp; rewrite inE gin orbT.
+have := Ih _ vg1 lsp'.
+rewrite /= -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+rewrite pvertE //.
+by case : (opening_cells_aux _ _ _ _) => [s' c'].
+Qed.
+
+Lemma opening_cells_high p s le he :
+  valid_edge le p -> valid_edge he p ->
+  {in s, forall g, left_pt g == p} ->
+  [seq high i | i <- opening_cells p s le he] =
+  rcons (sort (@edge_below R) s) he.
+Proof.
+move=> vle vhe lsp; rewrite /opening_cells.
+have lsp' :
+   {in sort (@edge_below _) s, forall g, left_pt g == p}.
+  move=> g; rewrite mem_sort; apply: lsp.
+move: (lsp') => /opening_cells_aux_high => /(_ _ _ vle vhe).
+move: lsp' => /opening_cells_aux_high_last => /(_ _ _ vle vhe).
+case: (opening_cells_aux _ _ _ _) => [s' c'] /=.
+by rewrite map_rcons => -> ->.
+Qed.
+
+Lemma opening_cells_aux_right_form (ctxt s : seq edge) (p : pt) le he
+ s' c' :
+p >>= le -> p <<< he -> valid_edge le p -> valid_edge he p ->
+le \in ctxt -> he \in ctxt ->
+le <| he -> {in s, forall g, left_pt g == p} ->
+{in ctxt &, (@no_crossing R)} ->
+{subset s <= ctxt} ->
+path (@edge_below R) le s  ->
+opening_cells_aux p s le he = (s', c') ->
+s_right_form (rcons s' c').
+Proof.
+move=> + ph + vh + hin + + noc + +.
+elim: s le s' c' => [ | g1 edges IH] le s' c'
+  pabove vle lin lowhigh outs allin sorted_e /=.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  by rewrite pvertE // pvertE // => -[] <- <- /=; rewrite andbT.
+rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+rewrite pvertE //.
+have outs' : {in edges, forall g, left_pt g == p}.
+  by move=> g gin; apply outs; rewrite inE gin orbT.
+have allin' : {subset edges <= ctxt}.
+  by move=> g gin; rewrite allin // inE gin orbT.
+have sorted_e' : path (@edge_below R) g1 edges.
+   by apply: (path_sorted sorted_e).
+have /eqP gl : left_pt g1 == p by rewrite outs // inE eqxx.
+have g1belowhigh : g1 <| he.
+  have gin' : g1 \in ctxt by rewrite allin // inE eqxx.
+  have/no_crossingE := noc g1 he gin' hin.
+  by rewrite gl=>/(_ vh)=> -[]/(_ ph).
+have pong : p === g1 by rewrite -gl left_on_edge.
+have paboveg1 : p >>= g1
+   by rewrite strict_nonAunder ?pong //; case/andP: pong.
+move: (sorted_e) => /=/andP[] leg1 _.
+have g1in : g1 \in ctxt by rewrite allin // inE eqxx.
+have vg1 : valid_edge g1 p.
+  by rewrite -(eqP (outs g1 _)) ?valid_edge_left // inE eqxx.
+have := IH g1 _ _ paboveg1 vg1 g1in g1belowhigh outs' allin' sorted_e'.
+case: (opening_cells_aux _ _ _ _) => [s1 c1] - /(_ _ _ erefl) {} IH /=.
+by move=> [] <- <- /=; rewrite leg1.
+Qed.
+
+Lemma opening_cells_right_form p s low_e high_e :
+valid_edge low_e p ->
+valid_edge high_e p ->
+p >>= low_e -> p <<< high_e ->
+low_e <| high_e ->
+{in s, forall g, left_pt g == p} ->
+{in s, forall g, low_e <| g} ->
+{in s, forall g, g <| high_e} ->
+{in s &, (@no_crossing R)} ->
+s_right_form (opening_cells p s low_e high_e).
+Proof.
+move=> vl vh pabove punder lowhigh outs alla allb noc; apply/allP.
+have noc' : {in low_e :: high_e :: s &, (@no_crossing R)}.
+  move=> e1 e2; rewrite !inE !orbA =>/orP[e1lh |e1in ]/orP[e2lh |e2in].
+    by apply/orP;move:e1lh e2lh=> /orP[]/eqP -> /orP[]/eqP ->;
+      rewrite ?edge_below_refl ?lowhigh ?orbT.
+    - by move: e1lh=> /orP[]/eqP ->;apply/orP;
+         rewrite/below_alt ?alla ?allb ?orbT.
+    - by move: e2lh=> /orP[]/eqP ->; apply/orP;
+         rewrite/below_alt ?alla ?allb ?orbT.
+    by apply: noc.
+have sorted_e : sorted (@edge_below R) (sort (@edge_below R) s).
+  by apply: sort_edge_below_sorted.
+have /sub_in1/= trsf : {subset sort (@edge_below R) s <= s}.
+  by move=> x; rewrite mem_sort.
+move/trsf:outs => {}outs.
+have [lin hin] : (low_e \in [:: low_e, high_e & s]) /\
+   (high_e \in [:: low_e, high_e & s]).
+  by split; rewrite !inE eqxx ?orbT.
+have slho : {subset (sort (@edge_below _) s) <=
+               [:: low_e, high_e & s]}.
+  by move=> x; rewrite mem_sort => xin; rewrite !inE xin ?orbT.
+move=> x xin.
+have srt : sorted (@edge_below R) (low_e :: sort (@edge_below R) s).
+  case sq : (sort (@edge_below R) s) => [// | a tl].
+    rewrite -[sorted _ _]/((low_e <| a) && sorted (@edge_below R) (a :: tl)).
+    rewrite -sq sorted_e andbT alla //.
+    by rewrite -(mem_sort (@edge_below _)) sq inE eqxx.
+have := (opening_cells_aux_right_form _ _ _ _ lin hin lowhigh outs).
+move: xin; rewrite /opening_cells.
+case: (opening_cells_aux _ _ _ _) => [s1 c1] xin - /(_ s1 c1).
+move=> /(_ _ _ _ _ _ _ _ erefl) => it.
+by apply: (allP (it _ _ _ _ _ _ _) x xin).
+Qed.
+
+Lemma lower_edge_new_cells e low_e high_e:
+forall new_open_cells,
+valid_edge low_e (point e) ->
+valid_edge high_e (point e) ->
+opening_cells (point e) (outgoing e) low_e high_e = new_open_cells ->
+low (head dummy_cell new_open_cells) = low_e.
+Proof.
+move=> vle vhe.
+rewrite /opening_cells.
+case : (sort (@edge_below R) (outgoing e)) => [/= |/= c q] newop.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  by rewrite pvertE // pvertE //= => <- /=.
+rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+rewrite pvertE //.
+by case: (opening_cells_aux _ _ _ _) => [s1 c1] /= => <- /=.
+Qed.
+
+Lemma opening_cells_not_nil out le he p :
+  opening_cells p out le he != [::].
+Proof.
+rewrite /opening_cells; case: (opening_cells_aux _ _ _ _) => [s1 c1].
+apply/eqP/rcons_neq0.
+Qed.
+
+Lemma higher_edge_new_cells e low_e high_e:
+out_left_event e ->
+valid_edge low_e (point e) -> valid_edge high_e (point e) ->
+forall new_open_cells,
+opening_cells (point e) (outgoing e) low_e high_e =
+   new_open_cells ->
+high (last dummy_cell new_open_cells) = high_e.
+Proof.
+rewrite /opening_cells.
+move=> /outleft_event_sort outl vle vhe.
+have := opening_cells_aux_high_last vle vhe outl.
+case : (opening_cells_aux _ _ _ _) => [s1 c1] <- ? <-.
+by rewrite last_rcons.
+Qed.
+
+Lemma opening_cells_close event low_e high_e future :
+valid_edge low_e (point event) ->
+valid_edge high_e (point event) ->
+out_left_event event ->
+end_edge_ext bottom top low_e future ->
+end_edge_ext bottom top high_e future ->
+close_out_from_event event future ->
+close_alive_edges (opening_cells (point event) (outgoing event) low_e high_e)
+   future.
+Proof.
+rewrite /opening_cells.
+move=> vle vhe oute A B /close_out_from_event_sort; move: A B.
+have : {in sort (@edge_below _) (outgoing event),
+          forall g, left_pt g == (point event)}.
+  by move=> g; rewrite mem_sort; apply: oute.
+move : low_e vle.
+elim : (sort (@edge_below R) (outgoing event)) => [| g1 q Ih] /= 
+            le vle oute' endl endh.
+  move=> _.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  by rewrite pvertE // pvertE //= endl endh.
+move => /andP[] endg1 allend.
+have oute1 : {in q, forall g, left_pt g == point event}.
+  by move=> g gin; apply oute'; rewrite inE gin orbT.
+have vg1 : valid_edge g1 (point event).
+  by rewrite -(eqP (oute' g1 _)) ?valid_edge_left // inE eqxx.
+have:= Ih g1 vg1 oute1 (end_edgeW _ _ endg1) endh allend.
+case : (opening_cells_aux _ _ _ _) => [s1 c1] => {}Ih.
+rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+by rewrite pvertE //= endl (end_edgeW _ _ endg1) Ih.
+Qed.
+
+Lemma opening_valid e low_e high_e:
+out_left_event e ->
+valid_edge low_e (point e) ->
+valid_edge high_e (point e) ->
+seq_valid (opening_cells (point e) (outgoing e) low_e high_e) (point e).
+Proof.
+move=> + + vhe.
+rewrite /opening_cells.
+move/outleft_event_sort.
+move : low_e.
+elim : (sort (@edge_below R) (outgoing e)) => [/= | c q IH] low_e outl vle.
+  rewrite /=.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  by rewrite pvertE // pvertE //= vle vhe.
+rewrite /=.
+rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+rewrite pvertE //.
+have vc : valid_edge c (point e).
+  by rewrite -(eqP (outl c _)) ?valid_edge_left // inE eqxx.
+have outl1 : forall g, g \in q -> left_pt g == point e.
+  by move=> g gin; rewrite outl // inE gin orbT.
+have := IH c outl1 vc.
+case: (opening_cells_aux _ _ _ _) => [s1 c1] {} Ih /=.
+by rewrite vle vc Ih.
+Qed.
+
+Lemma adjacent_opening_aux p s le he news newc :
+  valid_edge le p -> valid_edge he p ->
+  {in s, forall g, left_pt g == p} ->
+  opening_cells_aux p s le he = (news, newc) -> 
+  adjacent_cells (rcons news newc) /\
+   (low (head dummy_cell (rcons news newc)) = le).
+Proof.
+move=> + vhe.
+elim: s le news newc => [ | g s Ih] le news newc /= vle oute.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  by rewrite pvertE // pvertE // => - [] <- <- /=.
+have vg : valid_edge g p.
+  by rewrite -(eqP (oute g _)) ?valid_edge_left // inE eqxx.
+have oute' : {in s, forall g, left_pt g == p}.
+  by move=> g' gin; rewrite oute // inE gin orbT.
+case oca_eq: (opening_cells_aux _ _ _ _) => [s1 c1].
+have := Ih g s1 c1 vg oute' oca_eq => -[] Ih1 Ih2 {Ih}.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite pvertE // => - [] <- <- /=; split;[ | done].
+case: (s1) Ih1 Ih2 => [ | a s'] /=.
+  by move=> _ ->; rewrite eqxx.
+by move=> -> ->; rewrite eqxx.
+Qed.
+
+Lemma adjacent_opening p s le he:
+  valid_edge le p -> valid_edge he p ->
+  {in s, forall g, left_pt g == p} ->
+  adjacent_cells (opening_cells p s le he).
+Proof.
+move=> vle vhe lefts.
+have lefts' : {in sort (@edge_below _) s, forall g, left_pt g == p}.
+  by move=> g; rewrite mem_sort; apply: lefts.
+rewrite /opening_cells; case oca_eq: (opening_cells_aux _ _ _ _) => [so co].
+by have [] := adjacent_opening_aux vle vhe  lefts' oca_eq.
+Qed.
+
+Lemma opening_cells_last_lexePt e low_e high_e c :
+out_left_event e ->
+~~(point e <<< low_e) -> point e <<< high_e ->
+valid_edge low_e (point e)-> valid_edge high_e (point e) ->
+{in  (rcons (low_e::(sort (@edge_below R) (outgoing e))) high_e) &, no_crossing R} ->
+low_e <| high_e ->
+ c \in (opening_cells (point e) (outgoing e) low_e high_e) ->
+ lexePt (last dummy_pt (left_pts c)) (point e).
+Proof.
+rewrite /opening_cells.
+move => /outleft_event_sort outlefte eabl eunh lowv highv.
+elim : (sort (@edge_below R) (outgoing e)) low_e eabl lowv outlefte => [/= | c' q IH] low_e eabl lowv outlefte nc linfh.
+  have := pvertE highv; set high_p := Bpt _ _ => hp.
+  have := pvertE lowv; set low_p := Bpt _ _ => lp.
+  have := intersection_on_edge lp=> [][] poel lx_eq.
+  have := intersection_on_edge hp=> [][] poeh hx_eq.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite lp hp.
+  rewrite lx_eq in hx_eq.
+  have y_ineq := order_below_viz_vertical lowv highv lp hp linfh.
+  rewrite  inE => /eqP ->.
+  case: ifP.
+    rewrite -[pt_eqb R eq_op high_p (point e)]/(high_p == (point e) :> pt).
+    move=> /eqP <-.
+    rewrite -[pt_eqb R eq_op high_p low_p]/(high_p == low_p :> pt).
+    case : ifP => [/eqP <-/=|/= _].
+      by rewrite /lexePt eqxx le_refl orbT .
+    by rewrite /lexePt hx_eq eqxx y_ineq /= orbT.
+  rewrite /lexePt.
+  rewrite -[pt_eqb _ _ _ _]/(high_p == point e :> pt).
+  rewrite -[pt_eqb _ _ _ _]/(point e == low_p :> pt).
+  case : ifP => [/eqP <-/=|/=_ ].
+    by rewrite eqxx le_refl /= orbT.
+  rewrite lx_eq eqxx.
+  have -> : p_y low_p <= p_y (point e).
+    by rewrite leNgt -(strict_under_edge_lower_y lx_eq poel).
+  by rewrite orbT.
+rewrite /= .
+have cin : c' \in c' :: q.
+  by rewrite  inE eqxx.
+have c'v: (valid_edge c' (point e)).
+  apply valid_edge_extremities.
+  by rewrite outlefte // cin.
+have einfc' : ~~ (point e <<< c').
+  apply : onAbove.
+  have := outlefte c' cin => /eqP <-.
+  apply :  left_on_edge.
+have outq: (forall e0 : edge, e0 \in q -> left_pt e0 == point e).
+  move => e0 ein.
+  apply outlefte.
+  by rewrite inE ein orbT.
+have c'infh : c' <| high_e.
+  have := nc high_e c'.
+  rewrite /= !inE  !mem_rcons !inE  !eqxx !orbT /= => /(_ isT isT).
+  move=> /below_altC/no_crossingE.
+  have := outlefte c' cin => /eqP ->.
+  rewrite highv eunh => [] /(_ isT) [a _].
+  by apply: a.
+have nc' : {in  (rcons (c'::q) high_e) &, no_crossing R}.
+  move => e1 e2 e1in e2in.
+  apply nc.
+    by rewrite inE e1in orbT.
+  by rewrite inE e2in orbT.
+rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+have := pvertE lowv; set low_p := Bpt _ _ => lp.
+rewrite lp.
+have := intersection_on_edge lp=> [][] poel lx_eq.
+case oca_eq : (opening_cells_aux _ _ _ _) => [so co].
+rewrite -[pt_eqb _ _ (point e) low_p]/(point e == low_p :> pt).
+case : ifP=> [/eqP <-/=|/= _].
+  rewrite inE => /orP  [/eqP -> /=|].
+    by rewrite lexePt_refl.
+  have := IH c' einfc' c'v outq nc' c'infh.
+  by rewrite oca_eq.
+rewrite inE => /orP  [/eqP -> /=|].
+  have : p_y low_p <= p_y (point e).
+    by rewrite leNgt -(strict_under_edge_lower_y lx_eq poel).
+  rewrite /lexePt lx_eq eqxx=> ->.
+  by rewrite orbT.
+have := IH c' einfc' c'v outq nc' c'infh.
+by rewrite oca_eq.
+Qed.
+
+Arguments pt_eqb : simpl never.
+
+Lemma opening_cells_aux_side_limit e s le he s' c':
+  valid_edge le e -> valid_edge he e ->
+  e >>= le -> e <<< he ->
+  {in s, forall g, left_pt g == e} ->
+  opening_cells_aux e s le he = (s', c') ->
+  all open_cell_side_limit_ok (rcons s' c').
+Proof.
+move=> + vh.
+elim : s le s' c'=> [ | g s Ih] le s' c' /= vl above under lg.
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  rewrite -[generic_trajectories.vertical_intersection_point
+             _ _ _ _ _ _ _ _ _ _ _]/(vertical_intersection_point _ _).
+  have := pvertE vl; set p1 := Bpt _ _ => /[dup] vip1 ->.
+  have := pvertE vh; set p2 := Bpt _ _ => /[dup] vip2 ->.
+  rewrite /open_cell_side_limit_ok => -[] <- <- /=.
+  have [v1 on1 x1] : [/\ valid_edge le p1, p1 === le & p_x e = p_x p1].
+    by have [on1 xp] := intersection_on_edge vip1.
+  have [v2 on2 x2] : [/\ valid_edge he p2, p2 === he & p_x e = p_x p2].
+    by have [on2 xp] := intersection_on_edge vip2.
+  have p2ne : p2 != e :> pt.
+    apply/eqP=> A; have := strict_under_edge_lower_y x2 on2.
+    by rewrite under => /esym; rewrite ltNge A lexx.
+  rewrite -[pt_eqb _ _ p2 e]/(p2 == e :> pt).
+  rewrite -[pt_eqb _ _ e p1]/(e == p1 :> pt).
+  rewrite (negbTE p2ne); case: ifP => [p1ise | p1ne] /=;
+    move: on1 on2; rewrite ?(eqP p2ise) -?(eqP p1ise) => on1 on2;
+    rewrite ?eqxx ?on1 ?on2 ?(eqP p2ise) -?(eqP p1ise) -?x1 -?x2
+        ?eqxx ?andbT //=.
+    have euh : e <<= he by apply: underW.
+    rewrite lt_neqAle.
+    have tmp:= (under_edge_lower_y x2 on2).
+    rewrite (eqP p1ise) /p1 /p2 /= in tmp; rewrite -tmp {tmp}.
+    rewrite -/p1 -(eqP p1ise) euh andbT.
+    apply/negP=> A; case/negP: p2ne; rewrite pt_eqE (eqP p1ise) /=.
+    by rewrite (eqP A) !eqxx.
+  rewrite -(strict_under_edge_lower_y x2 on2) under /=.
+  rewrite ltNge le_eqVlt negb_or.
+  rewrite -(strict_under_edge_lower_y x1 on1) above andbT.
+  by apply/negP=> A;case/negbT/negP:p1ne; rewrite pt_eqE -?x1 (eqP A) !eqxx.
+have /eqP lgg : left_pt g == e by apply: lg; rewrite inE eqxx.
+rewrite 
+ -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+have := pvertE vl; set p1 := Bpt _ _ => /[dup] vip1 ->.
+have [v1 on1 x1] : [/\ valid_edge le p1, p1 === le & p_x e = p_x p1].
+  by have [on1 xp] := intersection_on_edge vip1.
+have eong : e === g by rewrite -(eqP (lg g _)) ?inE ?eqxx // left_on_edge.
+case oca_eq : (opening_cells_aux _ _ _ _) => [so co] [] <- <-.
+rewrite /=; apply/andP; split.
+  rewrite /open_cell_side_limit_ok.
+  rewrite -[pt_eqb _ _ e p1]/(e == p1 :> pt).
+  case: ifP=> [eisp1 | enp1] /=;
+    rewrite -?x1 !eqxx on1 -?(eqP eisp1) ?eong ?andbT //=.
+  rewrite ltNge le_eqVlt negb_or.
+  rewrite -(strict_under_edge_lower_y x1 on1) above andbT.
+  by apply/negP=> A; case/negP: enp1; rewrite pt_eqE (eqP A) x1 ?eqxx.
+apply/allP=> c cintl.
+suff/allP/(_ c cintl) : all open_cell_side_limit_ok (rcons so co) by [].
+apply: (Ih g) => //.
+- by apply: valid_edge_extremities; rewrite lg ?inE ?eqxx.
+- by apply: onAbove.
+by move: lg; apply: sub_in1 => g' gin; rewrite inE gin orbT.
+Qed.
+
+Lemma opening_cells_side_limit e s le he :
+  valid_edge le e -> valid_edge he e ->
+  e >>= le -> e <<< he ->
+  {in s, forall g, left_pt g == e} ->
+  all open_cell_side_limit_ok (opening_cells e s le he).
+Proof.
+move=> vle vhe ea eu lefts.
+have lefts' : {in sort (@edge_below _) s, forall g, left_pt g == e}.
+  by move=> g; rewrite mem_sort; apply: lefts.
+have := opening_cells_aux_side_limit vle vhe ea eu lefts'.
+rewrite /opening_cells.
+case oca_eq : (opening_cells_aux _ _ _ _) => [so co].
+by apply.
+Qed.
+
+Lemma fan_edge_below_trans (s : seq edge) p :
+  {in s, forall g, left_pt g == p} ->
+  {in s & &, transitive (@edge_below R)}.
+Proof.
+move=> lcnd g1 g2 g3 g1in g2in g3in.
+by apply: trans_edge_below_out (eqP (lcnd _ _))(eqP (lcnd _ _))(eqP (lcnd _ _)).
+Qed.
+
+Lemma opening_cells_pairwise' e le he :
+   point e >>> le ->
+   point e <<< he ->
+   out_left_event e ->
+   {in le :: he :: outgoing e &, no_crossing R} ->
+   valid_edge le (point e) ->
+   valid_edge he (point e) ->
+   pairwise (@edge_below _)
+         [seq high x | x <- (opening_cells (point e) (outgoing e) le he)].
+Proof.
+move=> pal puh oute noc vle vhe; rewrite /opening_cells.
+have oute' := outleft_event_sort oute.
+have lein : le \in le :: he :: sort (@edge_below _) (outgoing e) by subset_tac.
+have hein : he \in le :: he :: sort (@edge_below _) (outgoing e) by subset_tac.
+have subo' : {subset sort (@edge_below _) (outgoing e) <=
+   le :: he :: sort (@edge_below _) (outgoing e)} by subset_tac.
+have sub' : (le :: he :: sort (@edge_below _) (outgoing e)) =i (le :: he :: (outgoing e)).
+  by move=> g; rewrite !inE mem_sort.
+have noc' : {in le :: he :: sort (@edge_below _) (outgoing e) &, no_crossing R}.
+  by move=> g1 g2; rewrite !sub'; apply: noc.
+case oca_eq : opening_cells_aux => [s' c].
+rewrite pairwise_map pairwise_rcons -pairwise_map /=.
+have [_ it _]:= outgoing_conditions pal puh lein hein vle vhe subo' noc' oute'.
+have := opening_cells_aux_high vle vhe oute'; rewrite oca_eq /= => highsq.
+ apply/andP; split.
+  rewrite [X in is_true X]
+     (_ : _ = all (fun x => x <| high c) [seq high x | x <- s']); last first.
+    by rewrite all_map.
+  have := opening_cells_aux_high_last vle vhe oute'; rewrite oca_eq /= => ->.
+  by rewrite highsq; apply/allP.
+rewrite highsq.
+have loc_trans : {in sort (@edge_below _) (outgoing e) & &,
+ transitive (@edge_below _)}.
+  by apply: (@fan_edge_below_trans _ (point e)).
+have /sort_edge_below_sorted : {in outgoing e &, no_crossing _}.
+  by move=> x y xin yin; apply: noc; subset_tac.
+by rewrite (sorted_pairwise_in loc_trans (allss _)).
+Qed.
+
+Lemma opening_cells_contains_point e le he nos:
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  point e >>> le ->
+  point e <<< he ->
+  out_left_event e ->
+  opening_cells (point e) (outgoing e) le he = nos ->
+  {in nos, forall c, contains_point (point e) c}.
+Proof.
+move=> vle vhe pal puh oute oceq.
+have oute' := outleft_event_sort oute.
+have := opening_cells_aux_subset vle vhe oute'.
+move: oceq; rewrite /opening_cells.
+case oca_eq : (opening_cells_aux _ _ _ _)=> [nos' lno'] <- /(_ _ _ _ erefl).
+move=> main x xin; rewrite contains_pointE.
+move: (main x xin); rewrite !inE=> /andP[] lows highs.
+apply/andP; split.
+  move: lows=> /orP[/eqP -> | /oute'/eqP <-]; first by rewrite underWC.
+  by rewrite left_pt_above.
+move: highs=> /orP[/eqP -> | /oute'/eqP <-]; first by rewrite underW.
+by rewrite left_pt_below.
+Qed.
+
+Lemma opening_cells_last_left_pts e le he :
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  out_left_event e ->
+  outgoing e != nil ->
+  point e <<< he ->
+  left_pts (opening_cells_aux (point e) (sort (@edge_below _) (outgoing e))
+     le he).2
+ = Bpt (p_x (point e)) (pvert_y (point e) he) :: point e :: nil.
+Proof.
+move=> vle vhe oute onn puh.
+have oute' := outleft_event_sort oute.
+have puh' : p_y (point e) < pvert_y (point e) he.
+  by rewrite -strict_under_pvert_y.
+have pdif : Bpt (p_x (point e)) (pvert_y (point e) he) != point e :> pt.
+  rewrite pt_eqE negb_and /=; apply/orP; right; rewrite eq_sym.
+  by move: puh'; rewrite lt_neqAle => /andP[] ->.
+case ogeq : (sort _ (outgoing e)) (mem_sort (@edge_below _) (outgoing e)) =>
+  [ | fog ogs] // .
+  move=> abs; case ogeq' : (outgoing e) onn => [ | f q] //=.
+  by suff : f \in [::];[rewrite in_nil | rewrite abs ogeq' inE eqxx].
+move=> elems.
+have lf : left_pt fog = point e.
+  by move: oute'; rewrite ogeq=> oute2; apply/eqP/oute2; rewrite inE eqxx.
+have vf : valid_edge fog (point e) by rewrite valid_edge_extremities // lf eqxx.
+rewrite opening_cells_aux_eqn.
+rewrite /= pvertE //.
+have : {subset ogs <= outgoing e} by move=> x xin; rewrite -elems inE xin orbT.
+move: (fog) lf vf {ogeq elems}.
+elim : (ogs) le {vle} => [ | f q Ih] //= => le fog1 lfog1 vf1 qsubo.
+  rewrite
+   -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+  rewrite
+    -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+  rewrite pvertE // pvertE //=.
+  rewrite -[pt_eqb _ _ _ (point e)]/(_ == point e :> pt).
+  rewrite (negbTE pdif).
+  have -> : pvert_y (point e) fog1 = p_y (point e).
+     by apply on_pvert; rewrite -lfog1 left_on_edge.
+  rewrite -[pt_eqb _ _ (point e) _]/(point e == _ :> pt).
+  rewrite pt_eqE /= !eqxx /=; congr (_ :: _ :: _); apply/(@eqP pt).
+  by rewrite pt_eqE /= !eqxx.
+case oca_eq: (opening_cells_aux _ _ _ _) => [s c].
+rewrite
+ -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+rewrite pvertE //=.
+have lfq : left_pt f = point e.
+  by apply/eqP/oute'; rewrite mem_sort qsubo // inE eqxx.
+have vf : valid_edge f (point e).
+  by apply: valid_edge_extremities; rewrite lfq eqxx.
+have qsub : {subset q <= outgoing e}.
+  by move=> x xin; apply: qsubo; rewrite inE xin orbT.
+by have := Ih le f lfq vf qsub; rewrite oca_eq /=.
+Qed.
+
+Lemma opening_cells_aux_absurd_case e le he (s : seq edge) :
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  s != [::] ->
+  {in s, forall g, left_pt g == point e} ->
+   (opening_cells_aux (point e) (sort (@edge_below _) s) le he).1 != [::].
+Proof.
+move=> vle vhe + outs; case sq : s => [ // | a s'] _.
+case ssq : (sort (@edge_below _) s) => [ | b s2].
+  by suff : a \in [::];[ | rewrite -ssq mem_sort sq inE eqxx].
+rewrite opening_cells_aux_eqn.
+rewrite -sq ssq /= pvertE //.
+by case oca_eq : (opening_cells_aux _ _ _ _).
+Qed.
+
+(* TODO : complain that there is no sort_eq0 lemma with statement
+   (sort r l == [::]) = (l == [::]) *)
+
+Lemma opening_cells_1 e le he:
+  outgoing e != [::] ->
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  out_left_event e ->
+  exists fno nos lno, opening_cells (point e) (outgoing e) le he =
+       fno :: rcons nos lno.
+Proof.
+move=> ogn vle vhe oute.
+rewrite /opening_cells.
+have := opening_cells_aux_absurd_case vle vhe ogn oute.
+set x := (opening_cells_aux _ _ _ _).
+case x => [ [ | fno nos] lno] // _.
+by exists fno, nos, lno.
+Qed.
+
+Lemma opening_cells_in p' s le he :
+  valid_edge le p' -> valid_edge he p' ->
+  {in s, forall g, left_pt g == p'} ->
+  {in opening_cells p' s le he, forall c, p' \in (left_pts c : seq pt)}.
+Proof.
+move=> + vhe outp.
+rewrite /opening_cells.
+have {outp} : {in sort (@edge_below _) s, forall g, left_pt g == p'}.
+  by move=> g; rewrite mem_sort; apply: outp.
+elim: (sort _ _) le => [ | g gs Ih] le.
+  move=> _ /= vle g.
+  rewrite
+   -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+  rewrite
+   -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+  rewrite (pvertE vle) (pvertE vhe) !inE => /eqP ->.
+  do 2 rewrite -[pt_eqb _ _ _ _]/(_ == _ :> pt).
+  case: ifP=> []; case: ifP=> [] /=.
+        move=> /eqP -> // /eqP <-.
+        by rewrite (@mem_head pt).
+      by rewrite (@mem_head pt).
+    move=> /eqP <-; rewrite (@in_cons pt).
+    by rewrite (@mem_head pt) orbT.
+    (* was by move=> /eqP <-; rewrite !inE eqxx orbT. *)
+  by rewrite (@in_cons pt) (@mem_head pt) orbT.
+move=> outp vl.
+have lgq : left_pt g = p' by apply/eqP; apply: (outp _ (mem_head _ _)).
+have vg : valid_edge g p' by rewrite -lgq valid_edge_left.
+have {}outp : {in gs, forall g, left_pt g == p'}.
+  by move=> g' gin; apply: outp; rewrite inE gin orbT.
+have {}Ih := Ih g outp vg.
+rewrite /=.
+rewrite
+ -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+rewrite /= (pvertE vl); case oca_eq : (opening_cells_aux _ _ _ _)=> [nos lno].
+move: Ih; rewrite oca_eq /= => Ih.
+move=> c; rewrite inE=> /orP[/eqP -> /= |]; last by apply: Ih.
+case: ifP; last by rewrite (@mem_head pt).
+rewrite -[pt_eqb _ _ _ _]/(_ == _ :> pt).
+by move=> /eqP <-; rewrite (@mem_head pt).
+Qed.
+
+Lemma last_opening_cells_left_pts_prefix e le he nos lno :
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  point e <<< he ->
+  out_left_event e ->
+  opening_cells_aux (point e) (sort (@edge_below _) (outgoing e)) le he =
+    (nos, lno) ->
+  (1 < size (left_pts lno))%N  /\
+  take 2 (left_pts lno) =
+    [:: Bpt (p_x (point e)) (pvert_y (point e) he); (point e)] .
+Proof.
+move=> + vh puh oute.
+have := outleft_event_sort oute.
+elim: (sort _ _) nos lno le => [ | g s Ih] nos lno le /= oute' vl.
+  do 2 rewrite -/(vertical_intersection_point _ _).
+  rewrite (pvertE vl) (pvertE vh) => -[nosq lnoq].
+  rewrite -lnoq /=.
+  rewrite -/(_ == point e) -/(point e == _).
+  set ph := (X in X == point e); set pl := (X in point e == X).
+  rewrite -/ph -/pl.
+  have /negbTE -> : ph != point e.
+    rewrite pt_eqE negb_and /ph /= eqxx /=.
+    move: puh.
+    by rewrite (strict_under_pvert_y vh) lt_neqAle eq_sym=> /andP[].
+  split; first by case: (_ == _).
+  by have [-> | enqpl] := eqVneq (point e) pl.
+rewrite -/(vertical_intersection_point _ _).
+rewrite (pvertE vl).
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos1 lno1] [_ <-].
+have oute1 : forall ed, ed \in s -> left_pt ed == point e.
+  by move=> ed edin; apply: oute'; rewrite inE edin orbT.
+have vg : valid_edge g (point e).
+  by rewrite -(eqP (oute' g _)) ?valid_edge_left // inE eqxx.
+by apply: (Ih nos1 lno1 g oute1 vg oca_eq).
+Qed.
+
+Lemma last_opening_cells_safe_side_char e le he pp nos lno :
+  outgoing e != [::] ->
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  point e <<< he ->
+  out_left_event e ->
+  opening_cells (point e) (outgoing e) le he = rcons nos lno ->
+  in_safe_side_left pp lno =
+   [&& p_x pp == p_x (point e), p_y (point e) < p_y pp & pp <<< he].
+Proof.
+move=> ogn0 vle vhe puh oute oeq.
+have oute' := outleft_event_sort oute.
+have oca_eq:
+  (opening_cells_aux (point e) (sort (@edge_below _) (outgoing e)) le he) =
+ (nos, lno).
+  move: oeq; rewrite /opening_cells; case: (opening_cells_aux _ _ _ _)=> [a b].
+  by move/eqP; rewrite eqseq_rcons=> /andP[] /eqP -> /eqP ->.
+have lnoin : lno \in opening_cells (point e) (outgoing e) le he.
+  by rewrite oeq mem_rcons mem_head.
+rewrite /in_safe_side_left.
+have := opening_cells_left oute vle vhe lnoin=> ->.
+have [/eqP samex /= | ] := boolP (p_x pp == p_x (point e)); last by [].
+have highlno : high lno = he.
+  by have := opening_cells_aux_high_last vle vhe oute'; rewrite oca_eq.
+rewrite highlno [in RHS]andbC.
+have := opening_cells_1 ogn0 vle vhe oute => -[fno [nos' [lno' oeq']]].
+have [nosq lnoq] : nos = fno :: nos' /\ lno = lno'.
+  move: oeq'; rewrite oeq -[fno :: rcons _ _]/(rcons (fno :: _) _) => /eqP.
+  by rewrite eqseq_rcons => /andP[] /eqP -> /eqP ->.
+have llnoq : low lno = high (last fno nos').
+  have := adjacent_opening vle vhe oute; rewrite oeq'.
+  rewrite /= -cats1 cat_path=> /andP[] _ /=.
+  by rewrite andbT lnoq eq_sym=> /eqP.
+have /oute lfnoq : high (last fno nos') \in outgoing e.
+  have := opening_cells_high vle vhe oute; rewrite oeq'.
+  have := size_sort (@edge_below _) (outgoing e).
+(* TODO : should use some lemma here *)
+  rewrite -(mem_sort (@edge_below _)); case: (sort _ _) => [ | w w'] //=.
+    by move=>/eqP; rewrite eq_sym size_eq0 (negbTE ogn0).
+  move=> _ [] <-; rewrite map_rcons=> /eqP.
+  rewrite eqseq_rcons => /andP[] /eqP <- _.
+  by elim/last_ind: (nos') => [ | ? ? _];
+rewrite ?mem_head // last_rcons inE map_rcons mem_rcons mem_head orbT.
+have eonl : point e === low lno by rewrite llnoq -(eqP lfnoq) left_on_edge.
+have ppal : (pp >>> low lno) = (p_y (point e) < p_y pp).
+  have := under_edge_lower_y samex eonl => ->.
+  by rewrite -ltNge.
+rewrite ppal.
+have := opening_cells_last_left_pts vle vhe oute ogn0 puh.
+rewrite oca_eq /= => ->.
+have [ppuh /= | ] := boolP (pp <<< he); last by [].
+have [ppae /= | ] := boolP (p_y (point e) < p_y pp); last by [].
+rewrite !(@in_cons pt) !pt_eqE /=.
+have vpphe : valid_edge he pp by rewrite (same_x_valid _ samex).
+rewrite -(same_pvert_y vpphe samex).
+move: ppuh; rewrite (strict_under_pvert_y vpphe) lt_neqAle=> /andP[].
+move=> /negbTE -> _.
+move: ppae; rewrite lt_neqAle eq_sym=> /andP[] /negbTE -> _.
+by rewrite !andbF.
+Qed.
+
+Lemma opening_cells_first_left_pts e le he :
+  valid_edge le (point e) ->
+  outgoing e != nil ->
+  point e >>> le ->
+  left_pts 
+     (head dummy_cell
+     (opening_cells_aux (point e) (sort (@edge_below _) (outgoing e))
+     le he).1)
+ = point e :: Bpt (p_x (point e)) (pvert_y (point e) le) :: nil.
+Proof.
+move=> vle onn pal.
+set W := sort _ _.
+have sgt0 : (0 < size W)%N by rewrite /W size_sort; case : (outgoing e) onn.
+case Wq : W sgt0 => [ // | g1 gs'] _ /=.
+case oca_eq : (opening_cells_aux _ _ _ _) => [nos lno].
+rewrite 
+ -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+rewrite pvertE //=.
+rewrite -[pt_eqb _ _ _ _]/(_ == _ :> pt).
+case: ifP=> // samept.
+have := pvert_on vle; rewrite -(eqP samept) => onle.
+have /andP[/eqP pf _] := onle.
+by move: pal; rewrite underE pf le_eqVlt eqxx.
+Qed.
+
+Lemma first_opening_cells_side_char e le he pp fno nos lno :
+  outgoing e != [::] ->
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  point e >>> le ->
+  out_left_event e ->
+  opening_cells (point e) (outgoing e) le he = rcons (fno :: nos) lno ->
+  in_safe_side_left pp fno =
+   [&& p_x pp == p_x (point e), p_y pp  < p_y (point e) & pp >>> le].
+Proof.
+move=> ogn0 vle vhe pal oute oeq.
+have oute' := outleft_event_sort oute.
+have oca_eq:
+  (opening_cells_aux (point e) (sort (@edge_below _) (outgoing e)) le he) =
+ ((fno :: nos), lno).
+  move: oeq; rewrite /opening_cells; case: (opening_cells_aux _ _ _ _)=> [a b].
+  by move/eqP; rewrite eqseq_rcons=> /andP[] /eqP -> /eqP ->.
+have fnoin : fno \in opening_cells (point e) (outgoing e) le he.
+  by rewrite oeq mem_rcons !inE eqxx orbT.
+rewrite /in_safe_side_left.
+have := opening_cells_left oute vle vhe fnoin=> ->.
+have [/eqP samex /= | ] := boolP (p_x pp == p_x (point e)); last by [].
+have lowfno : low fno = le.
+  by rewrite (lower_edge_new_cells vle vhe oeq).
+rewrite lowfno.
+have /oute hfnoq : high fno \in outgoing e.
+  have := opening_cells_high vle vhe oute; rewrite oeq /=.
+  have := size_sort (@edge_below _) (outgoing e).
+(* TODO : should use some lemma here *)
+  rewrite -(mem_sort (@edge_below _)); case: (sort _ _) => [ | w w'] //=.
+    by move=>/eqP; rewrite eq_sym size_eq0 (negbTE ogn0).
+  move=> _ [] <-; rewrite map_rcons=> /eqP.
+  rewrite eqseq_rcons => /andP[] /eqP <- _.
+  by rewrite mem_head.
+have eonh : point e === high fno by rewrite -(eqP hfnoq) left_on_edge.
+have ppue : (pp <<< high fno) = (p_y pp < p_y (point e)).
+  by have := strict_under_edge_lower_y samex eonh.
+rewrite ppue.
+have := opening_cells_first_left_pts he vle ogn0 pal.
+rewrite oca_eq /= => ->.
+have [{}ppue /= | ] := boolP (p_y pp < p_y (point e)); last by [].
+have [ppal /= | ] := boolP (pp >>> le); last by [].
+rewrite !(@in_cons pt) !pt_eqE.
+have vpple : valid_edge le pp by rewrite (same_x_valid _ samex).
+rewrite -(same_pvert_y vpple samex).
+move: ppal; rewrite (under_pvert_y vpple) le_eqVlt negb_or=> /andP[].
+move=> /negbTE -> _.
+move: ppue; rewrite lt_neqAle=> /andP[] /negbTE -> _.
+by rewrite !andbF.
+Qed.
+
+Lemma middle_opening_cells_side_char e le he pp fno nos lno :
+  outgoing e != [::] ->
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  out_left_event e ->
+  opening_cells (point e) (outgoing e) le he = rcons (fno :: nos) lno ->
+  ~~ has (in_safe_side_left pp) nos.
+Proof.
+move=> ogn0 vle vhe oute oeq.
+have oute' := outleft_event_sort oute.
+have oca_eq:
+  (opening_cells_aux (point e) (sort (@edge_below _) (outgoing e)) le he) =
+ ((fno :: nos), lno).
+  move: oeq; rewrite /opening_cells; case: (opening_cells_aux _ _ _ _)=> [a b].
+  by move/eqP; rewrite eqseq_rcons=> /andP[] /eqP -> /eqP ->.
+rewrite -all_predC; apply/allP=> c cino /=.
+have cin : c \in opening_cells (point e) (outgoing e) le he.
+  by rewrite oeq mem_rcons !(inE, mem_cat) cino !orbT.
+rewrite /in_safe_side_left.
+have := opening_cells_left oute vle vhe cin=> ->.
+have [samex /= | ] := boolP (p_x pp == p_x (point e)); last by [].
+have /oute hc : high c \in outgoing e.
+  have := opening_cells_high vle vhe oute; rewrite oeq /=.
+  have := size_sort (@edge_below _) (outgoing e).
+(* TODO : should use some lemma here *)
+  rewrite -(mem_sort (@edge_below _)); case: (sort _ _) => [ | w w'] //=.
+    by move=>/eqP; rewrite eq_sym size_eq0 (negbTE ogn0).
+  move=> _ [] <-; rewrite map_rcons=> /eqP.
+  rewrite eqseq_rcons => /andP[] /eqP <- _.
+  by rewrite inE map_f ?orbT.
+have /oute lc : low c \in outgoing e.
+  have := opening_cells_high vle vhe oute; rewrite oeq /=.
+  have /= := opening_cells_seq_edge_shift oute' vle vhe oca_eq.
+  move=> [] _ -> /eqP; rewrite eqseq_rcons=> /andP[] /eqP + _.
+  rewrite -(mem_sort (@edge_below _)) => <-.
+  by rewrite map_f // mem_rcons inE cino orbT.
+have eonh : point e === high c by rewrite -(eqP hc) left_on_edge.
+have eonl : point e === low c by rewrite -(eqP lc) left_on_edge.
+have := strict_under_edge_lower_y (eqP samex) eonh=> ->.
+have := under_edge_lower_y (eqP samex) eonl=> ->.
+by rewrite le_eqVlt negb_or -!andbA andbCA; case: (_ < _); rewrite !andbF.
+Qed.
+
+Lemma single_opening_cell_side_char e le he pp :
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  point e >>> le ->
+  point e <<< he ->
+  outgoing e = [::] ->
+  has (in_safe_side_left pp) (opening_cells (point e) (outgoing e) le he) =
+  ([&& p_x pp == p_x (point e), pp >>> le & p_y pp < p_y (point e)] ||
+   [&& p_x pp == p_x (point e), pp <<< he & p_y (point e) < p_y pp]).
+Proof.
+move=> vle vhe pal puh og0.
+have oute : out_left_event e by move=> g; rewrite og0 in_nil.
+have [ppe | ppne] := eqVneq (pp : pt) (point e).
+  rewrite ppe !lt_irreflexive !andbF.
+  apply /negbTE; rewrite -all_predC; apply/allP=> c cin /=.
+  have einl := opening_cells_in vle vhe oute cin.
+  by rewrite /in_safe_side_left einl !andbF.
+have := opening_cells_left oute vle vhe.
+rewrite og0 /opening_cells /=.
+do 2 rewrite
+ -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+rewrite (pvertE vle) (pvertE vhe) /= orbF.
+set c := Bcell _ _ _ _.
+move=> /(_ _ (mem_head _ _)).
+rewrite /in_safe_side_left /= => ->.
+have [/eqP samex /= | ] := boolP (p_x pp == p_x (point e)); last by [].
+rewrite andbCA.
+have puhy : p_y (point e) < pvert_y (point e) he.
+  by rewrite -(strict_under_pvert_y vhe).
+have paly :  pvert_y (point e) le < p_y (point e).
+  by rewrite ltNge -(under_pvert_y vle).
+do 2 rewrite -[pt_eqb _ _ _ _]/(_ == _ :> pt).
+rewrite !pt_eqE /= eqxx /=.
+move: (puhy); rewrite lt_neqAle eq_sym=> /andP[] /negbTE -> _.
+move: (paly); rewrite lt_neqAle eq_sym=> /andP[] /negbTE -> _.
+have vpple : valid_edge le pp by rewrite (same_x_valid _ samex).
+have vpphe : valid_edge he pp by rewrite (same_x_valid _ samex).
+
+have [ | pa] := lerP (p_y pp) (p_y (point e)); rewrite ?(andbF, orbF).
+  rewrite le_eqVlt => /orP[/eqP samey | /[dup] pu ->].
+    by case/negP: ppne; rewrite pt_eqE samex samey !eqxx.
+  have [ppale | _] := boolP (pp >>> le); last by [].
+  have -> : pp <<< he.
+    rewrite (strict_under_pvert_y vpphe).
+    rewrite (same_pvert_y vpphe samex).
+    by apply: (lt_trans pu); rewrite -(strict_under_pvert_y vhe).
+  rewrite /=.
+  have ppaly :  pvert_y (point e) le < p_y pp.
+    rewrite -(same_pvert_y vpple samex).
+    by rewrite ltNge -(under_pvert_y vpple).
+  rewrite !(@in_cons pt).
+  rewrite (negbTE ppne) !pt_eqE /=.
+  move: ppaly; rewrite lt_neqAle eq_sym=> /andP[] /negbTE -> _.
+  have ppuhy : p_y pp < pvert_y (point e) he.
+    by apply: (lt_trans pu).
+  move: ppuhy; rewrite lt_neqAle => /andP[] /negbTE -> _.
+  by rewrite !andbF.
+move=> {c}.
+rewrite ltNge le_eqVlt pa orbT andbF andbT /=.
+have [ppuhe | _] := boolP (pp <<< he); last by rewrite andbF.
+have ppale : pp >>> le.
+  rewrite (under_pvert_y vpple).
+  rewrite (same_pvert_y vpple samex) -ltNge.
+  by apply: (lt_trans _ pa); rewrite ltNge -(under_pvert_y vle).
+rewrite /=.
+have ppaly :  pvert_y (point e) le < p_y pp.
+  rewrite -(same_pvert_y vpple samex).
+  by rewrite ltNge -(under_pvert_y vpple).
+rewrite !(@in_cons pt) (negbTE ppne) !pt_eqE /=.
+move: ppaly; rewrite lt_neqAle eq_sym=> /andP[] /negbTE -> _.
+have ppuhy : p_y pp < pvert_y (point e) he.
+  rewrite -(same_pvert_y vpphe samex).
+  by rewrite -(strict_under_pvert_y vpphe).
+ move: ppuhy; rewrite lt_neqAle => /andP[] /negbTE -> _.
+by rewrite ppale !andbF.
+Qed.
+
+Lemma opening_cells_aux_uniq (q : pt) l g1 g2 r1 r2:
+  uniq l ->
+  g2 \notin l ->
+  {in l, forall g, left_pt g == q} ->
+  valid_edge g1 q ->
+  valid_edge g2 q ->
+  opening_cells_aux q l g1 g2 = (r1, r2) ->
+  uniq (rcons r1 r2).
+Proof.
+move=> ul g2nin ol v1 v2 oca_eq.
+have lg2 := opening_cells_aux_high_last v1 v2 ol.
+have lg1 := opening_cells_aux_high v1 v2 ol.
+apply: (@map_uniq _ _ high).
+rewrite map_rcons rcons_uniq.
+rewrite oca_eq /= in lg2 lg1.
+by rewrite lg2 lg1 g2nin ul.
+Qed.
+
+(* TODO : move to points_and_edges. *)
+Lemma half_point_valid (g : edge) (p1 p2 : pt) :
+  valid_edge g p1 -> valid_edge g p2 ->
+  valid_edge g (Bpt ((p_x p1 + p_x p2) / 2) ((p_y p1 + p_y p2) / 2)).
+Proof.
+rewrite /valid_edge; move=> /andP[] vp1l vp1r /andP[] vp2l vp2r /=.
+have cst2gt0 : (0 < 2 :> R) by apply: addr_gt0.
+apply/andP; split.
+  rewrite -(ler_pM2r cst2gt0) -mulrA mulVf ?mulr1; last by apply: lt0r_neq0.
+  by rewrite mulrDr !mulr1 lerD.
+rewrite -(ler_pM2r cst2gt0) -mulrA mulVf ?mulr1; last by apply: lt0r_neq0.
+by rewrite mulrDr !mulr1 lerD.
+Qed.
+
+Lemma half_between (x y : R) : x < y -> x < (x + y) / 2 < y.
+Proof.
+move=> xy.
+have cst2gt0 : (0 < 2 :> R) by apply: addr_gt0.
+apply/andP; split.
+  rewrite -(ltr_pM2r cst2gt0) -mulrA mulVf ?mulr1; last by apply: lt0r_neq0.
+  by rewrite mulrDr !mulr1 ler_ltD.
+rewrite -(ltr_pM2r cst2gt0) -mulrA mulVf ?mulr1; last by apply: lt0r_neq0.
+by rewrite mulrDr !mulr1 ltr_leD.
+Qed.
+
+Lemma half_between_edges (g1 g2 : edge) p :
+  valid_edge g1 p -> valid_edge g2 p -> p >>= g1 -> p <<< g2 ->
+  (Bpt (p_x p) ((pvert_y p g1 + pvert_y p g2) / 2)) >>> g1 /\
+  (Bpt (p_x p) ((pvert_y p g1 + pvert_y p g2) / 2)) <<< g2.
+Proof.
+move=> vg1 vg2 pal puh; set p1 := Bpt _ _.
+have samex : p_x p1 = p_x p by [].
+have v1g1 : valid_edge g1 p1 by rewrite (same_x_valid _ samex).
+have v1g2 : valid_edge g2 p1 by rewrite (same_x_valid _ samex).
+rewrite (under_pvert_y v1g1) (strict_under_pvert_y v1g2) -ltNge; apply/andP.
+apply: half_between.
+have := puh; rewrite (strict_under_pvert_y vg2); apply: le_lt_trans.
+by rewrite leNgt -(strict_under_pvert_y vg1).
+Qed.
+
+Lemma opening_cells_non_empty e le he:
+  valid_edge le (point e) ->
+  valid_edge he (point e) ->
+  point e >>> le ->
+  point e <<< he ->
+  out_left_event e ->
+  uniq (outgoing e) ->
+  {in [:: le, he & outgoing e] &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in opening_cells (point e) (outgoing e) le he, forall c p,
+     valid_edge (low c) p -> valid_edge (high c) p ->
+     p_x (point e) < p_x p ->
+     exists q, [&& q >>> low (close_cell p c), q <<< high (close_cell p c)&
+                 left_limit (close_cell p c) < p_x q < 
+                 right_limit (close_cell p c)]}.
+Proof.
+move=> vle vhe pal puh oute une noc.
+rewrite /opening_cells.
+have : {subset le :: sort (@edge_below _) (outgoing e) <=
+               [:: le, he & outgoing e]}.
+  move=> g; rewrite inE mem_sort=> /orP[/eqP -> | ]; first by subset_tac.
+  by move=> gin; rewrite !inE gin !orbT.
+have := outleft_event_sort oute.
+have : sorted (@edge_below _) (le :: (sort (@edge_below _) (outgoing e))).
+  by apply: (sorted_outgoing vle vhe _ _ _ (inter_at_ext_no_crossing noc)).
+have : uniq (le :: sort (@edge_below _) (outgoing e)).
+  rewrite /= sort_uniq une andbT.
+  rewrite mem_sort; apply/negP=> /oute /eqP abs.
+  by move: pal; rewrite under_onVstrict // -abs left_on_edge.
+elim: (sort _ _) {-6} (le) vle (underWC pal)=> [ | g1 gs Ih] le' vle' pale'.
+  move=> _ _ _ sub0.
+rewrite opening_cells_aux_eqn.
+  rewrite /= (pvertE vle') (pvertE vhe) /=.
+  set c0 := (X in [:: X])=> ?; rewrite inE => /eqP -> p vlp vhp pxgt.
+  (* point p0 has no guarantee concerning the vertical position. *)
+  set p0 := Bpt ((p_x (point e) + p_x p) / 2) ((p_x (point e) + p_x p) / 2).
+  have vlp0 : valid_edge le' p0 by apply: half_point_valid.
+  set p1 := Bpt (p_x p0)(pvert_y p0 le').
+  have vlp1 : valid_edge le' p1 by apply: half_point_valid.
+  have vhp1 : valid_edge he p1 by apply: half_point_valid.
+  have p1onle' : p1 === le' by apply: (pvert_on vlp0).
+  have hein : he \in [:: le, he & outgoing e] by subset_tac.
+  have le'in : le' \in [:: le, he & outgoing e] by apply: sub0; subset_tac.
+  have ba' : inter_at_ext le' he by apply: noc.
+  have ba : below_alt le' he by apply: (inter_at_ext_no_crossing noc).
+  have le'bhe : le' <| he.
+    by apply: (edge_below_from_point_above ba vle' vhe).
+  have p1uh : p1 <<< he.
+    have p1ule' : p1 <<= le' by rewrite (under_onVstrict vlp1) p1onle'.
+    have : p1 <<= he by apply: (order_edges_viz_point' vlp1).
+    rewrite (under_onVstrict vhp1)=> /orP[p1onhe |]; last by [].
+    case: ba'=> [lqh | ]; first by move: pale'; rewrite lqh puh.
+    move=> /(_ _ p1onle' p1onhe).
+    rewrite !inE=> /orP[] /eqP abs.
+      move: vle'; rewrite /valid_edge=> /andP[] + _; rewrite -abs.
+      rewrite leNgt=> /negP[].
+      by have := half_between pxgt=> /andP[] + _; apply.
+    move: vlp; rewrite /valid_edge=> /andP[] _; rewrite -abs.
+    rewrite leNgt=> /negP[].
+    by have := half_between pxgt=> /andP[] _ +.
+  have p1ale' : p1 >>= le' by rewrite (strict_nonAunder vlp1) p1onle'.
+  have := half_between_edges vlp1 vhp1 p1ale' p1uh.
+  set q := Bpt (p_x p1) ((pvert_y p1 le' + pvert_y p1 he) / 2).
+  move=> []qal quh.  
+  exists q.
+  have [-> -> _] := close_cell_preserve_3sides p c0.
+  rewrite right_limit_close_cell // left_limit_close_cell qal quh.
+  have := half_between pxgt=> /andP[] keepit ->; rewrite andbT /=.
+  rewrite /c0/=.
+  by case: ifP=>[] _; case: ifP=> [] _ /=; rewrite /left_limit /= keepit.
+move=> uns srt out sub /=.
+case oca_eq: opening_cells_aux => [s c].
+rewrite 
+ -[generic_trajectories.vertical_intersection_point _ _ _ _ _ _ _ _ _ _ _]
+   /(vertical_intersection_point _ _).
+rewrite (pvertE vle') /=.
+set c0 := Bcell _ _ _ _ _ _.
+move=> c1; rewrite inE=> /orP[/eqP -> | c1in] p /= vlp vhc pxgt; last first.
+  have lg1 : left_pt g1 = (point e).
+    by have := out _ (mem_head _ _) => /eqP <-.
+  have vg1 : valid_edge g1 (point e) by rewrite -lg1 valid_edge_left.
+  have ag1 : point e >>= g1 by rewrite -lg1 left_pt_above.
+  have out' : forall ed, ed \in gs -> left_pt ed == point e.
+    by move=> ed edin; apply: out; rewrite inE edin orbT.
+  have sub' : {subset g1 :: gs <= [:: le, he & outgoing e]}.
+    by move=> g gin; apply: sub; rewrite inE gin orbT.
+  have c1in' : c1 \in (let (s0, c2) := opening_cells_aux (point e) gs g1 he in
+       rcons s0 c2).
+    by rewrite oca_eq.
+  have srt' : sorted (@edge_below _) (g1 :: gs) by move: srt=> /= /andP[] _.
+  have un' : uniq (g1 :: gs) by move: uns=> /= /andP[].
+  by apply: (Ih g1 vg1 ag1 un' srt' out' sub' _ c1in').
+have [-> -> _] := close_cell_preserve_3sides p c0.
+rewrite right_limit_close_cell // left_limit_close_cell.
+set p0 := Bpt ((p_x (point e) + p_x p) / 2) ((p_x (point e) + p_x p) / 2).
+have vlp0 : valid_edge le' p0 by apply: half_point_valid.
+set p1 := Bpt (p_x p0) (pvert_y p0 le').
+have vlp1 : valid_edge le' p1 by apply: half_point_valid.
+have lg1 : left_pt g1 = point e by apply/eqP/out/mem_head.
+have vg1 : valid_edge g1 (point e) by rewrite -lg1 valid_edge_left.
+have vhp1 : valid_edge g1 p1 by apply: half_point_valid.
+have p1onle' : p1 === le' by apply: (pvert_on vlp0).
+have g1in : g1 \in [:: le, he & outgoing e] by apply: sub; subset_tac.
+have le'in : le' \in [:: le, he & outgoing e] by apply: sub; subset_tac.
+have ba' : inter_at_ext le' g1 by apply: noc.
+have ba : below_alt le' g1 by apply: (inter_at_ext_no_crossing noc).
+have le'bhe : le' <| g1 by move: srt=> /= /andP[].
+have p1ug1 : p1 <<< g1.
+  have p1ule' : p1 <<= le' by rewrite (under_onVstrict vlp1) p1onle'.
+  have : p1 <<= g1.
+    by apply: (order_edges_viz_point' vlp1).
+  rewrite (under_onVstrict vhp1)=> /orP[p1ong1 |]; last by [].
+  case: ba'=> [lqg1 | ]; first by move: uns; rewrite lqg1 /= inE eqxx.
+  move=> /(_ _ p1onle' p1ong1).
+  rewrite !inE=> /orP[] /eqP abs.
+    move: vle'; rewrite /valid_edge=> /andP[] + _; rewrite -abs.
+    rewrite leNgt=> /negP[].
+    by have := half_between pxgt=> /andP[] + _; apply.
+  move: vlp; rewrite /valid_edge=> /andP[] _; rewrite -abs.
+  rewrite leNgt=> /negP[].
+  by have := half_between pxgt=> /andP[] _ +.
+have p1ale' : p1 >>= le' by rewrite (strict_nonAunder vlp1) p1onle'.
+have := half_between_edges vlp1 vhp1 p1ale' p1ug1.
+set q := Bpt (p_x p1) ((pvert_y p1 le' + pvert_y p1 g1) / 2).
+move=> []qal qug1.
+exists q.
+have := half_between pxgt=> /andP[] keepit ->; rewrite andbT /=.
+rewrite /c0/= qal qug1 /=.
+by case: ifP=> [] _ /=; rewrite /left_limit /= keepit.
+Qed.
+
+End opening_cells.
+
+End proof_environment.
+
+End working_environment.
diff --git a/theories/points_and_edges.v b/theories/points_and_edges.v
new file mode 100644
index 0000000..1c19412
--- /dev/null
+++ b/theories/points_and_edges.v
@@ -0,0 +1,2698 @@
+From HB Require Import structures.
+From mathcomp Require Import all_ssreflect all_algebra.
+Require Export Field.
+Require Import math_comp_complements.
+Require Import generic_trajectories.
+
+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.
+
+Section working_context.
+
+Variable (R : realFieldType).
+
+Definition pt := pt R.
+Notation Bpt := (Bpt _).
+Notation "p .x" := (generic_trajectories.p_x _ p)
+    (at level 2, left associativity, format "p .x").
+Notation "p .y" := (generic_trajectories.p_y _ p)
+    (at level 2, left associativity, format "p .y").
+
+Lemma pt_eqP : Equality.axiom (pt_eqb R eq_op).
+Proof.
+rewrite /Equality.axiom.
+move=> [a_x a_y] [b_x b_y]; rewrite /pt_eqb/=.
+have [/eqP <-|/eqP anb] := boolP (a_x == b_x).
+  have [/eqP <- | /eqP anb] := boolP (a_y == b_y).
+    by apply: ReflectT.
+  by apply : ReflectF => [][].
+by apply: ReflectF=> [][].
+Qed.
+
+HB.instance Definition _ := hasDecEq.Build _ pt_eqP.
+
+Lemma pt_eqE (p1 p2 : pt) : (p1 == p2) = (p1.x == p2.x) && (p1.y == p2.y).
+Proof. by move: p1 p2 => [? ?][? ?]. Qed.
+
+Record edge := Bedge {left_pt : pt; right_pt : pt;
+    _ : left_pt.x < right_pt.x}.
+
+Definition edge_eqb (e1 e2 : edge) : bool :=
+   let: Bedge a1 b1 p1 := e1 in
+   let: Bedge a2 b2 p2 := e2 in
+   (a1 == a2) && (b1 == b2).
+
+Lemma edge_cond (e : edge) : (left_pt e).x < (right_pt e).x.
+Proof.  by move: e => [l r c]. Qed.
+
+Lemma edge_eqP : Equality.axiom edge_eqb.
+Proof.
+move=> [a1 b1 p1] [a2 b2 p2] /=.
+have [/eqP a1a2 | /eqP a1na2] := boolP (a1 == a2).
+  have [/eqP b1b2 | /eqP b1nb2] := boolP (b1 == b2).
+     move: p1 p2. rewrite -a1a2 -b1b2 => p1 p2.
+     rewrite (eqtype.bool_irrelevance p1 p2).
+     by apply: ReflectT.
+   by apply: ReflectF=> [][].
+by apply: ReflectF=>[][].
+Qed.
+
+HB.instance Definition _ := hasDecEq.Build _ edge_eqP.
+
+Notation area3 :=
+  (area3 R +%R (fun x y => x - y) *%R).
+
+(* returns true if p is under e *)
+Definition point_under_edge :=
+  point_under_edge R le +%R (fun x y => x - y) *%R 1 edge
+  left_pt right_pt.
+
+Definition point_strictly_under_edge :=
+  point_strictly_under_edge R eq_op le +%R (fun x y => x - y) *%R 1 edge
+  left_pt right_pt.
+
+Lemma R_ltb_lt  x y : R_ltb R eq_op le x y = (x < y).
+Proof. by rewrite /R_ltb -lt_neqAle. Qed.
+
+Lemma strictE p e :
+  point_strictly_under_edge (*R eq_op le +%R
+    (fun x y => x - y) *%R 1 edge left_pt right_pt *) p e =
+  (area3 p (left_pt e) (right_pt e) < 0).
+Proof.
+by rewrite /point_strictly_under_edge/generic_trajectories.point_strictly_under_edge R_ltb_lt subrr.
+Qed.
+
+Lemma underE p e :
+  point_under_edge (* R le +%R
+    (fun x y => x - y) *%R 1 edge left_pt right_pt *) p e =
+  (area3 p (left_pt e) (right_pt e) <= 0).
+Proof.
+by rewrite /point_under_edge/generic_trajectories.point_under_edge subrr.
+Qed.
+
+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).
+
+Notation "p '>>=' e" := (~~(point_strictly_under_edge p e))( at level 70, no associativity).
+Notation "p '>>>' e" := (~~(point_under_edge p e))(at level 70, no associativity).
+
+Section ring_sandbox.
+
+Definition R' := (R : Type).
+
+Let mul : R' -> R' -> R' := @GRing.mul _.
+Let add : R' -> R' -> R' := @GRing.add _.
+Let sub : R' -> R' -> R' := (fun x y => x - y).
+Let opp : R' -> R' := @GRing.opp _.
+Let zero : R' := 0.
+Let one : R' := 1.
+
+
+Let R2_theory :=
+   @mk_rt R' zero one add mul sub opp
+    (@eq R')
+    (@add0r R) (@addrC R) (@addrA R) (@mul1r R) (@mulrC R)
+      (@mulrA R) (@mulrDl R) (fun x y : R' => erefl (x - y)) (@addrN R).
+
+Add Ring R2_Ring : R2_theory.
+
+Ltac mc_ring :=
+rewrite ?mxE /= ?(expr0, exprS, mulrS, mulr0n) -?[@GRing.add _]/add
+    -?[@GRing.mul _]/mul
+    -?[@GRing.opp _]/opp -?[1]/one -?[0]/zero;
+match goal with |- @eq ?X _ _ => change X with R' end;
+ring.
+
+Let inv : R' -> R' := @GRing.inv _.
+Let div : R' -> R' -> R' := fun x y => mul x (inv y).
+
+Definition R2_sft : field_theory zero one add mul sub opp div inv (@eq R').
+Proof.
+constructor.
+- exact R2_theory.
+- have // : one <> zero by apply/eqP; rewrite oner_eq0.
+- have // : forall p q : R', div p q = mul p (inv q) by [].
+- have // : forall p : R', p <> zero -> mul (inv p) p = one.
+  by move=> *; apply/mulVf/eqP.
+Qed.
+
+Add Field Qfield : R2_sft.
+
+Ltac mc_field :=
+rewrite ?mxE /= ?(expr0, exprS, mulrS, mulr0n) -?[@GRing.add _]/add
+    -?[@GRing.mul _]/mul -[@GRing.inv _]/inv
+    -?[@GRing.opp _]/opp -?[1]/one -?[0]/zero;
+match goal with |- @eq ?X _ _ => change X with R' end;
+field.
+
+Example field_playground (x y : R' ) : x != 0 -> y != 0 -> (x * y) / (x * y) = 1.
+Proof.
+move=> xn0 yn0; mc_field.
+by split; apply/eqP.
+Qed.
+
+(* returns true if p is under A B *)
+Definition pue_f (a_x a_y b_x b_y c_x c_y : R')  : R' :=
+     b_x * c_y + a_x * b_y + c_x * a_y -
+    b_x * a_y - a_x * c_y - c_x * b_y.
+
+Lemma pue_f_o p_x p_y a_x a_y b_x b_y:  pue_f p_x p_y a_x a_y b_x b_y = - pue_f b_x b_y a_x a_y p_x p_y.
+Proof.
+  rewrite /pue_f.
+  mc_ring.
+Qed.
+
+Lemma pue_f_c p_x p_y a_x a_y b_x b_y:  pue_f p_x p_y a_x a_y b_x b_y =  pue_f b_x b_y p_x p_y a_x a_y.
+Proof.
+  rewrite /pue_f.
+  mc_ring.
+Qed.
+
+Lemma pue_f_inter p_x  a_x a_y b_x b_y : b_x != a_x ->
+  pue_f p_x ((p_x - a_x)* ((b_y - a_y)/(b_x - a_x)) + a_y) a_x a_y b_x b_y = 0.
+Proof.
+rewrite /pue_f.
+rewrite -subr_eq0 => h.
+set slope := (_ / _).
+
+rewrite (mulrDr b_x).
+rewrite (mulrDr a_x).
+apply/eqP.
+rewrite -(orbF (_ == 0)).
+rewrite -(negbTE h).
+rewrite -mulf_eq0 .
+rewrite ! ( mulrBl (b_x - a_x), fun x y => mulrDl x y (b_x - a_x)).
+
+rewrite /slope !mulrA !mulfVK //.
+apply/eqP; mc_ring.
+Qed.
+
+Lemma pue_f_inters p_x p_y a_x a_y b_x b_y  :  b_x != a_x -> p_y = ((p_x - a_x) * ((b_y - a_y) / (b_x - a_x)) + a_y) ->
+pue_f p_x p_y a_x a_y b_x b_y = 0.
+Proof.
+move => h ->.
+by apply pue_f_inter; rewrite h.
+
+
+Qed.
+
+Lemma pue_f_eq p_x p_y a_x a_y : pue_f p_x p_y p_x p_y a_x a_y = 0.
+Proof. by rewrite /pue_f /=; mc_ring. Qed.
+
+Lemma pue_f_two_points p_x p_y a_x a_y :
+  pue_f p_x p_y p_x p_y a_x a_y = 0 /\
+  pue_f p_x p_y a_x a_y p_x p_y = 0 /\
+  pue_f p_x p_y a_x a_y a_x a_y = 0.
+Proof.
+split.
+  by rewrite pue_f_eq.
+split.
+  by rewrite (pue_f_c p_x p_y  a_x a_y p_x p_y) pue_f_eq.
+by rewrite -(pue_f_c  a_x a_y  a_x a_y p_x p_y) pue_f_eq.
+Qed.
+
+Lemma pue_f_vert p_y a_x a_y b_x b_y :
+ pue_f a_x a_y b_x b_y b_x p_y = (b_x - a_x) * (p_y - b_y).
+Proof. by rewrite /pue_f; mc_ring. Qed.
+
+Lemma ax4 p_x p_y q_x q_y r_x r_y t_x t_y :
+  pue_f t_x t_y q_x q_y r_x r_y +
+  pue_f p_x p_y t_x t_y r_x r_y +
+  pue_f p_x p_y q_x q_y t_x t_y = pue_f p_x p_y q_x q_y r_x r_y.
+Proof. by rewrite /pue_f; mc_ring. Qed.
+
+Lemma pue_f_linear l a b c d e f :
+l * pue_f a b c d e f = pue_f a (l*b) c (l*d) e (l*f).
+Proof.
+rewrite /pue_f.
+mc_ring.
+Qed.
+
+Lemma pue_f_on_edge_y a_x a_y b_x b_y m_x m_y :
+  pue_f m_x m_y a_x a_y b_x b_y = 0 ->
+  (b_x - a_x) * m_y = m_x * (b_y -a_y)- (a_x * b_y - b_x *a_y).
+Proof.
+move=> abmeq0.
+apply/eqP; rewrite -subr_eq0; apply/eqP.
+by rewrite -abmeq0 /pue_f; mc_ring.
+Qed.
+
+Lemma pue_f_on_edge a_x a_y b_x b_y c_x c_y d_x d_y m_x m_y :
+  pue_f m_x m_y a_x a_y b_x b_y = 0 ->
+  (b_x - a_x) * pue_f m_x m_y c_x c_y d_x d_y =
+  (m_x - a_x) * pue_f b_x b_y c_x c_y d_x d_y +
+  (b_x - m_x) * pue_f a_x a_y c_x c_y d_x d_y.
+Proof.
+move=> on_ed.
+rewrite pue_f_linear /pue_f (pue_f_on_edge_y on_ed).
+mc_ring.
+Qed.
+
+Lemma pue_f_triangle_on_edge a_x a_y b_x b_y p_x p_y p'_x p'_y :
+  pue_f p'_x p'_y a_x a_y b_x b_y = 0 ->
+  (b_x - a_x) * pue_f p'_x p'_y a_x a_y p_x p_y =
+  (p'_x - a_x) * pue_f b_x b_y a_x a_y p_x p_y .
+Proof.
+move=> on_ed.
+rewrite pue_f_linear /pue_f (pue_f_on_edge_y on_ed).
+mc_ring.
+Qed.
+
+Lemma pue_f_triangle_on_edge' a_x a_y b_x b_y p_x p_y p'_x p'_y :
+  pue_f p'_x p'_y a_x a_y b_x b_y = 0 ->
+  (b_x - a_x) * pue_f p'_x p'_y p_x p_y b_x b_y =
+  (b_x - p'_x) * pue_f a_x a_y p_x p_y b_x b_y .
+Proof.
+move => on_ed.
+rewrite pue_f_linear /pue_f (pue_f_on_edge_y on_ed).
+mc_ring.
+Qed.
+
+Lemma pue_f_on_edge_same_point a_x a_y b_x b_y p_x p_y p_x' p_y':
+  a_x != b_x ->
+  pue_f p_x p_y a_x a_y b_x b_y = 0 ->
+  pue_f p_x' p_y' a_x a_y b_x b_y = 0 ->
+  p_x = p_x' -> p_y = p_y'.
+Proof.
+move=> axnbx puep0 puep'0.
+have pyeq := pue_f_on_edge_y puep0.
+have p'yeq := pue_f_on_edge_y puep'0.
+move=> xxs; have yys : (b_x - a_x) * p_y = (b_x - a_x) * p_y'.
+  by rewrite pyeq xxs p'yeq.
+move: (axnbx); rewrite eq_sym -subr_eq0.
+by move=> /mulfI; exact.
+Qed.
+
+Lemma pue_f_ax5 p_x p_y q_x q_y a_x a_y b_x b_y c_x c_y :
+  pue_f p_x p_y a_x a_y b_x b_y *
+  pue_f p_x p_y q_x q_y c_x c_y +
+  pue_f p_x p_y b_x b_y c_x c_y *
+  pue_f p_x p_y q_x q_y a_x a_y =
+  pue_f p_x p_y a_x a_y c_x c_y *
+  pue_f p_x p_y q_x q_y b_x b_y.
+Proof.
+rewrite /pue_f; mc_ring.
+Qed.
+
+Lemma pue_f_triangle_decompose a_x a_y b_x b_y c_x c_y d_x d_y :
+  pue_f a_x a_y c_x c_y d_x d_y = 0 ->
+  pue_f a_x a_y b_x b_y c_x c_y =
+  pue_f a_x a_y b_x b_y d_x d_y +
+  pue_f b_x b_y c_x c_y d_x d_y.
+Proof.
+move=> online.
+rewrite -(ax4 _ _ _ _ _ _ d_x d_y).
+rewrite addrC; congr (_ + _).
+by rewrite addrC pue_f_o pue_f_c online oppr0 add0r -pue_f_c.
+Qed.
+
+Definition mkmx2 (a b c d : R) :=
+  \matrix_(i < 2, j < 2)
+    if (i == ord0) && (j == ord0) then a
+    else if i == ord0 then b
+           else if j == ord0 then c else d.
+
+Definition mkcv2 (a b : R) := \col_(i < 2) if i == ord0 then a else b.
+
+Lemma det_mkmx2 a_x a_y b_x b_y :
+  \det(mkmx2 a_x a_y b_x b_y) = a_x * b_y - a_y * b_x.
+Proof.
+rewrite /mkmx2 (expand_det_row _ ord0) big_ord_recr /= big_ord1 /=.
+by rewrite /cofactor /= expr0 expr1 mulNr !mul1r !det_mx11 !mxE /= mulrN.
+Qed.
+
+Lemma line_intersection a_x a_y b_x b_y c_x c_y d_x d_y :
+  c_x != d_x ->
+  0 < pue_f c_x c_y a_x a_y b_x b_y ->
+  pue_f d_x d_y a_x a_y b_x b_y < 0 ->
+  exists p_x p_y,
+    pue_f p_x p_y a_x a_y b_x b_y = 0 /\
+    pue_f p_x p_y c_x c_y d_x d_y = 0 /\
+    (forall q_x q_y, pue_f q_x q_y a_x a_y b_x b_y = 0 ->
+       pue_f q_x q_y c_x c_y d_x d_y = 0 -> p_x = q_x /\ p_y = q_y).
+Proof.
+move=> cltd cabove cunder.
+set A := a_y - b_y; set B := b_x - a_x; set C := \det(mkmx2 a_x a_y b_x b_y).
+have puef1_id x y : pue_f x y a_x a_y b_x b_y = A * x + B * y + C.
+  by rewrite /A /B /C det_mkmx2 /pue_f; mc_ring.
+set D := c_y - d_y; set E := d_x - c_x; set F := \det(mkmx2 c_x c_y d_x d_y).
+have puef2_id x y : pue_f x y c_x c_y d_x d_y = D * x + E * y + F.
+  by rewrite /D /E /F det_mkmx2 /pue_f; mc_ring.
+set M := mkmx2 A B D E.
+set V1 := mkcv2 (b_x - a_x) (b_y - a_y).
+set V2 := mkcv2 (d_x - c_x) (d_y - c_y).
+have sys_to_mx_eqn :
+  forall x y, (A * x + B * y + C = 0 /\ D * x + E * y + F = 0) <->
+   (M *m mkcv2 x y + mkcv2 C F = 0).
+  move=> x y; split.
+    move=> [eq1 eq2]; apply/matrixP=> i j.
+    rewrite !mxE big_ord_recr /= big_ord1 /= !mxE.
+    by case : j => [ [ | j ] ] //= _; case : i => [ [ | [ | i]]].
+  move/matrixP=> mxq.
+  split.
+    have := mxq (Ordinal (isT : (0 < 2)%N)) (Ordinal (isT : (0 < 1)%N)).
+    by rewrite !mxE big_ord_recr /= big_ord1 /= !mxE.
+  have := mxq (Ordinal (isT : (1 < 2)%N)) (Ordinal (isT : (0 < 1)%N)).
+  by rewrite !mxE big_ord_recr /= big_ord1 /= !mxE.
+set sol := - (M ^-1 *m mkcv2 C F) : 'cV_2.
+have soleq : sol = mkcv2 (sol ord0 ord0) (sol ord_max ord0).
+  apply/matrixP=> [][[ | [ | i]]] // ip [ [ | j]] // jp; rewrite /= !mxE /=;
+    (rewrite (_ : Ordinal jp = ord0); last apply: val_inj=> //).
+    by rewrite (_ : Ordinal ip = ord0); last apply: val_inj.
+  by rewrite (_ : Ordinal ip = ord_max); last apply: val_inj.
+have detm : \det M != 0.
+  have dets : \det M = A * E - D * B.
+    rewrite (expand_det_col _ ord0) big_ord_recr /= big_ord1 !mxE /= /cofactor.
+    by rewrite !det_mx11 /= expr1 expr0 !mulNr !mulrN !mul1r !mxE.
+  have -> : \det M = pue_f d_x d_y a_x a_y b_x b_y -
+                  pue_f c_x c_y a_x a_y b_x b_y.
+    by rewrite dets /pue_f /A /B /D /E; mc_ring.
+  rewrite subr_eq0; apply/eqP=> abs; move: cabove cunder; rewrite abs=> ca cu.
+  by have := lt_trans ca cu; rewrite ltxx.
+have Munit : M \in unitmx by rewrite unitmxE unitfE.
+have solm : M *m sol + mkcv2 C F = 0.
+  rewrite /sol mulmxN mulmxA mulmxV; last by rewrite unitmxE unitfE.
+  by rewrite mul1mx addNr.
+move: (solm); rewrite soleq -sys_to_mx_eqn => [][sol1 sol2].
+exists (sol ord0 ord0), (sol ord_max ord0).
+split; first by rewrite puef1_id.
+split; first by rewrite puef2_id.
+move=> qx qy; rewrite puef1_id puef2_id=> tmp1 tmp2; have := conj tmp1 tmp2.
+rewrite sys_to_mx_eqn addrC => /addr0_eq solmq {tmp1 tmp2}.
+suff/matrixP mq : mkcv2 qx qy = sol.
+  by split; rewrite -?(mq ord0 ord0) -?(mq ord_max ord0) mxE.
+by rewrite /sol -mulmxN solmq mulKmx.
+Qed.
+
+Lemma pue_f_eq_slopes ax ay bx b_y mx my :
+  pue_f mx my ax ay bx b_y =
+   (my - ay) * (bx - ax) - (mx - ax) * (b_y - ay) /\
+  pue_f mx my ax ay bx b_y =
+   -((b_y - my) * (bx - ax) - (bx - mx) * (b_y - ay)).
+Proof.
+split; rewrite /pue_f; mc_ring.
+Qed.
+
+Lemma edge_and_left_vertical_f px py qx qy ax ay :
+  px < ax -> px = qx ->
+  (0 < pue_f px py qx qy ax ay) = (qy < py).
+Proof.
+move=> edge_cond <-.
+rewrite [X in (0 < X)](_ : _ = (ax - px) * (py - qy)); last first.
+  by rewrite /pue_f; mc_ring.
+by rewrite pmulr_rgt0 subr_gt0.
+Qed.
+
+Lemma edge_and_right_vertical_f px py qx qy ax ay :
+  ax < px -> px = qx -> (0 < pue_f px py qx qy ax ay) = (py < qy).
+Proof.
+move=> edge_cond <-.
+rewrite [X in (0 < X)](_ : _ = (px - ax) * (qy - py)); last first.
+  by rewrite /pue_f; mc_ring.
+by rewrite pmulr_rgt0 subr_gt0.
+Qed.
+
+End ring_sandbox.
+
+Lemma area3E a b c : area3 a b c =
+   pue_f a.x (a.y) b.x (b.y) c.x (c.y).
+Proof. by case: a b c=> [a_x a_y] [b_x b_y] [c_x c_y]. Qed.
+
+Lemma area3_opposite a b d:  area3 d a b = - area3 b a d.
+Proof.
+  move: a b d => [ax ay] [b_x b_y] [dx dy]/=.
+  apply :pue_f_o.
+Qed.
+
+Lemma area3_cycle a b d : area3 d a b = area3 b d a.
+Proof.
+  move: a b d => [ax ay] [b_x b_y] [dx dy]/=.
+  apply :pue_f_c.
+Qed.
+
+Lemma area3_vert a b c : (b.x = c.x) ->
+  area3 a b c = (b.x - a.x) * (c.y - b.y).
+Proof.
+move: a b c => [ax ay] [b_x b_y] [cx cy]/= <-.
+exact: pue_f_vert.
+Qed.
+
+Lemma ax4_three_triangles p q r t :
+  area3 t q r + area3 p t r + area3 p q t = area3 p q r.
+Proof.
+move : p q r t => [px py] [q_x q_y] [rx ry] [t_x t_y]/= .
+exact: ax4.
+Qed.
+
+Lemma area3_two_points a b :
+  area3 a a b = 0 /\
+  area3 a b a = 0 /\
+  area3 a b b = 0.
+Proof.
+move : a b => [ax ay] [b_x b_y] /=.
+exact: pue_f_two_points.
+Qed.
+
+Lemma area3_on_edge a b c d m :
+  area3 m a b = 0 ->
+  (b.x - a.x) * area3 m c d =
+  (m.x - a.x) * area3 b c d + (b.x - m.x) * area3 a c d.
+Proof.
+move : a b c d m => [ax ay] [b_x b_y] [cx cy] [dx dy] [mx my]/=.
+apply: pue_f_on_edge.
+Qed.
+
+Lemma area3_on_edge_y a b m :
+  area3 m a b = 0 ->
+  (b.x - a.x) * m.y = m.x * (b.y - a.y) - (a.x * b.y - b.x * a.y).
+Proof.
+move : a b m => [ax ay] [b_x b_y]  [mx my]/=.
+exact: pue_f_on_edge_y.
+Qed.
+
+Lemma area3_triangle_on_edge a b p p' :
+  area3 p' a b = 0 ->
+  (b.x - a.x) * area3 p' a p =
+  (p'.x - a.x) * area3 b a p.
+Proof.
+move : a b p p' => [ax ay] [b_x b_y] [px py] [p'x p'y] /=.
+exact: pue_f_triangle_on_edge.
+Qed.
+
+Definition subpoint (p : pt) :=
+  Bpt (p.x) (p.y - 1).
+
+Lemma edge_and_left_vertical (p q a : pt) :
+  p.x < a.x -> p.x = q.x ->
+  (0 < area3 p q a) = (q.y < p.y).
+Proof.
+case: p=> [px py]; case: a=> [ax ay]; case: q=> [qx qy] /=.
+by move=> c1 c2; apply edge_and_left_vertical_f.
+Qed.
+
+Lemma edge_and_left_vertical_eq (p q a : pt) :
+  p.x < a.x -> p.x = q.x ->
+  (area3 p q a == 0) = (p == q).
+Proof.
+move=> edge_cond vert_cond.
+apply/idP/idP; last first.
+  by move/eqP ->; rewrite (area3_two_points q a).1.
+move=> abs; suff : p.y = q.y.
+  by move: vert_cond {edge_cond abs}; case: p=> [? ?]; case q=> [? ?]/= <- <-.
+apply: le_anti. rewrite (leNgt (p.y) (q.y)).
+rewrite -(edge_and_left_vertical edge_cond vert_cond) (eqP abs).
+have ec' : q.x < a.x by rewrite -vert_cond.
+rewrite leNgt -(edge_and_left_vertical ec' (esym vert_cond)).
+by rewrite area3_opposite -area3_cycle (eqP abs) oppr0 ltxx.
+Qed.
+
+Lemma edge_and_right_vertical (p q a : pt) :
+  a.x < p.x -> p.x = q.x ->
+  (0 < area3 p q a) = (p.y < q.y).
+Proof.
+case: p=> [px py]; case: a=> [ax ay]; case: q=> [qx qy] /=.
+by move=> c1 c2; apply: edge_and_right_vertical_f.
+Qed.
+
+Lemma point_sub_right (p a : pt) :
+  (p.x < a.x) -> 0 < area3 p (subpoint p) a.
+Proof.
+move=> edge_cond.
+rewrite edge_and_left_vertical //; rewrite /subpoint /= lterBDr cprD.
+by rewrite ltr01.
+Qed.
+
+Lemma underW p e :
+  (p <<< e) ->
+  (p <<= e).
+Proof.
+move=> /andP[] _ it; exact: it.
+Qed.
+
+Lemma underWC p e :
+~~ (p <<= e) -> ~~ (p <<< e).
+Proof. by move/negP=> it; apply/negP=> it'; case: it; apply : underW. Qed.
+
+Definition valid_edge :=
+  generic_trajectories.valid_edge R le edge left_pt right_pt.
+
+Lemma valid_edge_extremities e0 p:
+  (left_pt e0 == p) || (right_pt e0 == p) ->
+  valid_edge e0 p.
+Proof.
+rewrite /valid_edge/generic_trajectories.valid_edge.
+by move => /orP [/eqP eq |/eqP eq ];
+rewrite -eq lexx ?andbT /= {eq} ltW // ; case : e0 .
+Qed.
+
+Lemma valid_edge_left g : valid_edge g (left_pt g).
+Proof.
+by apply: valid_edge_extremities; rewrite eqxx.
+Qed.
+
+Lemma valid_edge_right g : valid_edge g (right_pt g).
+Proof.
+by apply: valid_edge_extremities; rewrite eqxx orbT.
+Qed.
+
+Definition point_on_edge (p : pt) (e : edge) : bool :=
+  (area3 p (left_pt e) (right_pt e) == 0) && valid_edge e p.
+
+Notation "p '===' e" := (point_on_edge p e) (at level 70, no associativity).
+
+Definition edge_below (e1 : edge) (e2 : edge) : bool :=
+((left_pt e1 <<= e2) && (right_pt e1 <<= e2))
+|| (~~  (left_pt e2 <<< e1) && ~~ (right_pt e2<<< e1)).
+
+Notation "e1 '<|' e2" := (edge_below e1 e2)( at level 70, no associativity).
+
+Definition below_alt (e1 : edge) (e2 : edge) :=
+  edge_below e1 e2 \/ edge_below e2 e1.
+
+Lemma edge_below_refl e : e <| e.
+Proof.
+apply/orP; left.
+rewrite 2!underE.
+rewrite (proj1 (area3_two_points _ _)).
+by rewrite (proj1 (proj2 (area3_two_points _ _))) lexx.
+Qed.
+
+Lemma below_altC e1 e2 : below_alt e1 e2 <-> below_alt e2 e1.
+Proof. by rewrite /below_alt or_comm. Qed.
+
+Lemma below_altN e1 e2 : below_alt e1 e2 -> ~~(e2 <| e1) -> e1 <| e2.
+Proof. by move=> []// ->. Qed.
+
+Definition inter_at_ext (e1 e2 : edge) :=
+  e1 = e2 \/
+  forall p, p === e1 -> p === e2 -> p \in [:: left_pt e1; right_pt e1].
+
+Definition inter_at_ext' (e1 e2 : edge) :=
+  e1 = e2 \/
+  forall p, p === e2 -> p === e1 -> p \in [:: left_pt e2; right_pt e2].
+
+Lemma inter_at_ext_sym (s : seq edge) :
+  {in s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s &, forall e1 e2, inter_at_ext' e1 e2}.
+Proof.
+move=> cnd e1 e2 e1in e2in; case: (cnd e2 e1 e2in e1in).
+  by move=> ->; left.
+by move=> subcnd; right=> p pe2 pe1; apply: subcnd.
+Qed.
+
+Definition no_crossing := forall e1 e2, below_alt e1 e2.
+
+Definition no_crossing' : Prop :=
+ forall e e' : edge,
+ valid_edge e (left_pt e') ->
+(left_pt e' <<< e  -> e' <| e)  /\
+(~ (left_pt e' <<= e)  -> e <| e').
+
+Lemma left_on_edge e : left_pt e === e.
+Proof.
+move : e => [ l r inE].
+rewrite /point_on_edge //=.
+have [->/= _] := area3_two_points l r.
+rewrite eqxx/=.
+by apply/andP; split => //; exact: ltW.
+Qed.
+
+Lemma right_on_edge e : right_pt e === e.
+Proof.
+move : e => [ l r inE].
+rewrite /point_on_edge //=.
+have [_ [->/= _]] := area3_two_points r l.
+rewrite eqxx/=.
+by apply/andP; split => //; exact: ltW.
+Qed.
+
+Lemma point_on_edge_above low_e high_e a :
+  a === high_e ->
+  ~~ (left_pt high_e <<< low_e) ->
+  ~~ (right_pt high_e <<< low_e) ->
+  ~~ (a <<< low_e).
+Proof.
+move : high_e => [lr hr inH] /=.
+rewrite /point_on_edge /valid_edge => /andP [] /= /eqP poea /andP [] linfa ainfr.
+have pf := area3_on_edge (left_pt low_e) (right_pt low_e) poea.
+rewrite /point_strictly_under_edge.
+rewrite /generic_trajectories.point_strictly_under_edge subrr.
+rewrite !R_ltb_lt -!leNgt => llrllh llrllrh.
+have diffa : lr.x - a.x <= 0 by rewrite subr_cp0.
+have diffb : hr.x - a.x >= 0 by rewrite subr_cp0.
+have difflh : lr.x - hr.x < 0 by rewrite subr_cp0.
+rewrite -(ler_nM2l difflh _ 0) mulr0 -opprB mulNr oppr_le0 pf.
+by rewrite addr_ge0 // mulr_ge0 // subr_ge0.
+Qed.
+
+Lemma point_on_edge_above_strict low_e high_e a :
+  a === high_e ->
+  left_pt high_e >>> low_e ->
+  right_pt high_e >>> low_e ->
+  a >>> low_e.
+Proof.
+move : high_e => [lr hr inH] /=.
+rewrite /point_on_edge /valid_edge => /andP [] /= /eqP poea /andP [] linfa ainfr.
+have pf := area3_on_edge (left_pt low_e) (right_pt low_e) poea.
+rewrite /point_under_edge -!ltNge !subrr => llrllh llrllrh.
+have diffa : lr.x - a.x <= 0 by rewrite subr_cp0.
+have diffb : hr.x - a.x >= 0 by rewrite subr_cp0.
+have difflh : lr.x - hr.x < 0 by rewrite subr_cp0.
+rewrite -(ltr_nM2l difflh _ 0) mulr0 -opprB mulNr oppr_lt0 pf.
+have addr_le_gt0 (x y : R) : 0 <= x -> 0 < y -> 0 < x + y.
+  move=> xge0 ygt0; rewrite -(add0r 0).
+  by apply: ler_ltD.
+move: diffa; rewrite le_eqVlt=> /orP[ | diffa]; last first.
+  rewrite addrC addr_le_gt0 // ?mulr_gt0 ?mulr_ge0 //.
+    by rewrite ltW.
+  by rewrite subr_gt0 -subr_lt0.
+rewrite subr_eq0=> /eqP /[dup] lraq <-; rewrite subrr mul0r add0r.
+by rewrite mulr_gt0 // subr_gt0.
+Qed.
+
+Lemma point_on_edge_under low_e high_e a :
+  a === (low_e) ->
+  left_pt low_e <<= high_e ->
+  right_pt low_e <<= high_e ->
+  a <<= high_e.
+Proof.
+move : low_e => [lr hr inH] /=.
+rewrite /point_on_edge /valid_edge => /andP [] /= /eqP poea /andP [] linfa ainfr.
+have pf := area3_on_edge (left_pt high_e) (right_pt high_e) poea.
+rewrite /point_under_edge /generic_trajectories.point_under_edge !subrr=> llrllh llrllrh.
+have diffa : lr.x - a.x <= 0 by rewrite subr_cp0.
+have diffb : hr.x - a.x >= 0 by rewrite subr_cp0.
+have difflh : lr.x - hr.x < 0 by rewrite subr_cp0.
+rewrite -(ler_nM2r difflh 0 _) mul0r mulrC -opprB mulNr pf opprD.
+by rewrite addr_ge0 // -mulNr mulr_le0 // oppr_le0 subr_cp0.
+Qed.
+
+Lemma point_on_edge_under_strict high_e low_e a :
+  a === low_e ->
+  left_pt low_e <<< high_e ->
+  right_pt low_e <<< high_e ->
+  a <<< high_e.
+Proof.
+move : low_e => [lr hr inH] /=.
+rewrite /point_on_edge /valid_edge => /andP [] /= /eqP poea /andP [] linfa ainfr.
+have pf := area3_on_edge (left_pt high_e) (right_pt high_e) poea.
+rewrite /point_strictly_under_edge.
+rewrite/generic_trajectories.point_strictly_under_edge.
+rewrite !R_ltb_lt !subrr=> llrllh llrllrh.
+have diffa : lr.x - a.x <= 0 by rewrite subr_cp0.
+have diffb : hr.x - a.x >= 0 by rewrite subr_cp0.
+have difflh : lr.x - hr.x < 0 by rewrite subr_cp0.
+rewrite -(ltr_nM2l difflh 0) mulr0 -opprB mulNr oppr_gt0 pf.
+have addr_le_lt0 (x y : R) : x <= 0 -> y < 0 -> x + y < 0.
+  by move=> xle0 ylt0; rewrite -(add0r 0) ler_ltD.
+move: diffa; rewrite le_eqVlt=> /orP[ | diffa]; last first.
+  rewrite addrC addr_le_lt0 // ?nmulr_llt0 ?mulr_ge0_le0 //.
+      by rewrite ltW.
+  by rewrite subr_gt0 -subr_lt0.
+rewrite subr_eq0=> /eqP /[dup] lraq <-; rewrite subrr mul0r add0r.
+by rewrite nmulr_llt0 // subr_gt0.
+Qed.
+
+Lemma not_strictly_above' low_e high_e p':
+  ~~ (left_pt (high_e) <<< low_e) ->
+  ~~ (right_pt (high_e) <<< low_e) ->
+  p' ===  high_e ->  (right_pt (low_e)).x = p'.x  ->
+  right_pt (low_e) <<= high_e .
+Proof.
+move : low_e => [ll lr inL] /=.
+move => pablh pabrh poep' eqxp'p.
+have /= puefcpp' := area3_vert (left_pt (Bedge inL)) eqxp'p .
+have := (point_on_edge_above poep' pablh pabrh ).
+rewrite strictE.
+rewrite -area3_cycle -leNgt puefcpp' underE.
+have inle : lr.x - ll.x > 0 by rewrite subr_cp0.
+rewrite (pmulr_rge0 _ inle) => inp'lr.
+have <- := ax4_three_triangles lr  (left_pt high_e) (right_pt high_e) p'.
+move : poep'.
+rewrite /point_on_edge=> /andP [] /eqP pue0 valp'.
+rewrite pue0.
+have := (area3_vert (right_pt high_e) eqxp'p  ).
+rewrite -area3_cycle eqxp'p => ->.
+move : valp'.
+rewrite /valid_edge => /andP [] xlhp' xrhp'.
+have xrhp'0: p'.x - (right_pt high_e).x <= 0 by rewrite subr_cp0.
+rewrite add0r -oppr_ge0 opprD /= addr_ge0//.
+  by rewrite -mulNr mulr_ge0 // oppr_ge0.
+have := area3_vert (left_pt high_e) eqxp'p.
+rewrite -area3_opposite area3_cycle eqxp'p => ->.
+have xlhp'0: p'.x - (left_pt high_e).x >= 0 by rewrite subr_cp0.
+by rewrite mulr_ge0.
+Qed.
+
+Lemma under_above_on e p : valid_edge e p -> p <<= e -> p >>= e -> p === e.
+Proof.
+move=> v u a; apply/andP; split => //.
+apply/eqP/le_anti/andP;split.
+  by move: u; rewrite /point_under_edge /generic_trajectories.point_under_edge !subrr.
+move: a; rewrite /point_strictly_under_edge.
+rewrite /generic_trajectories.point_strictly_under_edge subrr.
+by rewrite R_ltb_lt leNgt=> it; exact: it.
+Qed.
+
+(* returns the point of the intersection between a vertical edge
+ intersecting p and the edge e if it exists, None if it doesn't *)
+
+Definition vertical_intersection_point (p : pt) (e : edge) : option pt :=
+  vertical_intersection_point R le +%R (fun x y => x - y) *%R
+    (fun x y => x / y) edge left_pt right_pt p e.
+
+Lemma vertical_none p e :
+  ~~ valid_edge e p -> vertical_intersection_point p e = None.
+Proof.
+move: p e => [px py] [[ax ay] [b_x b_y] ab] h /=.
+rewrite /vertical_intersection_point.
+rewrite /generic_trajectories.vertical_intersection_point /=.
+by rewrite /valid_edge in h; rewrite (negbTE h).
+Qed.
+
+Lemma vertical_correct p e :
+    match vertical_intersection_point p e with
+  None => ~~ valid_edge e p | Some(i) => i === e end.
+Proof.
+move: p e => [ptx pty] [[ax ay] [bx b_y]  /=ab] .
+rewrite /vertical_intersection_point/valid_edge.
+rewrite /generic_trajectories.vertical_intersection_point.
+case : ifP => /= h ; last by [].
+have: ax != bx by rewrite neq_lt ab.
+set py := ((b_y - ay) / (bx - ax) * ptx + (ay - (b_y - ay) / (bx - ax) * ax)).
+move => h2.
+rewrite /point_on_edge .
+apply/andP; split; last exact h.
+apply/eqP.
+apply pue_f_inters => //.
+by rewrite eq_sym.
+Qed.
+
+Lemma exists_point_valid e p :
+  valid_edge e p ->
+  exists p', vertical_intersection_point p e = Some p'.
+Proof.
+have := vertical_correct p e.
+case : (vertical_intersection_point p e)=> [vp |//= a b].
+  rewrite /point_on_edge  => a b.
+  by exists vp.
+exists p.
+by rewrite b in a.
+Qed.
+
+Lemma intersection_on_edge e p p' :
+  vertical_intersection_point p e = Some p' ->
+  p' === e /\ p.x = p'.x.
+Proof.
+have := vertical_correct p e.
+case vert : (vertical_intersection_point p e)=> [vp |//=].
+move: vert.
+rewrite /vertical_intersection_point.
+rewrite /generic_trajectories.vertical_intersection_point.
+case : (generic_trajectories.valid_edge _ _ _ _ _ e p) => [| //].
+move => [] /= vpq  poe [] <-.
+by rewrite poe -vpq.
+Qed.
+
+Lemma not_strictly_under' low_e high_e p' :
+  left_pt (low_e) <<= high_e ->
+  right_pt (low_e) <<= high_e ->
+(* This is an alternative way to say
+  valid_edge low_e (right_pt high_e) *)
+  p' === low_e -> (right_pt (high_e)).x = p'.x  ->
+  ~~ (right_pt (high_e) <<< low_e).
+Proof.
+move : high_e => [hl hr inH] /=.
+move => pablh pabrh poep' eqxp'p.
+have /= puefcpp' := area3_vert (left_pt (Bedge inH)) eqxp'p .
+have := point_on_edge_under poep' pablh pabrh.
+rewrite underE strictE.
+rewrite -area3_cycle.
+rewrite -leNgt puefcpp'.
+have inle : hr.x - hl.x > 0 by rewrite subr_cp0.
+rewrite (pmulr_rle0 _ inle )  => inp'hr.
+have <- := ax4_three_triangles hr (left_pt low_e) (right_pt low_e) p'.
+move : poep'.
+rewrite /point_on_edge=> /andP [] /eqP pue0 valp'.
+rewrite pue0.
+have := area3_vert (right_pt low_e) eqxp'p.
+rewrite -area3_cycle eqxp'p => ->.
+move : valp'.
+rewrite /valid_edge => /andP [] xlhp' xrhp'.
+have xrhp'0 : p'.x - (right_pt low_e).x <= 0 by rewrite subr_cp0.
+rewrite add0r addr_ge0// ?mulr_le0//.
+have := area3_vert (left_pt low_e) eqxp'p.
+rewrite area3_opposite -area3_cycle eqxp'p => /eqP; rewrite eqr_oppLR => /eqP ->.
+by rewrite -mulNr mulr_le0 // oppr_le0 subr_cp0.
+Qed.
+
+Lemma pue_right_edge e p : (right_pt e).x = p.x ->
+  (p <<= e) = (p.y - (right_pt e).y <= 0).
+Proof.
+move : e p  => [[ax ay][bx b_y] /= inE] [px py]  /=.
+rewrite /point_under_edge/generic_trajectories.point_under_edge /= => <-/=.
+have := pue_f_vert py ax ay bx b_y.
+rewrite pue_f_c /pue_f => ->.
+rewrite -subr_cp0 -opprB oppr_lt0 in inE.
+by rewrite subrr (pmulr_rle0 _  inE) .
+Qed.
+
+Lemma psue_right_edge e p : (right_pt e).x = p.x ->
+  (p <<< e) = (p.y - (right_pt e).y < 0).
+Proof.
+move : e p  => [[ax ay][bx b_y] /= cnd] [px py]  /=.
+rewrite /point_strictly_under_edge/generic_trajectories.point_strictly_under_edge /=.
+rewrite R_ltb_lt => <- /=.
+have := pue_f_vert py ax ay bx b_y.
+rewrite pue_f_c /pue_f => ->.
+rewrite -subr_gt0 in cnd.
+by rewrite subrr (pmulr_rlt0 _  cnd).
+Qed.
+
+Lemma pue_left_edge e p : (left_pt e).x = p.x ->
+  (p <<= e) = (0 <= (left_pt e).y - p.y).
+Proof.
+move : e p  => [[ax ay][bx b_y] /= inE] [px py]  /=.
+rewrite /point_under_edge.
+rewrite /generic_trajectories.point_under_edge /= => <- /=.
+have := pue_f_vert ay bx b_y ax py.
+rewrite -pue_f_c /pue_f => ->.
+rewrite -subr_cp0 in inE.
+by rewrite subrr (nmulr_rle0 _  inE).
+Qed.
+
+Lemma psue_left_edge e p : (left_pt e).x = p.x ->
+  (p <<< e) = (0 < (left_pt e).y - p.y).
+Proof.
+move: e p => [[ax ay][bx b_y] /= cnd] [px py] /= <- /=.
+rewrite /point_strictly_under_edge.
+rewrite /generic_trajectories.point_strictly_under_edge /=.
+rewrite R_ltb_lt.
+have := pue_f_vert ay bx b_y ax py.
+rewrite -pue_f_c /pue_f => ->.
+rewrite -subr_cp0 in cnd.
+by rewrite subrr (nmulr_rlt0 _ cnd).
+Qed.
+
+Lemma not_strictly_under low_e high_e  :
+  left_pt low_e <<= high_e ->
+  right_pt low_e <<= high_e ->
+  valid_edge low_e (right_pt high_e) ->
+  ~~ (right_pt high_e <<< low_e).
+Proof.
+move => pableft pabright valright.
+have [p' vip] := exists_point_valid valright.
+have := intersection_on_edge vip => [][] poep' eqx.
+by apply: not_strictly_under' pableft pabright poep' eqx.
+Qed.
+
+Lemma not_strictly_above low_e high_e :
+  ~~ (left_pt high_e <<< low_e) ->
+  ~~ (right_pt high_e <<< low_e) ->
+  valid_edge high_e (right_pt low_e) ->
+  right_pt low_e <<= high_e.
+Proof.
+move => pableft pabright valright.
+have [p' vip] := exists_point_valid valright.
+have := intersection_on_edge vip => [][] poep' eqx.
+by apply: not_strictly_above' pableft pabright poep' eqx.
+Qed.
+
+Lemma on_edge_same_point e p p':
+  p === e -> p' === e ->
+  p.x = p'.x -> p.y = p'.y.
+Proof.
+move : e => [l r ec].
+rewrite /point_on_edge /= => /andP [] p0 _ /andP[] p'0 _.
+have dif : l.x != r.x.
+  by apply/eqP=> abs; move: ec; rewrite abs ltxx.
+move: l r p0 p'0 dif {ec}=> [a_x a_y][b_x b_y] /eqP p0 /eqP p'0 dif.
+move: p p' p0 p'0 => [x y] [x' y'] puep0 puep'0.
+exact: pue_f_on_edge_same_point dif puep0 puep'0.
+Qed.
+
+Lemma strict_under_edge_lower_y r r' e :
+  r.x = r'.x -> r' === e -> (r <<< e) = (r.y < r'.y).
+Proof.
+move=> rr' rone.
+have valre : valid_edge e r.
+  by case/andP: rone; rewrite /valid_edge/generic_trajectories.valid_edge rr'.
+move: (valre)=> /andP[] + _; rewrite le_eqVlt=> /orP[/eqP atl| inr].
+  have req : r' = left_pt e.
+    have rltr : r'.x < (right_pt e).x by rewrite -rr' -atl edge_cond.
+    have /esym := edge_and_left_vertical_eq rltr (esym (etrans atl rr')).
+    by move/andP: rone => [] -> _ /eqP.
+  by move/psue_left_edge : atl; rewrite subr_gt0 -req.
+have rue' : (r <<< e) = (area3 r (left_pt e) r' < 0).
+  move: rone=> /andP[] /[dup] tmp /eqP /area3_triangle_on_edge + _ => /(_ r).
+(* TODO : fix area3_triangle_on_edge for cycle *)
+  rewrite (area3_opposite (left_pt _)).
+  rewrite (area3_opposite (left_pt _) _ (right_pt _)) !mulrN.
+  move=> /eqP; rewrite eqr_opp => /eqP signcond.
+  move: (edge_cond e); rewrite -subr_gt0 => /pmulr_rlt0 <-.
+  rewrite signcond pmulr_rlt0; last by rewrite subr_gt0 -rr'.
+  rewrite /point_strictly_under_edge.
+  by rewrite /generic_trajectories.point_strictly_under_edge subrr R_ltb_lt.
+have inr' : (left_pt e).x < r'.x by rewrite -rr'.
+have /psue_right_edge : (right_pt (Bedge inr')).x = r.x by rewrite /= rr'.
+rewrite rue' subr_lt0.
+rewrite /point_strictly_under_edge.
+by rewrite /generic_trajectories.point_strictly_under_edge subrr R_ltb_lt.
+Qed.
+
+Lemma under_onVstrict e p : valid_edge e p ->
+  (p <<= e) = (p === e) || (p <<< e).
+Proof.
+move=> valep.
+rewrite /point_under_edge /point_strictly_under_edge /point_on_edge.
+rewrite /generic_trajectories.point_strictly_under_edge R_ltb_lt.
+rewrite /generic_trajectories.point_under_edge subrr.
+by rewrite valep andbT -le_eqVlt.
+Qed.
+
+Lemma onAbove e p : p === e -> ~~ (p <<< e).
+Proof.
+rewrite /point_on_edge /point_strictly_under_edge.
+rewrite /generic_trajectories.point_strictly_under_edge R_ltb_lt subrr.
+by move=> /andP[/eqP -> valep]; rewrite ltxx.
+Qed.
+
+Lemma strict_nonAunder e p : valid_edge e p ->
+  (p <<< e) = (~~ (p === e)) && (p <<= e).
+Proof.
+move=> valep.
+rewrite /point_strictly_under_edge /point_on_edge /point_under_edge.
+rewrite /generic_trajectories.point_strictly_under_edge R_ltb_lt.
+rewrite /generic_trajectories.point_under_edge !subrr.
+by rewrite valep andbT lt_neqAle.
+Qed.
+
+Lemma under_edge_strict_lower_y (r r' : pt) e :
+  r.x = r'.x -> r != r' -> r <<= e -> r' === e -> r.y < r'.y.
+Proof.
+move=> xs nq under on'.
+have  vr : valid_edge e r.
+  by move: on'; rewrite /valid_edge/generic_trajectories.valid_edge xs=> /andP[].
+move: under; rewrite (under_onVstrict vr)=> /orP[on | ].
+  by case/negP: nq; rewrite pt_eqE (on_edge_same_point on on') xs// !eqxx.
+by rewrite (strict_under_edge_lower_y xs).
+Qed.
+
+Lemma above_edge_strict_higher_y (r r' : pt)  e :
+  r.x = r'.x -> r != r' -> r >>= e -> r' === e -> r'.y < r.y.
+Proof.
+move=> xs nq above on'.
+have  vr : valid_edge e r.
+  by move: on'; rewrite /valid_edge/generic_trajectories.valid_edge xs=> /andP[].
+move: above; rewrite (strict_under_edge_lower_y xs on') // -leNgt le_eqVlt.
+move/orP=> [/eqP ys | //].
+by case/negP: nq; rewrite pt_eqE xs ys !eqxx.
+Qed.
+
+Lemma under_edge_lower_y r r' e :
+  r.x = r'.x -> r' === e -> (r <<= e) = (r.y <= r'.y).
+Proof.
+move=> rr' rone.
+have valre : valid_edge e r.
+  by case/andP: rone; rewrite /valid_edge/generic_trajectories.valid_edge rr'.
+move: (valre)=> /andP[] + _; rewrite le_eqVlt=> /orP[/eqP atl| inr].
+  have req : r' = left_pt e.
+    have rltr : r'.x < (right_pt e).x by rewrite -rr' -atl edge_cond.
+    have /esym := edge_and_left_vertical_eq rltr (esym (etrans atl rr')).
+    by move/andP: rone => [] -> _ /eqP.
+  by move/pue_left_edge: atl; rewrite subr_ge0 -req.
+have rue' : (r <<= e) = (area3 r (left_pt e) r' <= 0).
+  move: rone=> /andP[] /[dup] tmp /eqP /area3_triangle_on_edge + _ => /(_ r).
+(* TODO : fix area3_triangle_on_edge for cycle *)
+  rewrite (area3_opposite (left_pt _)).
+  rewrite (area3_opposite (left_pt _) _ (right_pt _)) !mulrN.
+  move=> /eqP; rewrite inj_eq; last by apply: oppr_inj.
+  move/eqP => signcond.
+  move: (edge_cond e); rewrite -subr_gt0 => /pmulr_rle0 <-.
+  rewrite /point_under_edge/generic_trajectories.point_under_edge subrr.
+  by rewrite signcond pmulr_rle0; last rewrite subr_gt0 -rr'.
+have inr' : (left_pt e).x < r'.x by rewrite -rr'.
+rewrite /point_under_edge/generic_trajectories.point_under_edge subrr.
+have /pue_right_edge : (right_pt (Bedge inr')).x = r.x by rewrite /= rr'.
+move: rue'.
+rewrite /point_under_edge/generic_trajectories.point_under_edge subrr=> rue'.
+by rewrite rue' subr_le0.
+Qed.
+
+Lemma aligned_trans a a' b p : a.x != b.x ->
+  area3 a' a b = 0 -> area3 p a b = 0 -> area3 p a' b = 0.
+Proof.
+rewrite -area3_cycle.
+move=> bna /[dup] /area3_triangle_on_edge proc a'ab pab.
+apply/eqP.
+have /mulfI/inj_eq <- : a.x - b.x != 0 by rewrite subr_eq0.
+by rewrite -area3_cycle -(proc _) area3_cycle pab !mulr0.
+Qed.
+
+Lemma area3_change_ext a b a' b' p :
+  a.x < b.x -> a'.x < b'.x ->
+  area3 a' a b = 0 -> area3 b' a b = 0 ->
+  sg (area3 p a b) = sg (area3 p a' b').
+Proof.
+move=> altb altb' ona onb.
+have /area3_triangle_on_edge := ona => /(_ p) ona'.
+have /area3_triangle_on_edge := onb => /(_ p) onb0.
+have /area3_triangle_on_edge : area3 b' a' a = 0.
+  have bna : b.x != a.x by case: ltrgtP altb.
+  by rewrite (aligned_trans bna) // area3_opposite;
+    apply/eqP; rewrite oppr_eq0 area3_cycle; exact/eqP.
+move=>/(_ p) onb'.
+have difab : 0 < b.x - a.x by rewrite subr_gt0.
+have difab' : 0 < b'.x - a'.x by rewrite subr_gt0.
+have [ | | aa' ] := ltrgtP (a.x) (a'.x); last first.
+- set w := Bedge altb.
+  have/on_edge_same_point tmp : a === Bedge altb by exact: left_on_edge.
+  have/(tmp _) : a' === Bedge altb.
+    rewrite /point_on_edge ona /valid_edge/generic_trajectories.valid_edge.
+    rewrite eqxx/=.
+    by rewrite /= -aa' lexx ltW.
+  rewrite aa' => /(_ erefl) ays.
+  have aa : a = a' by move: (a) (a') aa' ays=> [? ?][? ?] /= -> ->.
+  rewrite -aa area3_opposite [in RHS]area3_opposite.
+  rewrite -[RHS]mul1r -(gtr0_sg difab) -sgrM mulrN onb0 [X in _ - X]aa' -mulrN.
+  by rewrite sgrM (gtr0_sg difab') mul1r.
+- rewrite -subr_gt0=> xalta'; rewrite -[RHS]mul1r -(gtr0_sg xalta') -sgrM.
+  rewrite [in RHS]area3_opposite mulrN onb' -mulrN sgrM (gtr0_sg difab').
+  rewrite -area3_opposite -[in RHS]area3_cycle.
+  rewrite -(gtr0_sg difab) -sgrM ona' [in RHS]area3_opposite.
+  by rewrite mulrN -mulNr opprB sgrM (gtr0_sg xalta') mul1r.
+rewrite -subr_lt0=> xa'lta; apply/esym.
+rewrite area3_opposite -[X in -X]mul1r -mulNr sgrM sgrN1.
+rewrite -(ltr0_sg xa'lta) -sgrM onb' sgrM (gtr0_sg difab').
+rewrite area3_opposite -area3_cycle sgrN mulrN -(gtr0_sg difab).
+rewrite -sgrM ona' -sgrN -mulNr opprB sgrM (ltr0_sg xa'lta).
+by rewrite area3_opposite sgrN mulrN mulNr opprK mul1r.
+Qed.
+
+Lemma under_low_imp_under_high low_e high_e p  :
+  left_pt low_e <<= high_e ->
+  right_pt low_e <<= high_e ->
+  valid_edge low_e p ->
+  valid_edge high_e p ->
+  p <<= low_e -> p <<= high_e.
+Proof.
+move : low_e high_e => [ll lr inL] [hl hr inH] /= pulh purh vallow valhigh.
+have [p' vip] := exists_point_valid vallow.
+have := intersection_on_edge vip => [][] poep' eqx'.
+have [p'' vip'] := exists_point_valid valhigh.
+have := intersection_on_edge vip' => [][] poep'' eqx''{vip' vip}.
+have := poep''.
+have := poep'.
+
+rewrite /point_on_edge /valid_edge
+  /generic_trajectories.valid_edge =>  /andP [] /= poepf' /andP []
+ linfp' p'infr   /andP [] /= poepf'' /andP [] linfp'' p''infr.
+
+rewrite -area3_cycle in poepf'.
+rewrite -eqx' in linfp' p'infr.
+rewrite -eqx'' in linfp'' p''infr.
+move => puep.
+
+have ydiff : p.y <= p'.y by rewrite -(under_edge_lower_y eqx' poep').
+
+rewrite eqx' in eqx''.
+have puep' := point_on_edge_under  poep' pulh purh.
+have y'diff : p'.y <= p''.y by rewrite -(under_edge_lower_y eqx'' poep'').
+have y''diff : p.y  <= p''.y by rewrite (le_trans  ydiff y'diff).
+rewrite -eqx' in eqx''.
+have := ax4_three_triangles p hl hr p''.
+have pHleq := area3_vert hl eqx''.
+have /eqP pHreq :=  (area3_vert hr eqx'').
+rewrite -area3_cycle in pHreq.
+rewrite area3_opposite -area3_cycle in pHleq.
+
+move : poepf'' pHreq => /eqP -> /eqP -> .
+have : area3 p hl p'' = - ((p.x - hl.x) * (p''.y - p.y)) by rewrite -pHleq opprK.
+move => ->.
+rewrite add0r -mulrBl.
+rewrite  [x in (x - _) * _ = _] addrC.
+rewrite addrKA opprK.
+
+rewrite /= {pulh purh vallow valhigh poep' poep'' poepf' puep puep'}.
+rewrite underE.
+rewrite addrC.
+have inH' := inH.
+rewrite -subr_cp0 in inH'.
+rewrite -subr_ge0 in y''diff.
+move => <-.
+by rewrite nmulr_rle0.
+Qed.
+
+Lemma under_low_imp_strict_under_high low_e high_e p  :
+  left_pt low_e <<= high_e ->
+  right_pt low_e <<= high_e ->
+  valid_edge low_e p ->
+  valid_edge high_e p ->
+  p <<< low_e -> p <<< high_e.
+Proof.
+move : low_e high_e => [ll lr inL] [hl hr inH]  /=.
+move => pulh purh vallow valhigh.
+have [p' vip] := exists_point_valid vallow.
+have := intersection_on_edge vip => [][] poep' eqx'.
+have [p'' vip'] := exists_point_valid valhigh.
+have := intersection_on_edge vip' => [][] poep'' eqx''{vip' vip}.
+have := poep''.
+have := poep'.
+
+rewrite /point_on_edge /valid_edge =>  /andP [] /= poepf' /andP []
+ linfp' p'infr   /andP [] /= poepf'' /andP [] linfp'' p''infr.
+
+rewrite -area3_cycle in poepf'.
+rewrite -eqx' in linfp' p'infr.
+rewrite -eqx'' in linfp'' p''infr.
+move => puep.
+
+have ydiff : p.y < p'.y by rewrite -(strict_under_edge_lower_y eqx' poep').
+
+rewrite eqx' in eqx''.
+have puep' := point_on_edge_under  poep' pulh purh.
+have y'diff : p'.y <= p''.y by rewrite -(under_edge_lower_y eqx'' poep'').
+have y''diff : p.y  < p''.y by rewrite (lt_le_trans  ydiff y'diff).
+rewrite -eqx' in eqx''.
+have := ax4_three_triangles p hl hr p''.
+have pHleq := area3_vert hl eqx''.
+have /eqP pHreq := area3_vert hr eqx''.
+rewrite -area3_cycle in pHreq.
+rewrite area3_opposite -area3_cycle in pHleq.
+
+move : poepf'' pHreq => /eqP -> /eqP -> .
+have :  area3 p hl p'' = - ((p.x - hl.x) * (p''.y - p.y)).
+  by rewrite -pHleq opprK.
+move => ->.
+rewrite add0r -mulrBl.
+rewrite [x in (x - _) * _ = _]addrC.
+rewrite addrKA opprK.
+
+rewrite /= {pulh purh vallow valhigh poep' poep'' poepf' puep puep'}.
+rewrite addrC.
+have inH' := inH.
+rewrite -subr_cp0 in inH'.
+rewrite -subr_gt0 in y''diff.
+rewrite strictE => <-.
+by rewrite nmulr_rlt0.
+Qed.
+
+Lemma under_low_imp_under_high_bis low_e high_e p  :
+  ~~ (left_pt high_e <<< low_e) ->
+  ~~ (right_pt high_e <<< low_e) ->
+  valid_edge low_e p ->
+  valid_edge high_e p ->
+  p <<= low_e -> p <<= high_e.
+Proof.
+move : low_e high_e => [ll lr inL] [hl hr inH]  .
+move => pabhl pabhr vallow valhigh.
+have [p' vip] := exists_point_valid vallow.
+have := intersection_on_edge vip => [][] poep' eqx'.
+have [p'' vip'] := exists_point_valid valhigh.
+have  := intersection_on_edge vip' => [][] poep'' eqx''{vip' vip}.
+have := poep''.
+have := poep'.
+
+rewrite /point_on_edge /valid_edge =>  /andP [] /= poepf' /andP []
+ linfp' p'infr   /andP [] /= poepf'' /andP [] linfp'' p''infr.
+
+rewrite -area3_cycle in poepf'.
+rewrite -eqx' in linfp' p'infr.
+rewrite -eqx'' in linfp'' p''infr.
+move => /= puep.
+
+have ydiff : p.y <= p'.y by rewrite -(under_edge_lower_y eqx' poep').
+rewrite eqx' in eqx''.
+symmetry in eqx''.
+have pabp' := point_on_edge_above  poep'' pabhl pabhr.
+have y'diff : p'.y <= p''.y by rewrite leNgt -(strict_under_edge_lower_y eqx'' poep').
+have y''diff : p.y  <= p''.y by rewrite (le_trans  ydiff y'diff).
+rewrite -eqx' in eqx''.
+have := ax4_three_triangles p hl hr p''.
+have /eqP pHleq :=  (area3_vert hl eqx'').
+have pHreq := area3_vert hr eqx''.
+
+rewrite area3_opposite in pHreq.
+rewrite area3_cycle in pHleq.
+
+move : poepf'' pHleq => /eqP  -> /eqP -> .
+have :  area3 p p'' hr = - ((p''.x - hr.x) * (p.y - p''.y)) by rewrite -pHreq opprK.
+move => ->.
+rewrite add0r addrC -mulrBl.
+rewrite [x in (x - _) * _ = _]addrC.
+rewrite addrKA opprK.
+
+rewrite /= {pabhl pabhr vallow valhigh poep' poep'' poepf' puep pabp'}.
+rewrite addrC.
+have inH' := inH.
+rewrite -subr_gte0 in inH'.
+rewrite -subr_le0 in y''diff.
+rewrite underE => <-.
+by rewrite pmulr_rle0.
+Qed.
+
+Lemma under_low_imp_strict_under_high_bis low_e high_e p  :
+  ~~ (left_pt high_e <<< low_e) ->
+  ~~ (right_pt high_e <<< low_e) ->
+  valid_edge low_e p ->
+  valid_edge high_e p ->
+  p <<< low_e -> p <<< high_e.
+Proof.
+move : low_e high_e => [ll lr inL] [hl hr inH]  .
+move => pabhl pabhr vallow valhigh.
+have [p' vip] := exists_point_valid vallow.
+have := intersection_on_edge vip => [][] poep' eqx'.
+have [ p'' vip'] := exists_point_valid valhigh.
+have  := intersection_on_edge vip' => [][] poep'' eqx''{vip' vip}.
+have := poep''.
+have := poep'.
+
+rewrite /point_on_edge /valid_edge =>  /andP [] /= poepf' /andP []
+ linfp' p'infr   /andP [] /= poepf'' /andP [] linfp'' p''infr.
+
+rewrite -area3_cycle in poepf'.
+rewrite -eqx' in linfp' p'infr.
+rewrite -eqx'' in linfp'' p''infr.
+move => /= puep.
+
+have ydiff : p.y < p'.y by rewrite -(strict_under_edge_lower_y eqx' poep').
+
+rewrite eqx' in eqx''.
+symmetry in eqx''.
+have pabp' := point_on_edge_above poep'' pabhl pabhr.
+have y'diff : p'.y <= p''.y
+   by rewrite leNgt -(strict_under_edge_lower_y eqx'' poep').
+have y''diff : p.y  < p''.y by rewrite (lt_le_trans  ydiff y'diff).
+rewrite -eqx' in eqx''.
+have := ax4_three_triangles p hl hr p''.
+have /eqP pHleq :=  (area3_vert hl eqx'').
+have pHreq :=  (area3_vert hr eqx'').
+
+rewrite area3_opposite in pHreq.
+rewrite area3_cycle in pHleq.
+
+move : poepf'' pHleq => /eqP  -> /eqP -> .
+have : area3 p p'' hr = - ((p''.x - hr.x) * (p.y - p''.y)).
+  by rewrite -pHreq opprK.
+move => ->.
+rewrite add0r addrC -mulrBl.
+rewrite [x in (x - _) * _ = _]addrC.
+rewrite addrKA opprK.
+
+rewrite /= {pabhl pabhr vallow valhigh poep' poep'' poepf' puep pabp'}.
+rewrite addrC.
+have inH' := inH.
+rewrite -subr_gte0 in inH'.
+rewrite -subr_lt0 in y''diff.
+rewrite strictE => <-.
+by rewrite pmulr_rlt0.
+Qed.
+
+Lemma order_edges_viz_point' low_e high_e p :
+valid_edge low_e p -> valid_edge high_e p ->
+low_e <| high_e ->
+p <<= low_e -> p <<= high_e.
+Proof.
+move => vallow valhigh.
+have  := (exists_point_valid  vallow  ) .
+have := (exists_point_valid  valhigh  ) => [][] ph verhigh [] pl verlow.
+have  := intersection_on_edge verlow => [][] poepl eqxl.
+have  := intersection_on_edge verhigh => [][] poeph eqxh.
+rewrite /edge_below => /orP [] /andP [].
+  move => pueplow puephigh.
+  apply (under_low_imp_under_high pueplow puephigh vallow valhigh).
+move => pabpleft pabpright.
+  apply (under_low_imp_under_high_bis pabpleft pabpright vallow valhigh).
+Qed.
+
+Lemma order_edges_strict_viz_point' low_e high_e p :
+valid_edge low_e p -> valid_edge high_e p ->
+low_e <| high_e ->
+p <<< low_e ->  p <<< high_e.
+Proof.
+move => vallow valhigh.
+have  := (exists_point_valid  vallow  ) .
+have := (exists_point_valid  valhigh  ) => [][] ph verhigh [] pl verlow.
+have  := intersection_on_edge verlow => [][] poepl eqxl.
+have  := intersection_on_edge verhigh => [][] poeph eqxh.
+rewrite /edge_below => /orP [] /andP [].
+  set A := left_pt low_e.
+  set B := right_pt low_e.
+  move => pueplow puephigh.
+  move =>  inf0.
+  have:= inf0; rewrite strictE.
+  move=> /ltW; rewrite -/A -/B => infeq0.
+  have := (under_low_imp_strict_under_high pueplow puephigh vallow valhigh inf0).
+  by rewrite strictE.
+move=> pueplow puephigh.
+move=> inf0.
+by have := (under_low_imp_strict_under_high_bis pueplow puephigh vallow valhigh inf0).
+Qed.
+
+Lemma edge_dir_intersect p1 p2 e1 :
+  p1.x != p2.x ->
+  ~~ (p1 <<= e1) -> p2 <<< e1 ->
+ exists p, area3 p (left_pt e1) (right_pt e1) = 0 /\
+      area3 p p1 p2 = 0 /\
+   (forall q, area3 q (left_pt e1) (right_pt e1) = 0 ->
+       area3 q p1 p2 = 0 -> p = q).
+Proof.
+move=> dif12.
+rewrite underE.
+rewrite area3E -ltNge => ca.
+rewrite strictE.
+rewrite area3E => cu.
+have [px [py []]] := line_intersection dif12 ca cu.
+rewrite -/((Bpt px py).y); set py' := ((Bpt px py).y).
+rewrite -/((Bpt px py).x) /py' {py'}.
+move: ca cu; rewrite -4!area3E=> ca cu on_line1 [] on_line2 uniq.
+exists (Bpt px py); rewrite on_line1 on_line2;split;[ | split]=> //.
+by move=> [qx qy]; rewrite !area3E=> /uniq => U; move=> {}/U[] /= -> ->.
+Qed.
+
+Lemma intersection_middle_au e1 e2 :
+  ~~ (left_pt e2 <<= e1) -> right_pt e2 <<< e1 ->
+  exists p, area3 p (left_pt e1) (right_pt e1) = 0 /\ p === e2.
+Proof.
+move=> /[dup] ca; rewrite -ltNge subrr=> ca' /[dup] cu cu'.
+rewrite strictE in cu'.
+have le2xnre2x : (left_pt e2).x != (right_pt e2).x.
+  by have := edge_cond e2; rewrite lt_neqAle=> /andP[].
+have [p [p1 [p2 pu]]] := edge_dir_intersect le2xnre2x ca cu.
+exists p; rewrite p1; split=> //.
+rewrite /point_on_edge p2 eqxx /= /valid_edge.
+rewrite /generic_trajectories.valid_edge.
+have ol2 := p2.
+have := area3_on_edge (left_pt e1) (right_pt e1) ol2 => /=.
+rewrite p1 mulr0 => /esym/eqP; rewrite addrC addr_eq0 -mulNr opprB=> /eqP signcond.
+case : (ltP (p.x) ((right_pt e2).x)).
+  move=>/[dup]/ltW ->; rewrite andbT -subr_gt0 -subr_le0.
+  rewrite -(pmulr_lgt0 _ ca') signcond.
+  by rewrite nmulr_lgt0 // => /ltW.
+move=>/[dup] re2lp.
+rewrite -subr_le0 -(pmulr_lle0 _ ca') signcond.
+by rewrite nmulr_lle0 // subr_ge0=> /(le_trans re2lp); rewrite leNgt edge_cond.
+Qed.
+
+Lemma intersection_middle_ua e1 e2 :
+  left_pt e2 <<< e1 -> ~~(right_pt e2 <<= e1) ->
+  exists p, area3 p (left_pt e1) (right_pt e1) = 0 /\ p === e2.
+Proof.
+move=> /[dup] cu cu' /[dup] ca; rewrite -ltNge subrr=> ca'.
+rewrite strictE in cu'.
+have re2xnle2x : (right_pt e2).x != (left_pt e2).x.
+  by have := edge_cond e2; rewrite lt_neqAle eq_sym=> /andP[].
+have [p [p1 [p2 pu]]] := edge_dir_intersect re2xnle2x ca cu.
+move: p2; rewrite area3_opposite area3_cycle => /eqP.
+rewrite oppr_eq0=> /[dup] /eqP ol2 p2.
+exists p; rewrite p1; split=> //.
+rewrite /point_on_edge p2/= /valid_edge.
+rewrite /generic_trajectories.valid_edge.
+have := area3_on_edge (left_pt e1) (right_pt e1) ol2 => /=.
+rewrite p1 mulr0 => /esym/eqP; rewrite addrC addr_eq0 -mulNr opprB=> /eqP signcond.
+case : (ltP (p.x) ((right_pt e2).x)).
+  move=>/[dup]/ltW ->; rewrite andbT -subr_gt0 -subr_le0.
+  rewrite -(nmulr_llt0 _ cu') signcond.
+  by rewrite pmulr_llt0 // => /ltW.
+move=>/[dup] re2lp.
+rewrite -subr_le0 -(nmulr_lge0 _ cu') signcond.
+by rewrite pmulr_lge0 // subr_ge0=> /(le_trans re2lp); rewrite leNgt edge_cond.
+Qed.
+
+Definition lexPt (p1 p2 : pt) : bool :=
+  (p1.x < p2.x) || ((p1.x == p2.x) && (p1.y < p2.y)).
+
+Definition lexePt (p1 p2 : pt) : bool :=
+    (p1.x < p2.x) || ((p1.x == p2.x) && (p1.y <= p2.y)).
+
+Lemma lexPtW p1 p2 : lexPt p1 p2 -> lexePt p1 p2.
+Proof.
+rewrite /lexPt /lexePt =>/orP [-> //=| /andP [] -> y_ineq].
+rewrite ltW //. 
+by rewrite orbT.
+Qed.
+
+Lemma lexePtNgt (p1 p2 : pt) : lexePt p1 p2 = ~~lexPt p2 p1.
+Proof.
+rewrite /lexePt /lexPt negb_or negb_and.
+rewrite andb_orr -leNgt (andbC (_ <= _)) (eq_sym (p2.x)) -lt_neqAle.
+rewrite -leNgt (le_eqVlt (p1.x)).
+by case: (p1.x < p2.x) => //; rewrite ?orbF //=.
+Qed.
+
+Lemma lexPtNge (p1 p2 : pt) : lexPt p1 p2 = ~~lexePt p2 p1.
+Proof.
+rewrite /lexePt /lexPt.
+rewrite negb_or -leNgt negb_and (eq_sym (p2.x)) andb_orr (andbC (_ <= _)).
+rewrite -lt_neqAle le_eqVlt -ltNge.
+by case: (p1.x < p2.x); rewrite // ?orbF.
+Qed.
+
+Lemma lexePt_eqVlt (p1 p2 :pt) : lexePt p1 p2 = (p1 == p2) || lexPt p1 p2.
+Proof.
+rewrite /lexePt /lexPt.
+case: (ltrgtP (p1.x) (p2.x))=> cnd; rewrite ?orbT //= ?orbF.
+  by apply/esym/negP=> /eqP p1p2; move: cnd; rewrite p1p2 ltxx.
+apply/idP/idP.
+  rewrite orbC le_eqVlt=> /orP[/eqP | ->// ].
+  move: cnd; case: p1 => [a b]; case: p2 => [c d]/= -> ->.
+  by rewrite eqxx orbT.
+by move/orP=> [/eqP -> // | /ltW].
+Qed.
+
+Lemma lexPt_irrefl : irreflexive lexPt.
+Proof.
+move=> x; apply/negP=> /[dup] abs.
+by rewrite lexPtNge lexePt_eqVlt abs orbT.
+Qed.
+
+Lemma lexePt_refl : reflexive lexePt.
+Proof.
+rewrite /reflexive /lexePt=> p.
+by rewrite eqxx le_refl /= orbT.
+Qed.
+
+Lemma lexPt_trans  : transitive lexPt.
+Proof.
+  rewrite /transitive /lexPt => p2 p1 p3 => /orP [xineq /orP [xineq2| /andP []/eqP <- yineq]|/andP []/eqP -> yineq /orP [-> //|/andP [] /eqP -> yineq2]] .
+      by rewrite (lt_trans xineq xineq2).
+    by rewrite xineq.
+  by rewrite (lt_trans yineq yineq2) eqxx orbT.
+Qed.
+
+Lemma lexePt_lexPt_trans p1 p2 p3 : 
+lexePt p1 p2 -> lexPt p2 p3 -> lexPt p1 p3.
+Proof.
+rewrite /lexePt /lexPt => /orP  [x_ineq|/andP  [] /eqP -> y_ineq /orP [-> // |/andP []/eqP -> y_s]].
+  have : lexPt p1 p2.
+    by rewrite /lexPt x_ineq.
+  by apply lexPt_trans.
+by rewrite( le_lt_trans y_ineq y_s) eqxx /= orbT.
+Qed.
+
+Lemma lexPt_lexePt_trans p1 p2 p3 :
+lexPt p1 p2 -> lexePt p2 p3 -> lexPt p1 p3.
+Proof.
+move/[swap].
+rewrite /lexePt /lexPt => /orP  [x_ineq|/andP  [] /eqP -> y_ineq /orP [-> // |/andP []/eqP -> y_s]].
+  have : lexPt p2 p3.
+    by rewrite /lexPt x_ineq.
+  move/[swap]; apply lexPt_trans.
+by rewrite( lt_le_trans y_s y_ineq) eqxx /= orbT.
+Qed.
+
+Lemma lexePt_trans : transitive lexePt.
+move => p2 p1 p3; rewrite lexePt_eqVlt => /orP[/eqP-> // | p1p2] p2p3.
+by apply/lexPtW/(lexPt_lexePt_trans p1p2).
+Qed.
+
+Lemma lexePt_xW p1 p2 : lexePt p1 p2 -> p1.x <= p2.x.
+Proof.
+by rewrite /lexePt=> /orP[/ltW | /andP [/eqP -> _]].
+Qed.
+
+Lemma on_edge_lexePt_left_pt (p : pt) g :
+  p === g -> lexePt (left_pt g) p.
+Proof.
+move=> on.
+have : (left_pt g).x <= p.x by move: on=> /andP[] _ /andP[].
+rewrite le_eqVlt=> /orP[/eqP/esym /[dup] samex' samex | xlt ].
+ have/eqP samey := on_edge_same_point on (left_on_edge _) samex.
+  have -> : p = left_pt g.
+    by apply/eqP; rewrite pt_eqE samex' samey !eqxx.
+  by apply: lexePt_refl.
+by rewrite /lexePt xlt.
+Qed.
+
+Lemma trans_edge_below_out p e1 e2 e3 :
+  left_pt e1 = p -> left_pt e2 = p -> left_pt e3 = p ->
+  e1 <| e2 -> e2 <| e3 -> e1 <| e3.
+Proof.
+case: e1 => [d [a_x a_y] /= cpa].
+case: e2 => [d' [b_x b_y] /= cpb].
+case: e3 => [d'' [c_x c_y] /= cpc] dp d'p d''p.
+rewrite /edge_below !underE !strictE.
+rewrite !area3E; simpl left_pt; simpl right_pt.
+move: cpa cpb cpc; rewrite dp d'p d''p {dp d'p d''p}.
+case: p=> [px py]; simpl p_x; simpl p_y=> cpa cpb cpc.
+move=> c1' c2'.
+have c1 : 0 <= pue_f px py a_x a_y b_x b_y.
+  move: c1'; rewrite !(pue_f_eq _ _ _ _) lexx ltxx !andTb -leNgt.
+  by rewrite pue_f_o oppr_lte0 (pue_f_c px)=> /orP[].
+have c2 : 0 <= pue_f px py b_x b_y c_x c_y.
+  move: c2'; rewrite !(pue_f_eq _ _ _ _) lexx ltxx !andTb -leNgt.
+  by rewrite pue_f_o oppr_lte0 (pue_f_c px)=> /orP[].
+move=> {c1' c2'}.
+apply/orP; left.
+rewrite (pue_f_eq _ _ _ _) lexx andTb pue_f_o -pue_f_c oppr_lte0.
+set p := Bpt px py.
+have aright : 0 < area3 p (subpoint p) (Bpt a_x a_y).
+  by apply: point_sub_right.
+have bright : 0 < area3 p (subpoint p) (Bpt b_x b_y).
+  by apply: point_sub_right.
+have cright : 0 < area3 p (subpoint p) (Bpt c_x c_y).
+  by apply: point_sub_right.
+rewrite area3E in aright; simpl p_x in aright; simpl p_y in aright.
+rewrite area3E in bright; simpl p_x in bright; simpl p_y in bright.
+rewrite area3E in cright; simpl p_x in cright; simpl p_y in cright.
+rewrite -(pmulr_lge0 _ bright) -pue_f_ax5.
+by apply: addr_ge0; rewrite pmulr_lge0.
+Qed.
+
+Lemma no_crossingE e1 e2 :
+  below_alt e1 e2 -> valid_edge e2 (left_pt e1) ->
+  (left_pt e1 <<< e2 -> e1 <| e2) /\ (~~(left_pt e1 <<= e2) -> e2 <| e1).
+Proof.
+move=> nc ve.
+case: (exists_point_valid ve) => [p pP].
+move: (intersection_on_edge pP)=> [pone2 px].
+move: (pone2); rewrite /point_on_edge=> /andP[] pone2' vp.
+have xbnd1 : (left_pt e2).x <= (left_pt e1).x by case/andP: ve.
+have xbnd2 : (left_pt e1).x <= (right_pt e2).x by case/andP: ve.
+have dify : ((left_pt e1 <<< e2) \/ (~~(left_pt e1 <<= e2))) -> (left_pt e1).y != p.y.
+  move=> disj; apply/negP=> /eqP A.
+  have {A}-A : p = left_pt e1 by case: (p) (left_pt e1) px A=> [? ?][? ?]/= -> ->.
+  by move: disj; rewrite under_onVstrict // strict_nonAunder // -A pone2; case.
+have pone2'': pue_f ((left_pt e2).x) ((left_pt e2).y)
+             ((right_pt e2).x) ((right_pt e2).y)
+             (p.x) (p.y) = 0.
+  rewrite -pue_f_c; move: pone2'; rewrite area3E pue_f_c.
+  by move/eqP.
+move: (edge_cond e2); rewrite -(subr_gt0 (_.x))=> ce2.
+have dife2 : 0 < (right_pt e2).x - (left_pt e2).x.
+  by move: (edge_cond e2); rewrite -(subr_gt0 (_.x)).
+have dife2' : (right_pt e2).x - (left_pt e2).x != 0.
+  by move: dife2; rewrite  lt_neqAle eq_sym=> /andP[].
+have plp2 : (left_pt e2).x = (left_pt e1).x -> p = left_pt e2.
+  move=> c; have:= on_edge_same_point pone2 (left_on_edge _).
+  rewrite c px => /(_ erefl); move: px c.
+  by case: (p) (left_pt e2)=> [? ?][? ?]/= <- <- ->.
+have prp2 : (right_pt e2).x = (left_pt e1).x -> p = right_pt e2.
+  move=> c; have:= on_edge_same_point pone2 (right_on_edge _).
+  rewrite c px => /(_ erefl); move: px c.
+  by case: (p) (right_pt e2)=> [? ?][? ?]/= <- <- ->.
+have main : (0 < area3 (left_pt e1) (left_pt e2) (right_pt e2)) =
+       (p.y < (left_pt e1).y).
+  move: xbnd1; rewrite le_eqVlt=> /orP[/eqP atleft | notleft ].
+    have pisl : p = left_pt e2 by apply: plp2.
+    move: atleft; rewrite -pisl=> atleft; rewrite edge_and_left_vertical //.
+    by rewrite -atleft pisl (edge_cond e2).
+  have fact1 : (0 < p.x - (left_pt e2).x) by rewrite subr_gt0 -px.
+  rewrite -(pmulr_rgt0 _ fact1) area3_opposite mulrN.
+  rewrite -(area3_triangle_on_edge (left_pt e1) (eqP pone2')) -mulrN.
+  rewrite -area3_opposite area3_cycle pmulr_rgt0 //.
+  by apply: edge_and_right_vertical; rewrite -px.
+have arith : forall (a b : R), a <= 0 -> b <= 0 -> a + b <= 0.
+  clear=> a b al0 bl0.
+  by rewrite -lerBrDr (le_trans al0) // lerBrDr add0r.
+have case1 : left_pt e1 <<< e2 -> e1 <| e2.
+  move=> below; case:(nc) => // /orP[]; last by rewrite below.
+  move/andP=> []le2b re2b.
+  have pyne1 : (left_pt e1).y != p.y by apply: dify; left.
+  have ys : (left_pt e1).y < p.y.
+    rewrite ltNge le_eqVlt -main negb_or eq_sym pyne1 /= -leNgt le_eqVlt.
+    by move: (below); rewrite strictE orbC => ->.
+  have : 0 < area3 p (left_pt e1) (right_pt e1).
+    by rewrite edge_and_left_vertical // -px (edge_cond e1).
+  rewrite -(pmulr_rgt0 _ ce2).
+  rewrite (area3_on_edge (left_pt e1) (right_pt e1) (eqP pone2')).
+  rewrite ltNge arith //.
+    apply: mulr_ge0_le0; first by rewrite -px subr_ge0.
+    by move: re2b; rewrite underE -area3_cycle.
+  apply: mulr_ge0_le0; first by rewrite -px subr_ge0.
+  by move: le2b;
+    rewrite /point_under_edge/generic_trajectories.point_under_edge subrr.
+suff case2 : ~~(left_pt e1 <<= e2) -> e2 <| e1 by [].
+move=> above; case: (nc) => // /orP[]; first by rewrite (negbTE above).
+rewrite !strictE -!leNgt => /andP[] le2a re2a.
+have pyne1 : (left_pt e1).y != p.y by apply: dify; right.
+have ys : p.y < (left_pt e1).y.
+  by rewrite -main;move: (above); rewrite /point_under_edge -ltNge subrr.
+have : 0 < area3 (left_pt e1) p (right_pt e1).
+  by rewrite edge_and_left_vertical // (edge_cond e1).
+rewrite area3_opposite -area3_cycle.
+rewrite -(pmulr_rgt0 _ dife2) mulrN.
+rewrite (area3_on_edge (left_pt e1) (right_pt e1) (eqP pone2')).
+by rewrite oppr_gt0 ltNge addr_ge0 // mulr_ge0 // -px subr_ge0.
+Qed.
+
+
+Lemma inter_at_ext_no_crossing (s : seq edge) :
+  {in s &, forall e1 e2, inter_at_ext e1 e2} ->
+  {in s &, no_crossing}.
+Proof.
+move=> nc e1 e2 e1in e2in.
+have nc' := inter_at_ext_sym nc.
+have ceq : e1 = e2 -> below_alt e1 e2.
+  move=> <-; left; apply/orP; left; rewrite !underE.
+  rewrite (fun a b => proj1 (area3_two_points a b)).
+  rewrite (fun a b => proj1 (proj2 (area3_two_points a b))).
+  by rewrite lexx.
+have [/eqP/ceq // | e1ne2] := boolP(e1 == e2).
+have [/eqP | {}nc ] := nc _ _ e1in e2in; first by rewrite (negbTE e1ne2).
+have [/eqP | {}nc' ] := nc' _ _ e1in e2in; first by rewrite (negbTE e1ne2).
+have [ | ] := boolP(e1 <| e2); first by left.
+have [ | ] := boolP(e2 <| e1); first by right.
+rewrite /edge_below.
+rewrite !negb_or. rewrite 4!negb_and !negbK.
+rewrite /edge_below !underE.
+rewrite !strictE => noc.
+suff [it | [p [pone1 pone2]]] :
+  below_alt e1 e2 \/ exists p, p === e1 /\ p === e2; first by [].
+  have : p \in [:: left_pt e1; right_pt e1] by apply: nc.
+  rewrite !inE=> pext.
+  set other := if p == left_pt e1 then right_pt e1 else left_pt e1.
+  have dif : right_pt e1 != left_pt e1.
+    apply/eqP=> abs.
+    move: (edge_cond e1); rewrite lt_neqAle eq_sym => /andP[].
+    by rewrite abs eqxx.
+  have [ u' | /underWC a'] := boolP (other <<= e2).
+    left; apply/orP; left.
+    move: (pone2) u'=> /andP[] _ /under_onVstrict.
+    rewrite pone2 /= /other.
+    by  move: pext=> /orP[] /eqP -> ->; rewrite ?eqxx ?(negbTE dif) ?andbT.
+  right; apply/orP; right.
+    move: (pone2) a'=> /andP[] _/strict_nonAunder; rewrite pone2 /= /other.
+    by move: pext=>/orP[]/eqP -> ->; rewrite ?eqxx ?(negbTE dif)=> ->.
+move: noc {nc nc'} => /andP[] /orP[le2a | re2a].
+  have le2a' : left_pt e2 >>> e1.
+    by rewrite /point_under_edge/generic_trajectories.point_under_edge subrr.
+  have [ re2u | re2a _] := boolP(right_pt e2 <<< e1); last first.
+    by left; left; apply/orP; right; rewrite re2a underWC.
+  have dif2 : (left_pt e2).x != (right_pt e2).x.
+    by have := edge_cond e2; rewrite lt_neqAle => /andP[].
+  have [r [_ [ _ uniq]]] := edge_dir_intersect dif2 le2a' re2u.
+  move=> /orP[le1u | re1u].
+    have [re1u | re1a] := boolP(right_pt e1 <<= e2).
+      left; left; apply/orP; left; rewrite re1u underW //.
+      by rewrite strictE.
+    have le1u' : left_pt e1 <<< e2.
+      by rewrite strictE.
+    have [p [pe2 pe1]] := intersection_middle_ua le1u' re1a.
+    have [q [qe1 qe2]] := intersection_middle_au le2a' re2u.
+    move: (pe1) (qe2)=> /andP[] /eqP pe1' _ /andP[] /eqP qe2' _.
+    have rq := uniq _ qe1 qe2'; have rp := uniq _ pe1' pe2.
+    by right; exists r; rewrite [X in X === e2]rq rp.
+  have [le1u | le1a] := boolP(left_pt e1 <<= e2).
+      left; left; apply/orP; left; rewrite le1u underW //.
+      by rewrite strictE.
+  have [q [qe1 qe2]] := intersection_middle_au le2a' re2u.
+  have re1u' : right_pt e1 <<< e2.
+    by rewrite strictE.
+  have [p [pe2 pe1]] := intersection_middle_au le1a re1u'.
+  move: (pe1) (qe2)=> /andP[] /eqP pe1' _ /andP[] /eqP qe2' _.
+  have rq := uniq _ qe1 qe2'; have rp := uniq _ pe1' pe2.
+  by right; exists r; rewrite [X in X === e2]rq rp.
+have re2a' : right_pt e2 >>> e1.
+  by rewrite /point_under_edge/generic_trajectories.point_under_edge subrr.
+have [ le2u | le2a _] := boolP(left_pt e2 <<< e1); last first.
+  by left; left; apply/orP; right; rewrite le2a underWC.
+have dif2 : (right_pt e2).x != (left_pt e2).x.
+  by have := edge_cond e2; rewrite lt_neqAle eq_sym => /andP[].
+have [r [_ [ _ uniq]]] := edge_dir_intersect dif2 re2a' le2u.
+have transfer a b c : area3 a b c = 0 -> area3 a c b = 0.
+  by move=> abc; rewrite area3_opposite area3_cycle abc oppr0.
+move=> /orP[le1u | re1u].
+  have [re1u | re1a] := boolP(right_pt e1 <<= e2).
+    left; left; apply/orP; left; rewrite re1u underW //.
+    by rewrite strictE.
+  have le1u' : left_pt e1 <<< e2.
+    by rewrite strictE.
+  have [p [/transfer pe2 pe1]] := intersection_middle_ua le1u' re1a.
+  have [q [qe1 qe2]] := intersection_middle_ua le2u re2a'.
+  move: (pe1) (qe2)=> /andP[] /eqP pe1' _ /andP[] /eqP /transfer qe2' _.
+  have rq := uniq _ qe1 qe2'; have rp := uniq _ pe1' pe2.
+  by right; exists r; rewrite [X in X === e2]rq rp.
+have [le1u | le1a] := boolP(left_pt e1 <<= e2).
+  left; left; apply/orP; left; rewrite le1u underW //.
+  by rewrite strictE.
+have [q [qe1 qe2]] := intersection_middle_ua le2u re2a'.
+have re1u' : right_pt e1 <<< e2.
+  by rewrite strictE.
+have [p [/transfer pe2 pe1]] := intersection_middle_au le1a re1u'.
+move: (pe1) (qe2)=> /andP[] /eqP pe1' _ /andP[] /eqP /transfer qe2' _.
+have rq := uniq _ qe1 qe2'; have rp := uniq _ pe1' pe2.
+by right; exists r; rewrite [X in X === e2]rq rp.
+Qed.
+
+Lemma outgoing_conditions (s oe : seq edge) p he le :
+  p >>> le -> p <<< he -> le \in s -> he \in s ->
+  valid_edge le p -> valid_edge he p ->
+  {subset oe <= s} ->
+  {in s &, no_crossing} ->
+  {in oe, forall g, left_pt g == p} ->
+  [/\ {in oe, forall g, le <| g}, {in oe, forall g, g <| he} &
+      {in oe &, no_crossing}].
+Proof.
+move=> pl ph lein hein vl vh oesub noc lefts; split.
++ move=> g gin; have := noc _ _ (oesub _ gin) lein.
+  move=>/no_crossingE[]; first by rewrite (eqP (lefts _ _)) // sval.
+  by rewrite (eqP (lefts _ _)) // => _ /(_ pl).
++ move=> g gin; have := noc _ _ (oesub _ gin) hein.
+  move=>/no_crossingE[]; first by rewrite (eqP (lefts _ _)) // sval.
+  by rewrite (eqP (lefts _ _)) // => /(_ ph).
+exact: (sub_in2 oesub).
+Qed.
+
+Lemma common_point_edges_y_left r r1 r2 e1 e2 :
+   valid_edge e1 r -> r.x <= (left_pt e1).x ->
+     r.x = r1.x -> r.x = r2.x -> left_pt e1 === e2 ->
+     r1 === e1 -> r2 === e2 ->
+     r1.y = r2.y.
+Proof.
+move=> v xl rr1 rr2 e1e2 re1 re2.
+have xl': r.x = (left_pt e1).x by apply: le_anti; rewrite xl; case/andP:v.
+have:= on_edge_same_point e1e2 re2; rewrite -xl' rr2 => /(_ erefl) <-.
+have:= on_edge_same_point (left_on_edge _) re1.
+by rewrite -xl' rr1 =>/(_ erefl) <-.
+Qed.
+
+Lemma common_point_edges_y_right r r1 r2 e1 e2 :
+ valid_edge e1 r -> (right_pt e1).x <= r.x ->
+     r.x = r1.x -> r.x = r2.x -> right_pt e1 === e2 ->
+     r1 === e1 -> r2 === e2 ->
+     r1.y = r2.y.
+Proof.
+move=> v xl rr1 rr2 e1e2 re1 re2.
+have xl': r.x = (right_pt e1).x.
+  by apply: le_anti; rewrite xl andbC; case/andP:v.
+have:= on_edge_same_point e1e2 re2; rewrite -xl' rr2 => /(_ erefl) <-.
+have:= on_edge_same_point (right_on_edge _) re1.
+  by rewrite -xl' rr1 =>/(_ erefl) <-.
+Qed.
+
+Lemma expand_valid p q (pq : p.x < q.x) e r :
+  valid_edge (Bedge pq) r ->
+  valid_edge e p -> valid_edge e q -> valid_edge e r.
+Proof.
+move=>/andP[]pr rq /andP[] lep pre /andP[]leq qre; rewrite /valid_edge.
+rewrite /generic_trajectories.valid_edge.
+by rewrite (le_trans lep) ?(le_trans rq).
+Qed.
+
+Lemma keep_under (p q : pt) e1 e2 :
+  inter_at_ext e1 e2 ->
+  {in [:: p; q] & [:: e1; e2], forall r e, valid_edge e r} ->
+  p <<< e1 -> ~~ (p <<< e2) -> ~~(q <<< e1) -> ~~(q <<< e2).
+Proof.
+have left_ext r r1 r2 := @common_point_edges_y_left r r1 r2 e1 e2.
+have right_ext r r1 r2 := @common_point_edges_y_right r r1 r2 e1 e2.
+move=> noc val pue1 pae2 qae1; apply/negP=> que2; set v := valid_edge.
+have : [/\ v e1 p, v e2 p, v e1 q & v e2 q].
+  by split; apply: val; rewrite !inE eqxx ?orbT.
+have pr e r: valid_edge e r ->
+   exists r', [/\ valid_edge e r, r' === e & r.x = r'.x].
+    move=>/[dup]vr/exists_point_valid[r' /intersection_on_edge [one xx]].
+    by exists r'; constructor.
+move=>[]/pr[p1 [vp1 pone1 p1p]] /pr[p2 [vp2 pone2 p2p]].
+move=> /pr[q1 [vq1 qone1 q1q]] /pr[q2 [vq2 qone2 q2q]].
+move: vp1 vp2 vq1 vq2 p1p p2p q1q q2q=>vp1 vp2 vq1 vq2 p1p p2p q1q q2q.
+move: pone1 pone2 qone1 qone2=>pone1 pone2 qone1 qone2 {pr v val}.
+set abbrev := strict_under_edge_lower_y.
+have pylt : p.y < p1.y by rewrite -(abbrev _ _ _ _ pone1).
+have pyge : p2.y <= p.y by rewrite leNgt -(abbrev _ _ _ _ pone2).
+have qyge : q1.y <= q.y by rewrite leNgt -(abbrev _ _ _ _ qone1).
+have qylt : q.y < q2.y by rewrite -(abbrev _ _ _ _ qone2).
+have yp : p2.y < p1.y by rewrite (le_lt_trans pyge).
+have yq : q1.y < q2.y by rewrite (le_lt_trans qyge).
+move=> {pyge qyge pylt qylt abbrev}.
+have [/[dup]p1p2 + /[dup] q1q2 +] : [/\ p1.x == p2.x & q1.x == q2.x].
+  by rewrite -p1p p2p -q1q q2q !eqxx.
+move=>/eqP/esym p2p1 /eqP/esym q2q1.
+move: (pone1) (pone2) (qone1) (qone2).
+move=>/andP[/eqP pl1 _] /andP[/eqP pl2 _] /andP[/eqP ql1 _] /andP[/eqP ql2 _].
+have [pltq | qltp | pq ] := ltrgtP (p.x) (q.x).
+- have [p1q1 p2q2] : p1.x < q1.x /\ p2.x < q2.x.
+    by rewrite -p1p -q1q -p2p -q2q .
+  set e3 := Bedge p1q1; set e4 := Bedge p2q2.
+  have l3a : ~~ (left_pt e3 <<= e4).
+    by move/(@pue_left_edge e4) : p2p1 => -> /=; rewrite subr_ge0 -ltNge.
+  have r3u : right_pt e3 <<< e4.
+    by move/(@psue_right_edge e4) : q2q1 => -> /=; rewrite subr_lt0.
+  have [pi [pi4 /andP[pi3 piint]]] := intersection_middle_au l3a r3u.
+  have pi1 : pi === e1.
+    apply/andP; split; last first.
+      by apply: (expand_valid piint);
+        rewrite /valid_edge/generic_trajectories.valid_edge -?p1p -?q1q.
+    rewrite -sgr_eq0 (area3_change_ext _ (edge_cond e1) p1q1) //.
+    by rewrite (eqP pi3) /sg !eqxx.
+  have pi2 : pi === e2.
+    apply/andP; split; last first.
+      by apply:(expand_valid piint);
+          rewrite /valid_edge/generic_trajectories.valid_edge -?p1p -?q1q.
+    rewrite -sgr_eq0 (area3_change_ext _ (edge_cond e2) p2q2) //.
+    by rewrite pi4 /sg !eqxx.
+  move: piint; rewrite /valid_edge/generic_trajectories.valid_edge.
+  rewrite /e3/= -p1p -q1q=> /andP[] ppi piq.
+  case: noc=> [E | /(_ pi pi1 pi2) piext]; first by move: pae2; rewrite -E pue1.
+  move: (piext) ppi piq pi1 pi2 { pi3 pi4 }; rewrite !inE.
+  move => /orP[]/eqP/[dup]pival -> ppi piq pi1 pi2.
+    have abs := left_ext _ _ _ vp1 ppi p1p p2p pi2 pone1 pone2.
+    by move: yp; rewrite abs ltxx.
+  have abs := right_ext _ _ _ vq1 piq q1q q2q pi2 qone1 qone2.
+  by move: yq; rewrite abs ltxx.
+- have [q1p1 q2p2] : q1.x < p1.x /\ q2.x < p2.x.
+    by rewrite -p1p -q1q -p2p -q2q .
+  set e3 := Bedge q1p1; set e4 := Bedge q2p2.
+  have l3u : left_pt e3 <<< e4.
+    by move/(@psue_left_edge e4):q2q1=> -> /=; rewrite subr_gt0.
+  have r3a : right_pt e3 >>> e4.
+    by move/(@pue_right_edge e4):p2p1=> -> /=; rewrite subr_le0 -ltNge.
+  have [pi [pi4 /andP[pi3 piint]]] := intersection_middle_ua l3u r3a.
+  have pi1 : pi === e1.
+    apply/andP; split; last first.
+      by apply: (expand_valid piint); rewrite /valid_edge
+           /generic_trajectories.valid_edge -?p1p -?q1q.
+    rewrite -sgr_eq0 (area3_change_ext _ (edge_cond e1) q1p1) //.
+    by rewrite (eqP pi3) /sg !eqxx.
+  have pi2 : pi === e2.
+    apply/andP; split; last first.
+      by apply:(expand_valid piint);
+        rewrite /valid_edge/generic_trajectories.valid_edge -?p1p -?q1q.
+    rewrite -sgr_eq0 (area3_change_ext _ (edge_cond e2) q2p2) //.
+    by rewrite pi4 /sg !eqxx.
+  move: piint; rewrite /valid_edge/generic_trajectories.valid_edge.
+  rewrite /e3/= -p1p -q1q=> /andP[] qpi pip.
+  case: noc=> [E | /(_ pi pi1 pi2) piext]; first by move: pae2; rewrite -E pue1.
+  move: (piext) qpi pip pi1 pi2 { pi3 pi4 }; rewrite !inE.
+  move => /orP[]/eqP/[dup]pival -> qpi pip pi1 pi2.
+    have abs := left_ext _ _ _ vq1 qpi q1q q2q pi2 qone1 qone2.
+    by move: yq; rewrite abs ltxx.
+  have abs := right_ext _ _ _ vp1 pip p1p p2p pi2 pone1 pone2.
+  by move: yp; rewrite abs ltxx.
+have := conj (on_edge_same_point pone1 qone1) (on_edge_same_point pone2 qone2).
+rewrite -p1p -p2p pq q1q (eqP q1q2) => -[]/(_ erefl) p1q1 /(_ erefl) p2q2.
+by move: yp; rewrite p1q1 p2q2; rewrite ltNge le_eqVlt yq orbT.
+Qed.
+
+Definition pvert_y (p : pt) (e : edge) :=
+  match vertical_intersection_point p e with
+    Some p' => p'.y
+  | None => 0
+  end.
+
+Lemma pvertE p e : valid_edge e p ->
+  vertical_intersection_point p e = Some (Bpt (p.x) (pvert_y p e)).
+Proof.
+move=> vep; rewrite /pvert_y.
+have [p' p'P] := exists_point_valid vep; rewrite p'P.
+have [one pxq] := intersection_on_edge p'P.
+by rewrite pxq; case: (p') one.
+Qed.
+
+Lemma pvert_on p e : valid_edge e p ->
+  Bpt (p.x) (pvert_y p e) === e.
+Proof.
+move=> vep; rewrite /pvert_y.
+have [p' p'P] := exists_point_valid vep; rewrite p'P.
+have [one pxq] := intersection_on_edge p'P.
+by rewrite pxq; case: (p') one.
+Qed.
+
+Definition on_pvert p e : p === e -> pvert_y p e = p.y.
+Proof.
+move=> /[dup]/andP[] _ vpe pone.
+by rewrite (on_edge_same_point pone (pvert_on vpe)).
+Qed.
+
+Definition cmp_slopes e1 e2 :=
+  sg(((right_pt e2).y - (left_pt e2).y) * 
+     ((right_pt e1).x -(left_pt e1).x) - 
+     ((right_pt e1).y - (left_pt e1).y) * 
+     ((right_pt e2).x - (left_pt e2).x)).
+
+Definition pedge_below p e1 e2 := 
+  (pvert_y p e1 < pvert_y p e2) || 
+  ((pvert_y p e1 == pvert_y p e2) && (0 <= cmp_slopes e1 e2)).
+
+Definition pedge_below' p e1 e2 := 
+  (pvert_y p e1 < pvert_y p e2) || 
+  ((pvert_y p e1 == pvert_y p e2) && (cmp_slopes e1 e2 <= 0)).
+
+Lemma same_left_edge_below_slopes e1 e2 :
+  left_pt e1 = left_pt e2 ->
+  e1 <| e2 = (0 <= cmp_slopes e1 e2).
+Proof.
+move=> sameleft.
+rewrite /edge_below !underE [in X in X || _]sameleft.
+rewrite (proj1 (area3_two_points _ _)) lexx /=.
+rewrite !strictE -[in X in _ || X]sameleft -!leNgt.
+rewrite (proj1 (area3_two_points _ _)) lexx /=.
+rewrite !area3E !(proj1 (pue_f_eq_slopes _ _ _ _ _ _)).
+rewrite  /cmp_slopes sameleft -opprB oppr_le0.
+rewrite [X in (_ <= X - _) || _]mulrC.
+rewrite [X in _ || (_ <= _ - X)]mulrC.
+rewrite orbb.
+by rewrite sgr_ge0.
+Qed.
+
+Lemma same_right_edge_below_slopes e1 e2 :
+  right_pt e1 = right_pt e2 ->
+  e1 <| e2 = (cmp_slopes e1 e2 <= 0).
+Proof.
+move=> sameright.
+rewrite /edge_below !underE [in X in X || _]sameright.
+rewrite (proj1 (proj2 (area3_two_points _ _))) lexx /=.
+rewrite !strictE -[in X in _ || X]sameright -!leNgt.
+rewrite (proj1 (proj2 (area3_two_points _ _))) lexx /= !andbT.
+rewrite !area3E !(proj2 (pue_f_eq_slopes _ _ _ _ _ _)).
+rewrite /cmp_slopes sameright oppr_le0 opprB.
+rewrite !(mulrC ((right_pt e2).y - _)) orbb.
+by rewrite sgr_le0 -oppr_ge0 [X in _ = (0 <= X)]opprB.
+Qed.
+
+Definition slope e :=
+  ((right_pt e).y - (left_pt e).y) / ((right_pt e).x - (left_pt e).x).
+
+Lemma cmp_slopesE e1 e2 :
+  cmp_slopes e1 e2 = sg(slope e2 - slope e1).
+Proof.
+have := edge_cond e1.
+  rewrite -subr_gt0 =>/gtr0_sg den1.
+have := edge_cond e2.
+  rewrite -subr_gt0 =>/gtr0_sg den2.
+rewrite -[RHS]mul1r -den1 -[RHS]mul1r -den2 -!sgrM.
+rewrite [X in sg( _ * X)]mulrBr /slope.
+rewrite [X in sg(X)]mulrBr 2![in X in sg(X - _)]mulrA.
+rewrite [X in sg( X * _ * _ - _)]mulrC.
+rewrite 2![in X in sg(_ - X)]mulrA.
+rewrite /cmp_slopes.
+set V := ((right_pt e1).x - _).
+set W := ((right_pt e2).x - _).
+set U := (_.y - _).
+set Z := (_.y - _).
+have den20 : W != 0 by rewrite -sgr_eq0 den2 oner_neq0.
+have den10 : V != 0 by rewrite -sgr_eq0 den1 oner_neq0.
+by rewrite (mulrAC V) mulfK // (mulrAC W) mulfK // (mulrC U) (mulrC Z).
+Qed.
+
+Lemma on_edge_same_slope_right e1 e1' :
+  left_pt e1' === e1 -> right_pt e1 = right_pt e1' ->
+  slope e1' = slope e1.
+Proof.
+move=> /andP[]+ val eqr.
+rewrite area3_opposite area3_cycle oppr_eq0.
+rewrite area3E (proj1 (pue_f_eq_slopes _ _ _ _ _ _)).
+have := edge_cond e1.
+  rewrite -subr_gt0 => den1.
+have := edge_cond e1'.
+  rewrite -subr_gt0 => den1'.
+rewrite subr_eq0.
+set W := (_.x - _).
+set V := (_.x - _).
+have den10 : W != 0.
+  by rewrite subr_eq0 eq_sym -subr_eq0 lt0r_neq0 // den1.
+have den10v : W ^-1 != 0 by rewrite invr_eq0.
+have den20 : V != 0.
+  by rewrite subr_eq0 eq_sym -subr_eq0 lt0r_neq0 // eqr den1'.
+have den20v : V ^-1 != 0 by rewrite invr_eq0.
+rewrite -(inj_eq (mulIf den10v)) mulfK //.
+rewrite -(inj_eq (mulfI den20v)) 2!mulrA 2!(mulrC V ^-1) divff // mul1r.
+rewrite -[X in X / V]opprB mulNr -mulrN -invrN /V opprB.
+rewrite -[X in X / W]opprB mulNr -mulrN -invrN /V opprB.
+by rewrite /slope eqr=> /eqP.
+Qed.
+
+Lemma on_edge_same_slope_left e1 e1' :
+  right_pt e1' === e1 -> left_pt e1 = left_pt e1' ->
+  slope e1' = slope e1.
+Proof.
+move=> /andP[]+ val eqr.
+rewrite area3E (proj1 (pue_f_eq_slopes _ _ _ _ _ _)).
+have := edge_cond e1.
+  rewrite -subr_gt0 => den1.
+have := edge_cond e1'.
+  rewrite -subr_gt0 => den1'.
+rewrite subr_eq0.
+set W := (_.x - _).
+set V := (_.x - _).
+have den10 : W != 0.
+  by rewrite subr_eq0 -subr_eq0 lt0r_neq0 // den1.
+have den10v : W ^-1 != 0 by rewrite invr_eq0.
+have den20 : V != 0.
+  by rewrite subr_eq0 -subr_eq0 lt0r_neq0 // eqr den1'.
+have den20v : V ^-1 != 0 by rewrite invr_eq0.
+rewrite -(inj_eq (mulIf den10v)) mulfK //.
+rewrite -(inj_eq (mulfI den20v)) 2!mulrA 2!(mulrC V ^-1) divff // mul1r.
+by rewrite /slope /W /V eqr=> /eqP.
+Qed.
+
+Lemma cmp_slopesNC e1 e2 : -cmp_slopes e1 e2 = cmp_slopes e2 e1.
+Proof. by rewrite /cmp_slopes -sgrN [in LHS]opprB. Qed.
+
+Lemma contact_left_slope e1 e2 :
+  left_pt e1 === e2 -> 
+  (right_pt e1 <<= e2) = (0 <= cmp_slopes e1 e2) /\
+  (right_pt e1 <<< e2) = (0 < cmp_slopes e1 e2).
+Proof.
+move=> /[dup] on2 /andP[] form val.
+suff area3_eq :
+  sg (area3 (right_pt e1) (left_pt e2) (right_pt e2)) =
+  -(cmp_slopes e1 e2).
+  rewrite !underE !strictE.
+  rewrite -sgr_le0 area3_eq oppr_le0 sgr_ge0; split;[by [] |].
+  by rewrite -sgr_lt0 area3_eq oppr_lt0 sgr_gt0.
+move: (val) => /andP[] _; rewrite le_eqVlt=> /orP[/eqP atr | le1ltre2].
+  rewrite /cmp_slopes atr.
+  have eqps : left_pt e1 = right_pt e2.
+    have := on_edge_same_point (right_on_edge _) on2.
+    rewrite atr => /(_ erefl); move: (right_pt e2) (left_pt e1) atr.
+    by move=> [] ? ? [] ? ? /= -> ->.
+  rewrite area3_opposite area3_cycle.
+  rewrite sgrN.
+  rewrite !area3E !(proj1 (pue_f_eq_slopes _ _ _ _ _ _)).
+  rewrite -eqps -(mulrC (_.y - _)).
+  rewrite -[X in _ = - sg (X * _ - _)]opprB -[X in _ = - sg (_ -  _ * X)]opprB.
+  by rewrite mulrN mulNr -opprD opprB.
+set e2' := Bedge le1ltre2.
+have signcond := area3_change_ext (right_pt e1) (edge_cond e2) le1ltre2
+             (eqP form) (proj1 (proj2 (area3_two_points _ _))).
+rewrite {}signcond.
+have on2' : left_pt e2' === e2 by exact: on2.
+rewrite cmp_slopesE  -(on_edge_same_slope_right on2')// -cmp_slopesE.
+rewrite cmp_slopesNC.
+rewrite area3E (proj1 (pue_f_eq_slopes _ _ _ _ _ _)) /cmp_slopes.
+by rewrite /e2' /= [in LHS](mulrC (_.x - _)).
+Qed.
+
+Lemma contact_right_slope e1 e2 :
+  right_pt e1 === e2 -> 
+  (left_pt e1 <<= e2) = (cmp_slopes e1 e2 <= 0) /\
+  (left_pt e1 <<< e2) = (cmp_slopes e1 e2 < 0).
+Proof.
+move=> /[dup] on2 /andP[] form val.
+suff area3_eq :
+  sg (area3 (left_pt e1) (left_pt e2) (right_pt e2)) =
+  cmp_slopes e1 e2.
+  rewrite !underE !strictE.
+  rewrite -area3_eq -[X in X = _ /\ _]sgr_le0; split; first by [].
+  by rewrite -[LHS]sgr_lt0.
+move: (val) => /andP[] + _; rewrite le_eqVlt eq_sym=> /orP[/eqP atl | le2ltre1].
+  rewrite /cmp_slopes atl.
+  have eqps : right_pt e1 = left_pt e2.
+    have := on_edge_same_point (left_on_edge _) on2.
+    rewrite atl => /(_ erefl); move: (right_pt e1) (left_pt e2) atl.
+    by move=> [] ? ? [] ? ? /= -> ->.
+  rewrite !area3E !(proj1 (pue_f_eq_slopes _ _ _ _ _ _)).
+  rewrite eqps (mulrC (_.x - _)).
+  rewrite -[X in _ = sg (_ * X - _)]opprB -[X in _ = sg (_ -  X * _)]opprB.
+  by rewrite mulrN mulNr -opprD opprB.
+set e2' := Bedge le2ltre1.
+have signcond := area3_change_ext (left_pt e1) (edge_cond e2) le2ltre1
+             (proj1 (area3_two_points _ _)) (eqP form).
+rewrite {}signcond.
+have on2' : right_pt e2' === e2 by exact: on2.
+rewrite cmp_slopesE  -(on_edge_same_slope_left on2')// -cmp_slopesE.
+rewrite area3_opposite area3_cycle.
+rewrite area3E (proj1 (pue_f_eq_slopes _ _ _ _ _ _)) /cmp_slopes.
+rewrite /e2' /= [in LHS](mulrC (_.x - _)) opprB.
+by rewrite -4![in LHS](opprB (_ (right_pt e1))) 2!mulrNN.
+Qed.
+
+Lemma sub_edge_right (p : pt) (e : edge) : p === e ->
+  p.x < (right_pt e).x ->
+  {e' | [/\ left_pt e' = p, right_pt e' = right_pt e &
+        forall e2, cmp_slopes e' e2 = cmp_slopes e e2]}.
+Proof.
+move=>/[dup] one /andP[] aligned val dif; exists (Bedge dif).
+split => // e2; rewrite !cmp_slopesE.
+by rewrite (@on_edge_same_slope_right e (Bedge dif) one erefl).
+Qed.
+
+Lemma sub_edge_left (p : pt) (e : edge) : p === e ->
+  (left_pt e).x < p.x ->
+  {e' | [/\ left_pt e' = left_pt e, right_pt e' = p &
+        forall e2, cmp_slopes e' e2 = cmp_slopes e e2]}.
+Proof.
+move=>/[dup] one /andP[] aligned val dif; exists (Bedge dif).
+split => // e2; rewrite !cmp_slopesE.
+by rewrite (@on_edge_same_slope_left e (Bedge dif) one erefl).
+Qed.
+
+Lemma intersection_imp_crossing e1 e2 p :
+  p === e1 -> p === e2 ->
+  (left_pt e1).x < p.x -> p.x < (right_pt e1).x ->
+  (left_pt e2).x < p.x -> p.x < (right_pt e2).x ->
+  ~below_alt e1 e2 \/ cmp_slopes e1 e2 == 0.
+Proof.
+move=> on1 on2 l1ltp pltr1 l2ltp pltr2.
+have [e2' [le2' re2' sle2']] := sub_edge_left on2 l2ltp.
+have [e2'' [le2'' re2'' sle2'']] := sub_edge_right on2 pltr2.
+have [e1' [le1' re1' sle1']] := sub_edge_left on1 l1ltp.
+have [e1'' [le1'' re1'' sle1'']] := sub_edge_right on1 pltr1.
+have /contact_left_slope/= : left_pt e2'' === e1 by rewrite le2''.
+have /contact_right_slope/= : right_pt e2' === e1 by rewrite re2'.
+have /contact_left_slope/= : left_pt e1'' === e2 by rewrite le1''.
+have /contact_right_slope/= : right_pt e1' === e2 by rewrite re1'.
+rewrite le1' le2' re2'' re1'' sle1' sle1'' sle2' sle2'' -(cmp_slopesNC e1).
+rewrite !oppr_lte0 !oppr_gte0 => -[]D' D []C' C []B' B []A' A.
+rewrite /below_alt/edge_below.
+have [ | difslope] := boolP(cmp_slopes e1 e2 == 0); first by right.
+left; rewrite D' C' A B A' B' D C -!leNgt orbC=> /orP; rewrite andbC !orbb.
+by move/le_anti/esym/eqP; rewrite (negbTE difslope).
+Qed.
+
+Lemma order_below_viz_vertical low_e high_e p pl ph:
+valid_edge low_e p -> valid_edge high_e p ->
+vertical_intersection_point p low_e = Some pl ->
+vertical_intersection_point p high_e = Some ph ->
+low_e <| high_e ->
+pl.y <= ph.y.
+Proof.
+move => lowv highv vert_pl vert_ph luh.
+have := intersection_on_edge vert_pl => [][] poel lx_eq.
+have := intersection_on_edge vert_ph => [][] poeh hx_eq.
+have plhv: valid_edge high_e pl.
+  move : highv.
+  by rewrite /valid_edge/generic_trajectories.valid_edge -lx_eq.
+have pllv: valid_edge low_e pl.
+  move : lowv.
+  by rewrite /valid_edge/generic_trajectories.valid_edge -lx_eq.
+have := order_edges_viz_point' pllv  plhv luh.
+rewrite under_onVstrict // poel /= => [] /= plinfh.
+have pluh: pl <<= high_e .
+  by apply plinfh.
+have px_eq : pl.x = ph.x.
+  by rewrite -lx_eq -hx_eq /=.
+by rewrite -(under_edge_lower_y px_eq poeh).
+Qed.
+
+Lemma edge_below_equiv p (s : pred edge) :
+  {in s, forall e, valid_edge e p && (p.x < (right_pt e).x)} ->
+  {in s &, no_crossing} ->
+  {in s & , forall e1 e2: edge, (e1 <| e2) = pedge_below p e1 e2}.
+Proof.
+move=> val noc e1 e2.
+move=> /[dup] e1in /val /andP[] /[dup] ve1 /exists_point_valid [p1 p1P] re1.
+move: (p1P); rewrite (pvertE ve1) =>/esym[] p1q.
+move: (ve1)=> /pvert_on; rewrite -p1q=> on1.
+move=> /[dup] e2in /val /andP[] /[dup] ve2 /exists_point_valid [p2 p2P] re2.
+move: (p2P); rewrite (pvertE ve2) =>/esym[] p2q.
+move: (ve2)=> /pvert_on; rewrite -p2q=> on2; rewrite /pedge_below.
+have p1p2 : p1.x = p2.x by rewrite p1q p2q.
+have [vylt /= | vylt' /= | vyq] := ltrgtP.
+- case: (noc e1 e2 e1in e2in) => // abs.
+  have := order_below_viz_vertical ve2 ve1 p2P p1P abs; rewrite leNgt.
+  by rewrite p1q p2q /= vylt.
+- have re1' : p1.x < (right_pt e1).x by rewrite p1q.
+  have p2u : p2 <<< e1.
+    by rewrite (strict_under_edge_lower_y (esym p1p2)); rewrite // p2q p1q.
+  have p1a : p1 >>> e2.
+    by rewrite (under_edge_lower_y p1p2); rewrite // -ltNge p2q p1q.
+  apply/negP=> /orP[|] /andP[]leftc rightc.
+    by move: p1a; rewrite (point_on_edge_under _ leftc rightc) // p1q.
+  move: p2u; rewrite -(negbK (_ <<< _)).
+  by rewrite (point_on_edge_above _ leftc rightc) // p2q.
+have pp : p1 = p2 by rewrite p1q p2q vyq.
+move: (ve1) => /andP[] + _; rewrite le_eqVlt=>/orP[/eqP pleft | pmid] /=.
+  have p1l : p1 = left_pt e1.
+    apply/esym/eqP; rewrite pt_eqE.
+    by rewrite (on_edge_same_point (left_on_edge _) on1) pleft p1q// eqxx andbT.
+  move: ve2 => /andP[] + _; rewrite le_eqVlt=> /orP [/eqP pleft2 | pmid2].
+    have p2l : p2 = left_pt e2.
+      apply/esym/eqP; rewrite pt_eqE.
+      by rewrite (on_edge_same_point (left_on_edge _) on2) pleft2 p2q// eqxx andbT.
+    by apply: same_left_edge_below_slopes; rewrite -p1l pp.
+  have le2ltp2 : (left_pt e2).x < p2.x by rewrite p2q.
+  have [e2' [le2' re2' sle2']] := sub_edge_left on2 le2ltp2.
+  have re2'e1 : right_pt e2' === e1 by rewrite re2' -pp.
+  rewrite /edge_below.
+  have := (contact_right_slope re2'e1) => /= -[] _; rewrite le2' sle2' => ->.
+  have p2ltre2 : p2.x < (right_pt e2).x by rewrite p2q.
+  have [e2'' [le2'' re2'' sle2'']] := sub_edge_right on2 p2ltre2.
+  have le2''e1 : left_pt e2'' === e1 by rewrite le2'' -pp.
+  have := (contact_left_slope le2''e1) => -[] _; rewrite re2'' sle2'' => ->.
+  rewrite -2!leNgt.
+  set W := (X in _ || X); have [ | difslope] := boolP W.
+    rewrite {}/W=>/le_anti/esym=>/eqP.
+    by rewrite -cmp_slopesNC oppr_eq0 orbT=> /eqP->; rewrite lexx.
+  rewrite orbF -p1l pp {1}underE.
+  move: (on2); rewrite /point_on_edge.
+  move=> /andP[] /eqP -> _; rewrite lexx /=.
+  by move: (on2); rewrite -pp p1l=>/contact_left_slope=>-[].
+have le1ltp1 : (left_pt e1).x < p1.x by rewrite p1q.
+have [e1' [le1' re1' sle1']] := sub_edge_left on1 le1ltp1.
+have re1'e2 : right_pt e1' === e2 by rewrite re1' pp.
+rewrite /edge_below.
+set W := (X in X || _); set W' := (X in _ || X).
+have := (contact_right_slope re1'e2); rewrite le1' sle1' => /= -[] eq1 _.
+have p1ltre1 : p1.x < (right_pt e1).x by rewrite p1q.
+have [e1'' [le1'' re1'' sle1'']] := sub_edge_right on1 p1ltre1.
+have le1''e2 : left_pt e1'' === e2 by rewrite le1'' pp.
+have /= := (contact_left_slope le1''e2); rewrite re1'' sle1'' => - [] /= eq2 _.
+have Weq : W = (cmp_slopes e1 e2 == 0).
+  rewrite /W eq1 eq2; apply/idP/eqP; first by apply/le_anti.
+  by move=> ->; rewrite lexx.
+have [ | difslope /=] := boolP W.
+  by rewrite /= le_eqVlt Weq => /eqP ->; rewrite eqxx.
+rewrite le_eqVlt eq_sym -Weq (negbTE difslope) /=.
+move: (ve2) => /andP[] + _; rewrite le_eqVlt => /orP [/eqP l2p | l2ltp].
+  have /eqP p2l : left_pt e2 == p1.
+    rewrite pt_eqE.
+    rewrite (on_edge_same_point (left_on_edge _) on2 _) -pp l2p p1q //=.
+    by rewrite !eqxx.
+  have/contact_left_slope[_ eq3] : left_pt e2 === e1 by rewrite p2l.
+  move: on1=>/andP[] /eqP + _; rewrite -p2l => eq4.
+  rewrite /W' eq3 lt_neqAle -cmp_slopesNC eq_sym oppr_eq0 -Weq difslope andTb.
+  rewrite strictE.
+  by rewrite -leNgt eq4 lexx -ltNge oppr_lt0.
+have xpp1 : p.x = p1.x by rewrite p1q.
+move: on2 l2ltp re2; rewrite -pp xpp1 => on2 l2ltp re2.
+have := intersection_imp_crossing on1 on2 le1ltp1 p1ltre1 l2ltp re2=> -[[]|abs].
+  by apply: noc.
+by case/negP: difslope; rewrite Weq.
+Qed.
+
+Lemma edge_below_equiv' p (s : pred edge) :
+  {in s, forall e, valid_edge e p && ((left_pt e).x < p.x)} ->
+  {in s &, no_crossing} ->
+  {in s & , forall e1 e2: edge, (e1 <| e2) = pedge_below' p e1 e2}.
+Proof.
+move=> val noc e1 e2.
+move=> /[dup] e1in /val /andP[] /[dup] ve1 /exists_point_valid [p1 p1P] le1.
+move: (p1P); rewrite (pvertE ve1) =>/esym[] p1q.
+move: (ve1)=> /pvert_on; rewrite -p1q=> on1.
+move=> /[dup] e2in /val /andP[] /[dup] ve2 /exists_point_valid [p2 p2P] le2.
+move: (p2P); rewrite (pvertE ve2) =>/esym[] p2q.
+move: (ve2)=> /pvert_on; rewrite -p2q=> on2; rewrite /pedge_below'.
+have p1p2 : p1.x = p2.x by rewrite p1q p2q.
+have [vylt /= | vylt' /= | vyq] := ltrgtP.
+- case: (noc e1 e2 e1in e2in) => // abs.
+  have := order_below_viz_vertical ve2 ve1 p2P p1P abs; rewrite leNgt.
+  by rewrite p1q p2q /= vylt.
+- have le1' : (left_pt e1).x < p1.x by rewrite p1q.
+  have p2u : p2 <<< e1.
+    by rewrite (strict_under_edge_lower_y (esym p1p2)); rewrite // p2q p1q.
+  have p1a : p1 >>> e2.
+    by rewrite (under_edge_lower_y p1p2); rewrite // -ltNge p2q p1q.
+  apply/negP=> /orP[|] /andP[]leftc rightc.
+    by move: p1a; rewrite (point_on_edge_under _ leftc rightc) // p1q.
+  move: p2u; rewrite -(negbK (_ <<< _)).
+  by rewrite (point_on_edge_above _ leftc rightc) // p2q.
+have pp : p1 = p2 by rewrite p1q p2q vyq.
+move: (ve1) => /andP[] _ +; rewrite le_eqVlt=>/orP[/eqP pright | pmid] /=.
+  have p1r : p1 = right_pt e1.
+    apply/eqP; rewrite pt_eqE.
+    by rewrite (on_edge_same_point on1 (right_on_edge _)) -pright p1q// eqxx andbT.
+  move: ve2 => /andP[] _; rewrite le_eqVlt=> /orP [/eqP pright2 | pmid2].
+    have p2l : p2 = right_pt e2.
+      apply/eqP; rewrite pt_eqE.
+      by rewrite (on_edge_same_point on2 (right_on_edge _)) -pright2 p2q// eqxx andbT.
+    by apply: same_right_edge_below_slopes; rewrite -p1r pp.
+  have p2ltre2 : p2.x < (right_pt e2).x by rewrite p2q.
+  have [e2' [le2' re2' sle2']] := sub_edge_right on2 p2ltre2.
+  have le2'e1 : left_pt e2' === e1 by rewrite le2' -pp.
+  rewrite /edge_below.
+  have := (contact_left_slope le2'e1) => /= -[] _; rewrite re2' sle2' => ->.
+  have le2ltp2 : (left_pt e2).x < p2.x by rewrite p2q.
+  have [e2'' [le2'' re2'' sle2'']] := sub_edge_left on2 le2ltp2.
+  have re2''e1 : right_pt e2'' === e1 by rewrite re2'' -pp.
+  have := (contact_right_slope re2''e1) => -[] _; rewrite le2'' sle2'' => ->.
+  rewrite -2!leNgt.
+  set W := (X in _ || X); have [ | difslope] := boolP W.
+    rewrite {}/W=>/le_anti/esym/eqP.
+    by rewrite -cmp_slopesNC oppr_eq0 orbT=> /eqP->; rewrite lexx.
+  rewrite orbF -p1r pp [p2 <<= _]underE.
+   move: (on2); rewrite /point_on_edge.
+  move=> /andP[] /eqP -> _; rewrite lexx andbT.
+  by move: (on2); rewrite -pp p1r=>/contact_right_slope=>-[].
+have p1ltre1 : p1.x < (right_pt e1).x by rewrite p1q.
+have [e1' [le1' re1' sle1']] := sub_edge_right on1 p1ltre1.
+have le1'e2 : left_pt e1' === e2 by rewrite le1' pp.
+rewrite /edge_below.
+set W := (X in X || _); set W' := (X in _ || X).
+have := (contact_left_slope le1'e2); rewrite re1' sle1' => /= -[] eq1 _.
+have le1ltp1 : (left_pt e1).x < p1.x by rewrite p1q.
+have [e1'' [le1'' re1'' sle1'']] := sub_edge_left on1 le1ltp1.
+have re1''e2 : right_pt e1'' === e2 by rewrite re1'' pp.
+have /= := (contact_right_slope re1''e2); rewrite le1'' sle1'' => - [] /= eq2 _.
+have Weq : W = (cmp_slopes e1 e2 == 0).
+  rewrite /W eq1 eq2; apply/idP/eqP; first by apply/le_anti.
+  by move=> ->; rewrite lexx.
+have [ | difslope /=] := boolP W.
+  by rewrite /= le_eqVlt Weq => /eqP ->; rewrite eqxx.
+rewrite le_eqVlt -Weq (negbTE difslope) /=.
+move: (ve2) => /andP[] _; rewrite le_eqVlt => /orP [/eqP r2p | pltr2].
+  have /eqP p2r : right_pt e2 == p1.
+    rewrite pt_eqE.
+    rewrite -(on_edge_same_point on2 (right_on_edge _) _) -pp -r2p p1q //=.
+    by rewrite !eqxx.
+  have/contact_right_slope[_ eq3] : right_pt e2 === e1 by rewrite p2r.
+  move: on1=>/andP[] /eqP + _; rewrite -p2r => eq4.
+  rewrite /W' eq3 lt_neqAle -cmp_slopesNC oppr_eq0 -Weq difslope andTb.
+  by rewrite /W' strictE
+      eq4 ltxx andbT -ltNge oppr_gt0.
+have xpp1 : p.x = p1.x by rewrite p1q.
+move: on2 pltr2 le2; rewrite -pp xpp1 => on2 pltr2 le2.
+have := intersection_imp_crossing on1 on2 le1ltp1 p1ltre1 le2 pltr2=> -[[]|abs].
+  by apply: noc.
+by case/negP: difslope; rewrite Weq.
+Qed.
+
+Lemma pedge_below_trans p: transitive (pedge_below p).
+Proof.
+move=> e2 e1 e3; rewrite /pedge_below.
+move=>/orP[v12 | /andP [y12 s12]] /orP[v23 | /andP[y23 s23]].
+- by rewrite (lt_trans v12 v23).
+- by rewrite -(eqP y23) v12.
+- by rewrite (eqP y12) v23.
+rewrite orbC (eqP y12) y23.
+move: s12 s23; rewrite !cmp_slopesE !sgr_ge0 !subr_ge0=> s12 s23.
+by rewrite (le_trans s12 s23).
+Qed.
+
+Lemma pedge_below_trans' p: transitive (pedge_below' p).
+Proof.
+move=> e2 e1 e3; rewrite /pedge_below'.
+move=>/orP[v12 | /andP [y12 s12]] /orP[v23 | /andP[y23 s23]].
+- by rewrite (lt_trans v12 v23).
+- by rewrite -(eqP y23) v12.
+- by rewrite (eqP y12) v23.
+rewrite orbC (eqP y12) y23.
+move: s12 s23; rewrite !cmp_slopesE !sgr_le0.
+rewrite (subr_le0 (slope e1)) (subr_le0 (slope e2)) (subr_le0 (slope e1)).
+by move=> s12 s23; rewrite (le_trans s23 s12).
+Qed.
+
+Lemma edge_below_trans p (s : pred edge) :
+  {in s, forall e, p.x < (right_pt e).x} \/ 
+  {in s, forall e, (left_pt e).x < p.x} ->
+  {in s, forall e, valid_edge e p} -> {in s &, no_crossing} ->
+  {in s & & , transitive edge_below}.
+Proof.
+move=> [rbound | lbound] vals noc e2 e1 e3 e2in e1in e3in.
+  have valb : {in s, forall e, valid_edge e p && (p.x < (right_pt e).x)}.
+    by move=> e ein; apply/andP; split;[apply: vals | apply: rbound].
+  rewrite (edge_below_equiv valb noc) // (edge_below_equiv valb noc) //.
+  rewrite (edge_below_equiv valb noc) //.
+  by apply: pedge_below_trans.
+have valb : {in s, forall e, valid_edge e p && ((left_pt e).x < p.x)}.
+  by move=> e ein; apply/andP; split;[apply: vals | apply: lbound].
+rewrite (edge_below_equiv' valb noc) // (edge_below_equiv' valb noc) //.
+rewrite (edge_below_equiv' valb noc) //.
+by apply: pedge_below_trans'.
+Qed.
+
+Lemma left_pt_above g : left_pt g >>= g.
+Proof. by rewrite strictE (proj1 (area3_two_points _ _)) ltxx. Qed.
+
+Lemma right_pt_above g : right_pt g >>= g.
+Proof. by rewrite strictE (proj1 (proj2 (area3_two_points _ _))) ltxx. Qed.
+
+Lemma left_pt_below g : left_pt g <<= g.
+Proof. by rewrite underE (proj1 (area3_two_points _ _)) lexx. Qed.
+
+Lemma right_pt_below g : right_pt g <<= g.
+Proof. by rewrite underE (proj1 (proj2 (area3_two_points _ _))) lexx. Qed.
+
+Lemma under_pvert_y (p : pt) (e : edge) :
+  valid_edge e p -> (p <<= e) = (p.y <= pvert_y p e).
+Proof.
+move=> val.
+have xs : p.x = (Bpt (p.x) (pvert_y p e)).x by [].
+have one : Bpt (p.x) (pvert_y p e) === e by apply: pvert_on.
+by rewrite (under_edge_lower_y xs one).
+Qed.
+
+Lemma strict_under_pvert_y (p : pt) (e : edge) :
+  valid_edge e p -> (p <<< e) = (p.y < pvert_y p e).
+Proof.
+move=> val.
+have xs : p.x = (Bpt (p.x) (pvert_y p e)).x by [].
+have one : Bpt (p.x) (pvert_y p e) === e by apply: pvert_on.
+by rewrite (strict_under_edge_lower_y xs one).
+Qed.
+
+Lemma same_x_valid (p1 p2 : pt) (g : edge) :
+  p1.x = p2.x -> valid_edge g p1 = valid_edge g p2.
+Proof.
+by move=> xs; rewrite /valid_edge /generic_trajectories.valid_edge xs.
+Qed.
+
+Lemma same_pvert_y (p1 p2 : pt) (g : edge) :
+  valid_edge g p1 -> p1.x = p2.x -> pvert_y p1 g = pvert_y p2 g.
+Proof.
+move=> vg xs.
+move: (vg) ; rewrite (same_x_valid _ xs) => vg2.
+exact: (on_edge_same_point (pvert_on vg) (pvert_on vg2) xs).
+Qed.
+
+Lemma edge_below_pvert_y g1 g2 p :
+  valid_edge g1 p -> valid_edge g2 p ->
+  g1 <| g2 -> pvert_y p g1 <= pvert_y p g2.
+Proof.
+move=> v1 v2 g1g2.
+have := pvert_on v1; set p' := Bpt _ _ => p'on.
+have/esym := @same_x_valid p p' g1 erefl; rewrite v1 => v'1.
+have/esym := @same_x_valid p p' g2 erefl; rewrite v2 => v'2.
+have := order_edges_viz_point' v'1 v'2 g1g2.
+rewrite (under_onVstrict v'1) p'on => /(_ isT).
+by rewrite under_pvert_y.
+Qed.
+
+Lemma pvert_y_edge_below g1 g2 p :
+  valid_edge g1 p -> valid_edge g2 p ->
+  pvert_y p g1 < pvert_y p g2 -> ~~ (g2 <| g1).
+Proof.
+move=> v1 v2 cmp; apply/negP=> g2g1.
+have := edge_below_pvert_y v2 v1 g2g1.
+by rewrite leNgt cmp.
+Qed.
+
+Lemma edges_partition_strictly_above p g1 g2 s1 s2:
+  all (valid_edge^~ p) (s1 ++ g1 :: g2 :: s2) ->
+  sorted edge_below (s1 ++ g1 :: g2 :: s2) ->
+  p >>= g1 -> p <<< g2 ->
+  {in rcons s1 g1 &  g2 :: s2, forall g g', ~~ (g' <| g)}.
+Proof.
+move=> aval pth pg1 pg2.
+have vg1 : valid_edge g1 p.
+  by apply: (allP aval); rewrite !(mem_cat, inE) eqxx ?orbT.
+have vg2 : valid_edge g2 p.
+  by apply: (allP aval); rewrite !(mem_cat, inE) eqxx ?orbT.
+have pg1y : pvert_y p g1 <= p.y by rewrite leNgt -strict_under_pvert_y.
+have pg2y : p.y < pvert_y p g2 by rewrite -strict_under_pvert_y.
+have g1g2 : pvert_y p g1 < pvert_y p g2 by apply: (le_lt_trans pg1y).
+have mp : {in s1++ g1 :: g2 :: s2 &,
+           {homo (pvert_y p) : x y / x <| y >-> x <= y}}.
+    move=> u v /(allP aval) vu /(allP aval) vv uv.
+    by apply: edge_below_pvert_y vu vv uv.
+have sb2 : {subset [:: g1, g2 & s2] <= (s1 ++ [:: g1, g2 & s2])}.
+  by move=> u uin; rewrite mem_cat uin orbT.
+have g2s2y : {in g2 :: s2, forall g, pvert_y p g1 < pvert_y p g}.
+  move=> g; rewrite inE => /orP[/eqP -> //| gin].
+  have pthy : sorted <=%R [seq pvert_y p h | h <- g2 :: s2].
+    apply: (homo_path_in mp); last first.
+      move: pth.
+      rewrite (_ : s1 ++ _ = (s1 ++[:: g1]) ++ g2 :: s2); last first.
+        by rewrite /= -!catA.
+      by move/sorted_catW=> /andP[].
+    apply: (sub_all sb2).
+    by apply/allP => z; rewrite !(mem_cat, inE) => /orP[] ->; rewrite ?orbT.
+  have /(allP aval) gin' : g \in (s1 ++ [:: g1, g2 & s2]).
+    by rewrite mem_cat !inE gin ?orbT.
+  move: pthy; rewrite /= (path_sortedE le_trans) => /andP[] /allP.
+  have giny : pvert_y p g \in [seq pvert_y p h | h <- s2] by apply: map_f.
+  by move=> /(_ _ giny) => /(lt_le_trans g1g2).
+have sb1 : {subset rcons s1 g1 <= s1 ++ [:: g1, g2 & s2]}.
+  by move=> x; rewrite mem_rcons mem_cat !inE => /orP[] ->; rewrite ?orbT.
+have s1g1y : {in rcons s1 g1, forall g, pvert_y p g <= pvert_y p g1}.
+  move=> g; rewrite mem_rcons inE => /orP[/eqP ->| gin].
+    apply: le_refl.
+  case s1eq : s1 gin => [// | init s1']; rewrite -s1eq => gin.
+  have pthy : sorted <=%R [seq pvert_y p h | h <- rcons s1 g1].
+    rewrite s1eq /=; apply: (homo_path_in mp); last first.
+      move: pth; rewrite s1eq/=.
+      rewrite (_ : s1' ++ _ = (s1' ++ [:: g1]) ++ g2 :: s2); last first.
+        by rewrite -catA.
+      by rewrite cat_path cats1 => /andP[].
+    by apply: (sub_all sb1); rewrite s1eq; apply: allss.
+  have [s' [s'' s'eq]] : exists s' s'', s1 = s' ++ g :: s''.
+    by move: gin=> /splitPr [s' s'']; exists s', s''.
+  have dc : rcons (init :: s1') g1 = (s' ++ [:: g]) ++ rcons s'' g1.
+   by rewrite -s1eq s'eq -!cats1 /= -?catA.
+  case s'eq2 : s' => [ | init' s'2].
+    move: pthy; rewrite s1eq dc s'eq2 /= (path_sortedE le_trans)=> /andP[].
+    move=> /allP/(_ (pvert_y p g1)) + _; apply.
+    by rewrite map_f // mem_rcons inE eqxx.
+  move: pthy; rewrite s1eq dc s'eq2 /= map_cat cat_path => /andP[] _.
+  rewrite !map_cat cats1 last_rcons (path_sortedE le_trans) => /andP[] + _.
+  move=> /allP/(_ (pvert_y p g1)); apply.
+  by apply: map_f; rewrite mem_rcons inE eqxx.
+move=> g g' /[dup]gin /s1g1y giny /[dup] g'in /g2s2y g'iny; apply/negP=> g'g.
+have vg : valid_edge g p by apply: (allP aval); apply: sb1.
+have vg' : valid_edge g' p.
+  by apply: (allP aval); apply: sb2; rewrite inE g'in orbT.
+have:= edge_below_pvert_y vg' vg g'g; rewrite leNgt.
+by rewrite (le_lt_trans _ g'iny).
+Qed.
+
+Lemma edge_below_from_point_above g1 g2 p:
+  below_alt g1 g2 -> valid_edge g1 p -> valid_edge g2 p ->
+  p >>= g1 -> p <<< g2 -> g1 <| g2.
+Proof.
+move=>[] //= g2g1 v1 v2 ab bel.
+have := order_edges_strict_viz_point' v2 v1 g2g1 bel.
+by rewrite (negbTE ab).
+Qed.
+
+Lemma edge_below_from_point_under g1 g2 p:
+  below_alt g1 g2 -> valid_edge g1 p -> valid_edge g2 p ->
+  p <<= g1 -> p >>> g2 -> g2 <| g1.
+Proof.
+move=>/below_altC[] //=g1g2 v1 v2 bel ab.
+have := order_edges_viz_point' v1 v2 g1g2 bel.
+by rewrite (negbTE ab).
+Qed.
+
+Lemma transport_below_edge r p e e':
+  below_alt e e' ->
+  valid_edge e r -> valid_edge e' r ->
+  valid_edge e p -> valid_edge e' p ->
+  pvert_y r e < pvert_y r e' ->
+  p <<< e -> p <<< e'.
+Proof.
+move=> noc vr vr' vp vp' cmp pbelow.
+have ebe'0 := pvert_y_edge_below vr vr' cmp.
+have ebe' : e <| e' by case: noc ebe'0=> [// | -> ].
+by apply:(order_edges_strict_viz_point' vp vp').
+Qed.
+
+Lemma transport_above_edge r p e e':
+  below_alt e e' ->
+  valid_edge e r -> valid_edge e' r ->
+  valid_edge e p -> valid_edge e' p ->
+  pvert_y r e < pvert_y r e' ->
+  p >>> e' -> p >>> e.
+Proof.
+move=> noc vr vr' vp vp' cmp pabove.
+have ebe'0 := pvert_y_edge_below vr vr' cmp.
+have ebe' : e <| e' by case: noc ebe'0=> [// | -> ].
+apply/negP=> abs.
+by move: pabove; rewrite (order_edges_viz_point' vp vp').
+Qed.
+
+Lemma path_edge_below_pvert_y bottom s p :
+  all (valid_edge^~ p) (bottom :: s) ->
+  path edge_below bottom s -> path <=%R (pvert_y p bottom)
+  [seq pvert_y p e | e <- s].
+Proof.
+move=> aval.
+have hp : {in bottom :: s &,
+         {homo (pvert_y p) : u v / edge_below u v >-> u <= v}}.
+  move=> u v /(allP aval) vu /(allP aval) vv.
+    by apply: edge_below_pvert_y vu vv.
+by move/(homo_path_in hp)=> /(_ (allss (bottom :: s))).
+Qed.
+
+Lemma edge_below_gap bottom s s' le r p g g' : 
+{in bottom::rcons s le ++ s' &, no_crossing} ->
+all (valid_edge^~ r) (bottom :: rcons s le ++ s') ->
+path edge_below bottom (rcons s le ++ s') ->
+r >>> le -> r <<= g' ->
+g \in rcons s le ->
+valid_edge g p ->
+p >>> g' ->
+g' \in s' ->
+valid_edge g' p -> p >>> g.
+Proof.
+move=> noc aval pth rabove rbelow gin vp pabove g'in vp'.
+have gin2 : g \in bottom :: rcons s le ++ s'.
+  by move: gin; rewrite !(inE, mem_rcons, mem_cat)=>/orP[] ->; rewrite ?orbT.
+have g'in2 : g' \in bottom :: rcons s le ++ s'.
+  by move: g'in; rewrite !(inE, mem_rcons, mem_cat)=> ->; rewrite ?orbT.
+have lein : le \in bottom :: rcons s le ++ s'.
+  by rewrite !(inE, mem_cat, mem_rcons) eqxx ?orbT.
+have vl : valid_edge le r by apply: (allP aval).
+have vr : valid_edge g r by apply: (allP aval).
+have vr' : valid_edge g' r by apply: (allP aval).
+have noc' : below_alt g g' by apply: noc.
+apply: (transport_above_edge noc' vr) => //.
+have aval' : all (valid_edge^~ r) (bottom :: rcons s le).
+  apply/allP=> u uin; apply: (allP aval).
+  move: uin; rewrite !(inE, mem_cat, mem_rcons).
+  by move=> /orP[| /orP[]] ->; rewrite ?orbT.
+have aval'' : all (valid_edge^~ r) (le :: s'). 
+  apply/allP=> u uin; apply: (allP aval).
+  move: uin; rewrite !(inE, mem_cat, mem_rcons).
+  by move=> /orP[] ->; rewrite ?orbT.
+have tr : transitive (relpre (pvert_y r) <=%R).
+  by move=> y x z; rewrite /=; apply: le_trans.
+have le_g' : pvert_y r le < pvert_y r g'.
+  have le_r : pvert_y r le < r.y by rewrite ltNge -under_pvert_y.
+  have r_g' : r.y <= pvert_y r g' by rewrite -under_pvert_y.
+  by apply: lt_le_trans le_r r_g'.
+have g_le : pvert_y r g <= pvert_y r le.
+  move: gin; rewrite mem_rcons inE=> /orP[/eqP -> |gin]; first by rewrite lexx.
+  have gin' : g \in (bottom :: s) by rewrite inE gin orbT.
+  move: pth; rewrite cat_path last_rcons => /andP[] + _.
+  move=> /= /path_edge_below_pvert_y => /(_ _ aval').
+  rewrite path_map.
+  rewrite -[path _ _ _]/(sorted _ (rcons (bottom :: s) le)).
+  by move=> /(sorted_rconsE tr)/allP/(_ _ gin') /=.
+by apply: le_lt_trans le_g'.
+Qed.
+
+Lemma edge_above_gap bottom s s' he r p g g' : 
+{in bottom::rcons s he ++ s' &, no_crossing} ->
+all (valid_edge^~ r) (bottom :: rcons s he ++ s') ->
+path edge_below bottom (rcons s he ++ s') ->
+r <<< he -> r >>= g ->
+g \in rcons s he ->
+valid_edge g p ->
+p <<< g ->
+g' \in s' ->
+valid_edge g' p -> p <<< g'.
+Proof.
+move=> noc aval pth rabove rbelow gin vp pabove g'in vp'.
+have gin2 : g \in bottom :: rcons s he ++ s'.
+  by move: gin; rewrite !(inE, mem_rcons, mem_cat)=>/orP[] ->; rewrite ?orbT.
+have g'in2 : g' \in bottom :: rcons s he ++ s'.
+  by move: g'in; rewrite !(inE, mem_rcons, mem_cat)=> ->; rewrite ?orbT.
+have hein : he \in bottom :: rcons s he ++ s'.
+  by rewrite !(inE, mem_cat, mem_rcons) eqxx ?orbT.
+have vl : valid_edge he r by apply: (allP aval).
+have vr : valid_edge g r by apply: (allP aval).
+have vr' : valid_edge g' r by apply: (allP aval).
+have noc' : below_alt g g' by apply: noc.
+apply: (transport_below_edge noc' vr) => //.
+have aval' : all (valid_edge^~ r) (bottom :: rcons s he).
+  apply/allP=> u uin; apply: (allP aval).
+  move: uin; rewrite !(inE, mem_cat, mem_rcons).
+  by move=> /orP[| /orP[]] ->; rewrite ?orbT.
+have aval'' : all (valid_edge^~ r) (he :: s'). 
+  apply/allP=> u uin; apply: (allP aval).
+  move: uin; rewrite !(inE, mem_cat, mem_rcons).
+  by move=> /orP[] ->; rewrite ?orbT.
+have tr : transitive (relpre (pvert_y r) <=%R).
+  by move=> y x z; rewrite /=; apply: le_trans.
+have g_he : pvert_y r g < pvert_y r he.
+  have r_he : r.y < pvert_y r he by rewrite -strict_under_pvert_y.
+  have g_r : pvert_y r g <= r.y by rewrite leNgt -strict_under_pvert_y.
+  by apply: le_lt_trans g_r r_he.
+have he_g' : pvert_y r he <= pvert_y r g'.
+  move: pth; rewrite cat_path last_rcons => /andP[] _.
+  move=> /= /path_edge_below_pvert_y => /(_ _ aval'').
+  rewrite path_map /=.
+  by rewrite (path_sortedE tr) => /andP[] /allP/(_ _ g'in) /=.
+by apply: lt_le_trans he_g'.
+Qed.
+
+Definition non_inner (g : edge) (p : pt) :=
+  p === g -> p = left_pt g \/ p = right_pt g.
+
+End working_context.
+
+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).
+
+Notation "p '>>=' e" := (~~(point_strictly_under_edge p e))( at level 70, no associativity).
+Notation "p '>>>' e" := (~~(point_under_edge p e))(at level 70, no associativity).
+Notation "p '===' e" := (point_on_edge p e)( at level 70, no associativity).
+Notation "e1 '<|' e2" := (edge_below e1 e2)( at level 70, no associativity).
diff --git a/theories/pol.v b/theories/pol.v
index 77adcfa..38d585e 100644
--- a/theories/pol.v
+++ b/theories/pol.v
@@ -1,15 +1,15 @@
-From mathcomp Require Import all_ssreflect.
-From mathcomp Require Import ssralg poly ssrnum ssrint rat polyrcf.
+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. 
+(** * 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.
@@ -68,12 +68,12 @@ 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_pdivr_mulr ?ltr0n // mulr_natr mulr2n ltr_addr.
+by move=>lta; rewrite ltr_pdivrMr ?ltr0n // mulr_natr mulr2n ltrDr.
 Qed.
 
 Lemma double_half x : half x + half x = x.
 Proof.
-by rewrite -mulrDl-mulr2n - mulr_natr -mulrA divrr ?two_unit ?mulr1.
+by rewrite /half -splitr.
 Qed.
 
 Lemma half_inj (x y : R) : half x = half y -> x = y.
@@ -88,35 +88,35 @@ 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  ltr_add2l  ltr_add2r ltr_pmul2r ?h //invr_gt0 ltr0n.
+by rewrite ltrD2l ltrD2r ltr_pM2r ?h //invr_gt0 ltr0n.
 Qed.
 
 Lemma maxS (x y: R) (z := (Num.max x y) +1) : (x<z) && (y <z).
 Proof.
 have p1 : forall u v:R, u <= v -> u < v + 1.
-       by move=> u v  h; rewrite (le_lt_trans h) // ltr_addl ltr01.
-by rewrite !p1// ?le_maxr// lexx // orbT.
+       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_wpmul2l a0 cd)).
-by apply: (le_trans (ler_wpmul2r d0 ab)).
+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_pmul2r yp) - [y < _](ltr_pmul2l xp).
+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_pmul2r yp) - [_ < y](ltr_pmul2l xp).
+rewrite -(ltr_pM2r yp) - [_ < y](ltr_pM2l xp).
 by rewrite mulVf ?(gt_eqF yp) //  mulfV // (gt_eqF xp).
 Qed.
 
@@ -141,7 +141,7 @@ 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_maxr Hri0 orbT.
+by move=> s IHs  Hri0; rewrite big_cons le_max Hri0 orbT.
 Qed.
 
 Lemma bigmaxr_le s F j:
@@ -149,16 +149,16 @@ Lemma bigmaxr_le s F j:
 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_maxr lexx.
+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_maxr lexx orbT.
+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 le_maxl; case /andP => Fk Hr1 i.
+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.
 
@@ -167,8 +167,8 @@ 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_maxr.
-case  (ltrP 0 (F a)); first by exists a => //; rewrite in_cons eqxx.
+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.
@@ -196,7 +196,7 @@ 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 le_maxl; apply /andP.
+  by  move=> x y xm ym; rewrite ge_max; apply /andP.
 by  move=> i; rewrite andbT; apply: leFm.
 Qed.
 
@@ -226,21 +226,21 @@ 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_maxr IHn orbT.
+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_maxr lexx.
+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_maxr lexx orbT.
+by rewrite le_max lexx orbT.
 Qed.
 
 Lemma bigmaxf_le0 f n: \max_(i < n) f i <= 0 ->
    forall i, (i <n)%N -> f i <= 0.
 Proof.
-elim: n => [_ i //| n Hr]; rewrite bigmaxf_rec le_maxl; case /andP => Fk H i.
+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.
 
@@ -248,7 +248,7 @@ Lemma bigmaxf_gt0 f n:  \max_(i < n ) f i > 0 -> { i | (i <n)%N  & f 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_maxr leNgt; move /negbTE => ->; rewrite orFb => aux.
+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.
 
@@ -276,7 +276,7 @@ Proof.
 move=> 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 le_maxl; apply /andP.
+  by  move=> x y xm ym; rewrite ge_max; apply /andP.
 by move=> [i hi] _; apply: leFm.
 Qed.
 
@@ -296,7 +296,7 @@ apply: le_trans (_: \sum_(i < n) `| f i * g i| <= _).
   apply: ler_norm_sum.
 have ->:  \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_wpmul2r.
+rewrite  mulr_sumr; apply: ler_sum => i _; apply: ler_wpM2r.
   by rewrite normr_ge0.
 by apply: (bigmaxf_le (fun i => `|f i|)).
 Qed.
@@ -306,7 +306,7 @@ Lemma normr_sumprod1 f g n b:
   `| \sum_(i< n) (f i * g i) |  <= b * \sum_ (i<n) `| g i|.
 Proof.
 move=> b0 h; apply: (le_trans (normr_sumprod f g n)).
-apply: ler_wpmul2r;  first by rewrite sumr_ge0 // => i _; rewrite absr_ge0.
+apply: ler_wpM2r;  first by rewrite sumr_ge0 // => i _; rewrite absr_ge0.
 exact /(bigmaxf_lerP (fun z => `|f z|)  n b0).
 Qed.
 
@@ -439,14 +439,19 @@ 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.   
+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).
-
+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.
@@ -650,7 +655,7 @@ Qed.
 Lemma reciprocalM p q :
   reciprocal_pol (p * q) = reciprocal_pol p * reciprocal_pol q.
 Proof.
-move: (reciprocalC (GRing.zero R)) => aux.
+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.
@@ -727,7 +732,7 @@ Proof.
 move=> Hp.
 have H0noroot : ~~(root (p %/ 'X^(\mu_0 p)) 0).
   rewrite -mu_gt0.
-    rewrite -eqn0Ngt -(addr0 'X) -(@oppr0 (poly_zmodType R)) -polyC0 mu_div
+    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 //.
@@ -824,8 +829,8 @@ 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_paddr //.
-rewrite addrC -ler_subl_addr.
+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 => <-;
@@ -837,9 +842,9 @@ 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_wpmul2l cp) // ler_pdivl_mulr // mulrC pa ger_addl lerN10.
-move:  (le_trans r1 r2); rewrite mulrA  ler_pdivl_mulr // mulrC.
-rewrite normrX ler_pmul2r //.
+  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.
 
@@ -847,7 +852,7 @@ 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 ler_addr.
+  rewrite big_ord_recr /= divff // normr1 lerDr.
   rewrite sumr_ge0 // => i _; rewrite  absr_ge0 //.
 move: (CauchyBound_aux).
 case e: n=> [| m].
@@ -863,7 +868,7 @@ move => h1; have h2 :  x =  - \sum_(i < m.+1) ( x^-(m - i) *(E i / E m.+1)).
     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) /= ler_addl normr_ge0.
+  by rewrite (big_ord_recr m.+1) /= lerDl normr_ge0.
 have pa:  (forall i, (i<m.+1)%N ->  `| x ^- (m - i) | <= 1).
   move => i lin.
   have pa: 0 < `|x ^+ (m - i)| by rewrite normr_gt0  expf_eq0 x0 andbF.
@@ -896,14 +901,14 @@ 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 ler_expn2r// ?andbT ?exprn_ge0// nnegrE (le_trans _ 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_wpmul2r // ?subr_ge0 //.
+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.
@@ -911,7 +916,7 @@ 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_pmul pc pa pd pb); rewrite - exprD subnK //; move: lin; case n.
+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 ->
@@ -928,7 +933,7 @@ have ->: aux =  ((\sum_(i<size p) `|p`_i| * (z^+(i.-1) *+ i)) * (y - x)).
   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_wpmul2l (normr_ge0 p`_i)); exact: (diff_xn_ub i zx xy yz).
+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)]) :
@@ -936,8 +941,8 @@ Lemma pol_ucont (p : {poly R}) a b (c := (norm_pol p^`()).[(Num.max (- a) b)]) :
 Proof.
 move => x y ax xy yb.
 apply: pol_lip => //.
-apply: (le_trans _ ax); by rewrite ler_oppl le_maxr lexx.
-apply: (le_trans  yb); by rewrite  le_maxr lexx orbT.
+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 ->
@@ -946,24 +951,24 @@ Lemma pol_cont (p : {poly R}) (x eps :R):  0 < eps ->
 Proof.
 move => ep.
 move: (pol_ucont p (a:= x-1)(b:=x+1)); set c := _ .[_ ] => /= hc.
-have pa: x-1 <= x by move: (ler_add2l x (-1) 0); rewrite addr0 lerN10.
-have pb: x <= x+1 by move: (ler_add2l x 0 1); rewrite ler01 addr0.
+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_minr ltr01 /= divr_gt0 // ? ep //.
-  by apply: (lt_le_trans ltr01); move: (ler_add2r 1 0 c); rewrite add0r cp.
+  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_minr; case /andP => xy1 xy2.
+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_pmul2l cp) in xy2; apply: (lt_le_trans xy2).
-   rewrite mulrCA  ger_pmulr //.
-   have c1: c <= c + 1  by move: (ler_add2l c 0 1); rewrite ler01 addr0.
+   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_pmul2r c1p) mulfVK ? (gt_eqF c1p) // mul1r.
+   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'.
@@ -1035,7 +1040,7 @@ 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_maxr lexx.
+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.
@@ -1046,21 +1051,21 @@ 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_pmul2r xp) (mulrVK (unitf_gt0 xp)).
+   rewrite mulrAC  -(ltr_pM2r xp) (mulrVK (unitf_gt0 xp)).
    move: hh.
    rewrite -/x.
-   by rewrite ltr_pdivr_mulr// (mulrC _ x).
+   by rewrite ltr_pdivrMr// (mulrC _ x).
 have hh2 : v-u < eps.
-  by apply: le_lt_trans hh1; rewrite - {1} (mulr1 (v-u)) (ler_pmul2l c2p).
+  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_pmul2l c2p) le_maxr lexx orbT //.
-rewrite eq1 /pair_in_interval pun pvp dvp  (ltW hh2) ler_oppl.
+  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]) ler_add2l oppr_ge0 ltW.
-by rewrite -{1} (add0r (- p.[u])) ler_add2r.
+   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):
@@ -1084,14 +1089,14 @@ Lemma constructive_ivt_ter  (p : {poly R})(a b : R) (eps: R):
       (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) ltr_add2r.
+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_pmul2r ba') mul0r.
+  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_pdivl_mulr // mul0r mulr_gt0.
+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 _.
@@ -1114,7 +1119,7 @@ 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) // ler_addl mulr_ge0 //.
+  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=> //.
@@ -1125,8 +1130,8 @@ have ia'_sharp : (ia' < n.+1)%N.
 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} ler_add2l //= -{2}(mulr1 (b -a)) ler_wpmul2l //.
-    rewrite ler_pdivr_mulr ?ltr0Sn // mul1r -subr_gte0 /=.
+  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.
@@ -1136,17 +1141,18 @@ have b'a'_sub : b' - a' = (b - a) / (n.+1)%:R.
   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 ltr_addr.
+  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_pdivr_mulr ?ltr0Sn // mulrC [eps * _]mulrC.
-    rewrite -ler_pdivr_mulr //; apply: (ltW  qn).
+    rewrite mulrA ler_pdivrMr ?ltr0Sn // mulrC [eps * _]mulrC.
+    rewrite -ler_pdivrMr //; apply: (ltW  qn).
 case/ler_normlP => h1 h2.
-rewrite ler_oppl -(ler_add2l p.[b']) (le_trans h2) ? ler_addr //.
-by rewrite -(ler_add2r (- p.[a'])) (le_trans h2) // ler_addl oppr_gte0 ltW.
+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
index 2ca3ff0..92eb380 100644
--- a/theories/poly_normal.v
+++ b/theories/poly_normal.v
@@ -6,7 +6,7 @@ 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 
+- constructions on sequences, such as all_neq0, all_pos, increasing, mid, seqmul, seqn0
 - proof of Proposition 2.44 of [bpr], normal_changes
 *)
 (******************************************************************************)
@@ -183,8 +183,8 @@ rewrite exprMn_comm; last first.
   by rewrite -mulNrn mulrC.
 rewrite sqrrN.
 rewrite -natrX.
-rewrite mulr_natl.
-rewrite [_ ^+2 *+ _]mulrS ler_add2l -mulr_natl -andbA /=.
+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 ->.
@@ -195,7 +195,7 @@ 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_spaddl ?orbT // ?lt_def sqr_ge0 // sqrf_eq0.
+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.
@@ -350,7 +350,7 @@ 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 ler_addl sumr_ge0 //.
+  rewrite lerDl sumr_ge0 //.
   case => /= i Hi Hi2.
   rewrite pmulr_rge0.
     case Hki : (k - i <= (size q).-1)%N.
@@ -370,7 +370,7 @@ rewrite (bigD1 (Ordinal Hk3)) //=
       -[size q]prednK ?size_poly_gt0 // addSn addnS -!pred_Sn in Hk.
   rewrite pmulr_rgt0; first by rewrite Hqcoef.
   by apply: Hpcoef.
-rewrite ler_addl sumr_ge0 //.
+rewrite lerDl sumr_ge0 //.
 case => /= i Hi Hi2.
 apply: mulr_ge0.
   case Hi3 : (i <= (size p).-1)%N.
@@ -402,7 +402,7 @@ rewrite (big_cat_nat op (n:=n)) // big_nat1 Hn
   [x in (op _ _ = x)](big_cat_nat op (n:=n)) // big_nat1 big_nat1
   (Monoid.mulmA op).
 congr (op _ _).
-rewrite -big_split big_nat [x in (_ = x)]big_nat.
+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=> _ ->.
@@ -531,9 +531,9 @@ apply/normalP; split=> [k | |k Hk |i Hpqi j Hij Hj].
       \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_comoid R) (fun j => true)
+    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_comoid R)
+      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.
@@ -547,8 +547,8 @@ apply/normalP; split=> [k | |k Hk |i Hpqi j Hij Hj].
   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_comoid R/0]_(1 <= i < k.+1)
-      (GRing.add_comoid R)
+  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.
@@ -586,8 +586,8 @@ apply/normalP; split=> [k | |k Hk |i Hpqi j Hij Hj].
       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_comoid R/0]_(0 <= i < k.-1)
-         \big[GRing.add_comoid R/0]_(i.+1 <= j < k)
+    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))).
@@ -602,14 +602,14 @@ apply/normalP; split=> [k | |k Hk |i Hpqi j Hij Hj].
       \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_comoid R) (n:= k)) //
+      rewrite (big_cat_nat GRing.add (n:= k)) //
         big_nat1 big_nat1
-        [x in (_ = _ + x)](big_cat_nat (GRing.add_comoid R) (n:= k)) //
+        [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_comoid R) (n:= k)) //.
+      rewrite  (big_cat_nat GRing.add (n:= k)) //.
         rewrite big_nat1.
         by rewrite (addnK k 0%N).
       apply: ltnW.
@@ -620,14 +620,14 @@ apply/normalP; split=> [k | |k Hk |i Hpqi j Hij Hj].
        \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_comoid R) (n:= k)) //
+      rewrite (big_cat_nat GRing.add (n:= k)) //
         big_nat1 big_nat1
-        [x in (_ = _ + x)](big_cat_nat (GRing.add_comoid R) (n:= k)) //
+        [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_comoid R) (n:= k)) //.
+      rewrite  (big_cat_nat GRing.add (n:= k)) //.
         by rewrite big_nat1 (addnK k 0%N).
       apply: ltnW.
       by case/andP : Hi.
@@ -637,15 +637,15 @@ apply/normalP; split=> [k | |k Hk |i Hpqi j Hij Hj].
       [x in (((((_ + x) + _) + _) + _) + _)]addrC
       !addrA -big_split
       -addrA [x in (_ + x)]addrC !addrA addrC !addrA -big_split.
-    have H : \big[GRing.add_comoid R/0]_(1 <= i < k)
-      (GRing.add_comoid R)
-        ((GRing.add_comoid R)
+    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_comoid R)
-           (\big[GRing.add_comoid R/0]_(i <= j < k)
+        (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) *
@@ -848,8 +848,8 @@ 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 ((ComplexField.real_complex_rmorphism R))) /= Hp.
+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.
@@ -868,7 +868,7 @@ Lemma real_root_div_poly_deg1 (p : {poly R}) (z : C) :
 Proof.
 move=>Himz Hroot.
 rewrite root_factor_theorem (@complexE _ z) Himz mulr0 addr0 in Hroot.
-rewrite -(dvdp_map ((ComplexField.real_complex_rmorphism R))) /=.
+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.
@@ -1579,8 +1579,8 @@ apply/increasingP => k Hk.
 rewrite spseq_size in Hk.
 rewrite (@spseq_coef k) //.
   rewrite (@spseq_coef k.+1) //.
-    rewrite ler_sub // ler_pdivr_mulr.
-      rewrite mulrC mulrA ler_pdivl_mulr.
+    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.
diff --git a/theories/preliminaries.v b/theories/preliminaries.v
index 60404a8..1d0f456 100644
--- a/theories/preliminaries.v
+++ b/theories/preliminaries.v
@@ -1,4 +1,23 @@
+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
+}}.
+
+
+
 Require Import Reals.
+From HB Require Import structures.
 From mathcomp Require Import all_ssreflect all_algebra vector reals classical_sets Rstruct.
 From infotheo Require Import convex.
 
@@ -14,15 +33,16 @@ Unset Printing Implicit Defensive.
 Lemma enum_rank_index {T : finType} i :
   nat_of_ord (enum_rank i) = index i (enum T).
 Proof.
-rewrite /enum_rank /enum_rank_in /insubd /odflt /oapp insubT//.
+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 [finType of T1 * T2] = prod_enum T1 T2.
-Proof. by rewrite enumT Finite.EnumDef.enumDef. Qed.
+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 ->
@@ -30,7 +50,7 @@ Lemma index_allpairs {T1 T2: eqType} (s1: seq T1) (s2: seq T2) x1 x2 :
     ((index x1 s1) * (size s2) + index x2 s2)%N.
 Proof.
 move=>ins1 ins2.
-elim: s1 ins1=>//= a s1 IHs1 ins1.
+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 /=.
@@ -43,11 +63,11 @@ case in12: ((x1, x2) \in [seq (a, x0) | x0 <- s2]).
 by rewrite size_map (IHs1 ins1) addnA.
 Qed.
 
-Lemma enum_rank_prod {T T': finType} i j :
-  (nat_of_ord (@enum_rank [finType of T * T'] (i, j)) = (enum_rank i) * #|T'| + enum_rank j)%N.
+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 enumT Finite.EnumDef.enumDef cardE=>/=.
+rewrite enum_prodE cardE /=.
 by apply index_allpairs; rewrite enumT.
 Qed.
 
@@ -93,10 +113,10 @@ by exists (a' :: s').
 Qed.
 
 Lemma index_enum_cast_ord n m (e: n = m) :
-  index_enum [finType of 'I_m] = [seq (cast_ord e i) | i <- index_enum [finType of 'I_n]].
+  index_enum 'I_m = [seq (cast_ord e i) | i <- index_enum 'I_n].
 Proof.
 subst m.
-rewrite -{1}(map_id (index_enum [finType of 'I_n])).
+rewrite -{1}(map_id (index_enum 'I_n)).
 apply eq_map=>[[x xlt]].
 rewrite /cast_ord; congr Ordinal; apply bool_irrelevance.
 Qed.
@@ -178,7 +198,7 @@ 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 [finType of 'I_(size s)]] = s.
+  [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].
@@ -209,7 +229,7 @@ From infotheo Require Import fdist.
 Local Open Scope fdist_scope.
 
 Lemma Convn_pair [T U : convType] [n : nat] (g : 'I_n -> T * U) (d : {fdist 'I_n}) :
-  Convn d g = (Convn d (fst \o g), Convn d (snd \o g)).
+  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.
diff --git a/theories/preliminaries_hull.v b/theories/preliminaries_hull.v
index 86607bd..667a501 100644
--- a/theories/preliminaries_hull.v
+++ b/theories/preliminaries_hull.v
@@ -36,8 +36,8 @@ 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=>/(_ 0).
-   by move=>lmono; apply (ltn_trans (lmono 0)); apply IHl=>i/=; apply (lmono (lift ord0 i)).
+   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.
@@ -216,18 +216,21 @@ 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
diff --git a/theories/safe_cells.v b/theories/safe_cells.v
new file mode 100644
index 0000000..f3aaf4b
--- /dev/null
+++ b/theories/safe_cells.v
@@ -0,0 +1,751 @@
+From mathcomp Require Import all_ssreflect all_algebra.
+Require Export Field.
+Require Import generic_trajectories.
+Require Import math_comp_complements points_and_edges events cells.
+Require Import opening_cells cells_alg.
+
+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.
+
+Section safety_property.
+
+Variable R : realFieldType.
+
+Notation pt := (@pt R).
+Notation p_x := (p_x R).
+Notation p_y := (p_y R).
+Notation Bpt := (Bpt R).
+Notation edge := (@edge R).
+Notation cell := (@cell R edge).
+Notation low := (low R edge).
+Notation high := (high R edge).
+Notation left_pts := (left_pts R edge).
+Notation right_pts := (right_pts R edge).
+Notation dummy_pt := (dummy_pt R 1).
+Notation event := (@event R edge).
+Notation point' := (@point R edge).
+Notation outgoing := (@point R edge).
+
+Variables closed : seq cell.
+(* The last open cell.  We need to prove that that its top edge is top.
+   Then, coverage will be given for all obstacles by the fact that all
+   edges in obstacles are different from top. *)
+Variables bottom top : edge.
+Variable obstacles : seq edge.
+Variables points : seq pt.
+
+Hypothesis obstacles_sub :
+  {subset [seq low c | c <- closed] ++
+     [seq high c | c <- closed] <= bottom :: top :: obstacles}.
+
+Hypothesis obstacles_point_in :
+  {subset [seq left_pt g | g <- obstacles] ++
+    [seq right_pt g | g <- obstacles] <= points}.
+
+Hypothesis disj_closed :  {in closed &, disjoint_closed_cells R}.
+(*
+Hypothesis disj_open :  {in [:: o_cell] & closed, disjoint_open_closed_cells R}*)
+
+Hypothesis coverage : {in obstacles, forall g, edge_covered g [::] closed}.
+Hypothesis covered_points :
+   {in points, forall (p : pt), exists2 c,
+       c \in closed & p \in (right_pts c : seq pt) /\
+       (p >>> low c)}.
+
+Hypothesis non_empty_closed : {in closed, forall c, left_limit c < right_limit c}.
+Hypothesis closed_ok : {in closed, forall c, closed_cell_side_limit_ok c}.
+Hypothesis noc : {in bottom :: top :: obstacles &,
+  forall g1 g2, inter_at_ext g1 g2}.
+Hypothesis low_high : {in closed, forall c, low c <| high c}.
+Hypothesis low_dif_high : {in closed, forall c, low c != high c}.
+
+Lemma x_left_pts_left_limit (c : cell) (p : pt) :
+  closed_cell_side_limit_ok c ->
+  p \in (left_pts c : seq pt) -> p_x p = left_limit c.
+Proof.
+move=> + pin; move=> /andP[] ln0 /andP[] lsx _.
+by rewrite (eqP (allP lsx _ _)).
+Qed.
+
+Lemma x_right_pts_right_limit (c : cell) (p : pt) :
+  closed_cell_side_limit_ok c ->
+  p \in (right_pts c : seq pt) -> p_x p = right_limit c.
+Proof.
+move=> + pin; move=> /andP[] _ /andP[] _ /andP[] _ /andP[] _ /andP[] _.
+move=> /andP[] rn0 /andP[] rsx _.
+by rewrite (eqP (allP rsx _ _)).
+Qed.
+
+Lemma left_limit_left_pt_high_cl (c : cell) :
+  closed_cell_side_limit_ok c ->
+  p_x (left_pt (high c)) <= left_limit c.
+Proof.
+move=> /andP[] ln0 /andP[] lsx /andP[] _ /andP[] /andP[] _ /andP[] + _ _.
+by rewrite (eqP (allP lsx _ (head_in_not_nil _ ln0))).
+Qed.
+
+Lemma right_limit_right_pt_high_cl (c : cell) :
+  closed_cell_side_limit_ok c ->
+  right_limit c <= p_x (right_pt (high c)).
+Proof.
+move=> /andP[] _ /andP[] _ /andP[] _ /andP[] _ /andP[] _.
+move=> /andP[] rn0 /andP[] rsx /andP[] _ /andP[] /andP[] _ /andP[] _ + _.
+by rewrite (eqP (allP rsx _ (head_in_not_nil _ rn0))).
+Qed.
+
+Lemma left_limit_left_pt_low_cl (c : cell) :
+  closed_cell_side_limit_ok c ->
+  p_x (left_pt (low c)) <= left_limit c.
+Proof.
+move=> /andP[] ln0 /andP[] lsx /andP[] _ /andP[] _ /andP[].
+move=> /andP[] _ /andP[] + _ _.
+by rewrite (eqP (allP lsx _ (last_in_not_nil _ ln0))).
+Qed.
+
+Lemma right_limit_right_pt_low_cl (c : cell) :
+  closed_cell_side_limit_ok c ->
+  right_limit c <= p_x (right_pt (low c)).
+Proof.
+move=> /andP[] _ /andP[] _ /andP[] _ /andP[] _ /andP[] _.
+move=> /andP[] rn0 /andP[] rsx /andP[] _ /andP[] _ /andP[] _ /andP[] _ +.
+by rewrite (eqP (allP rsx _ (last_in_not_nil _ rn0))).
+Qed.
+
+Lemma right_valid :
+  {in closed, forall c, {in (right_pts c : seq pt), forall p, 
+      valid_edge (low c) p /\ valid_edge (high c) p}}.
+Proof.
+move=> c cin p pin.
+have cok := closed_ok cin.
+have lltr : left_limit c < right_limit c.
+  by apply: non_empty_closed cin.
+split.
+  apply/andP; split; rewrite (x_right_pts_right_limit cok pin).
+    apply/(le_trans (left_limit_left_pt_low_cl cok)).
+    by apply/ltW.
+  by apply: right_limit_right_pt_low_cl.
+apply/andP; split; rewrite (x_right_pts_right_limit cok pin).
+  apply/(le_trans (left_limit_left_pt_high_cl cok)).
+  by apply/ltW.
+by apply: right_limit_right_pt_high_cl.
+Qed.
+
+Lemma closed_cell_in_high_above_low p (c : cell) :
+  low c != high c ->
+  low c <| high c ->
+  inter_at_ext (low c) (high c) ->
+  closed_cell_side_limit_ok c ->
+  left_limit c < p_x p < right_limit c ->
+  p === high c -> p >>> low c.
+Proof.
+move=> dif bel noclh cok /andP[] midl midr on.
+have [vlp vhp] : valid_edge (low c) p /\ valid_edge (high c) p.
+  move: cok=> /andP[] ln0 /andP[] lsx /andP[].
+  move=> _ /andP[] /andP[] _ /andP[] lh _ /andP[] /andP[] _ /andP[] ll _.
+  move=> /andP[] rn0 /andP[] rsx /andP[].
+  move=> _ /andP[] /andP[] _ /andP[] _ rl /andP[] _ /andP[] _ rh.
+  rewrite (eqP (allP lsx _ (@last_in_not_nil pt dummy_pt _ ln0))) in ll.
+  rewrite (eqP (allP rsx _ (@head_in_not_nil pt dummy_pt _ rn0))) in rl.
+  rewrite (eqP (allP lsx _ (@head_in_not_nil pt dummy_pt _ ln0))) in lh.
+  rewrite (eqP (allP rsx _ (@last_in_not_nil pt dummy_pt _ rn0))) in rh.
+  split; rewrite /valid_edge/generic_trajectories.valid_edge.
+    by rewrite (ltW (le_lt_trans ll midl)) (ltW (lt_le_trans midr rh)).
+  by rewrite (ltW (le_lt_trans lh midl)) (ltW (lt_le_trans midr rl)).
+rewrite under_onVstrict // negb_or.
+move: noclh=> [abs | noclh]; first by rewrite abs eqxx in dif.
+apply/andP; split; last first.
+  apply/negP=> abs.
+  have := order_edges_strict_viz_point' vlp vhp bel abs.
+  by rewrite strict_nonAunder // on.
+apply/negP=> abs.
+have := noclh _ abs on; rewrite !inE=> /orP[] /eqP {}abs.
+  move: midl; apply/negP; rewrite -leNgt abs.
+  by apply: left_limit_left_pt_low_cl.
+(* TODO: at this place, the typechecking loops, this warrants a bug report. *)
+(*(  have := left_limit_max cok. *)
+move: midr; apply/negP; rewrite -leNgt abs.
+by apply: right_limit_right_pt_low_cl.
+Qed.
+
+(* I don't know yet if this is going to be used. *)
+Lemma above_low :
+  {in closed, forall c p, p === high c -> valid_edge (low c) p ->
+     p >>= low c}.
+Proof.
+move=> c cin p /[dup] ponh /andP[] _ vh vl.
+apply/negP=> pul.
+have lbh : low c <| high c by apply: low_high.
+have := order_edges_strict_viz_point' vl vh lbh pul.
+by rewrite strict_nonAunder // ponh.
+Qed.
+
+Lemma right_side_under_high (c : cell) (p : pt) :
+  closed_cell_side_limit_ok c ->
+  valid_edge (high c) p ->
+  p \in (right_pts c : seq pt) ->
+  p <<= high c.
+Proof.
+move=> cok vph pin.
+set p' := Bpt (p_x p) (pvert_y p (high c)).
+have sx: p_x p = p_x p' by rewrite /p'.
+have p'on : p' === high c by apply: pvert_on vph.
+rewrite (under_edge_lower_y sx) //.
+have := cok.
+do 5 move=> /andP[] _.
+move=> /andP[] rn0 /andP[] rsx /andP[] srt /andP[] lon _.
+have p'q : p' = head dummy_pt (right_pts c).
+  have := on_edge_same_point p'on lon.
+  have /eqP -> := allP rsx _ (head_in_not_nil dummy_pt rn0).
+  have /eqP -> := allP rsx _ pin=> /(_ erefl) samey.
+  apply/(@eqP pt).
+  rewrite pt_eqE samey eqxx andbT.
+  rewrite (eqP (allP rsx _ pin))/=.
+  by rewrite (eqP (allP rsx _ (head_in_not_nil dummy_pt rn0))).
+move: rn0 p'q pin srt.
+elim: (right_pts c) => [| p2 rpts Ih] // rn0 p'1 pin srt.
+move: pin; rewrite inE => /orP[/eqP -> | pin].
+  by rewrite p'1.
+rewrite /= in srt.
+(* TODO : use rev_trans here. *)
+have gt_trans : transitive (>%R : rel R).
+  by move=> x y z xy yz ; apply: (lt_trans yz xy).
+move: (srt); rewrite (path_sortedE gt_trans)=> /andP[] srt' _.
+apply: ltW; rewrite p'1.
+by apply: (allP srt'); rewrite map_f.
+Qed.
+
+Lemma in_bound_closed_valid (c : cell) p :
+  closed_cell_side_limit_ok c ->
+  left_limit c <= p_x p -> p_x p <= right_limit c ->
+  valid_edge (low c) p /\ valid_edge (high c) p.
+Proof.
+move=> cok lp pr.
+have llh := left_limit_left_pt_high_cl cok.
+have lll := left_limit_left_pt_low_cl cok.
+have rrh := right_limit_right_pt_high_cl cok.
+have rrl := right_limit_right_pt_low_cl cok.
+split; rewrite /valid_edge/generic_trajectories.valid_edge.
+  by rewrite (le_trans lll lp) (le_trans pr rrl).
+by rewrite (le_trans llh lp) (le_trans pr rrh).
+Qed.
+
+Lemma left_side_under_high (c : cell) p :
+  closed_cell_side_limit_ok c ->
+  valid_edge (high c) p ->
+  p \in (left_pts c : seq pt) ->
+  p <<= high c.
+Proof.
+move=> cok vph pin.
+set p' := Bpt (p_x p) (pvert_y p (high c)).
+have sx: p_x p = p_x p' by rewrite /p'.
+have p'on : p' === high c by apply: pvert_on vph.
+rewrite (under_edge_lower_y sx) //.
+have := cok.
+move=> /andP[] ln0 /andP[] lsx /andP[] srt /andP[] hon _.
+have p'q : p' = head dummy_pt (left_pts c).
+  have := on_edge_same_point p'on hon.
+  rewrite (eqP (allP lsx _ pin)).
+  rewrite (x_left_pts_left_limit cok (head_in_not_nil _ ln0)).
+  move=> /(_ erefl) samey.
+  apply/(@eqP pt); rewrite pt_eqE samey eqxx andbT.
+  rewrite (eqP (allP lsx _ pin)) eq_sym.
+  by rewrite (allP lsx _ (head_in_not_nil _ ln0)).
+move: ln0 p'q pin srt.
+case: (left_pts c)=> [| p2 lpts] // _ p'q pin srt.
+move: pin; rewrite (@in_cons pt) => /orP[/eqP -> | pin].
+  by rewrite p'q.
+apply: ltW; rewrite p'q.
+move: srt=> /=; rewrite (path_sortedE); last first.
+  by move=> x y z xy yz; apply: (lt_trans yz xy).
+move=> /andP[] /allP/(_ (p_y p)) + _; apply.
+by rewrite (@map_f pt).
+Qed.
+
+Lemma safe_cell_interior c p :
+  c \in closed -> p <<< high c -> p >>> low c ->
+  left_limit c < p_x p < right_limit c ->
+  {in obstacles, forall g, ~~ (p === g)}.
+Proof.
+move=> ccl puh pal /andP[] pright pleft g gin; apply/negP=> pong.
+have pinc : inside_closed' p c.
+  by rewrite inside_closed'E (underW puh) pal pright (ltW pleft).
+have [[opc [pccs [pccssub [highs [cpccs [opco lopcq]]]]]] | ] := coverage gin.
+  by [].
+move=> [[ | pc1 pcc] [pccn0 [pcccl [ highs [conn [lpcc rpcc]]]]]].
+  by [].
+have : left_limit pc1 <= p_x p.
+  by move:(pong)=> /andP[] _ /andP[]; rewrite lpcc.
+rewrite le_eqVlt=> /orP[ /eqP pxq | ].
+  have plg : p = left_pt g.
+    move: lpcc; rewrite /= pxq=> samex.
+    have := on_edge_same_point pong (left_on_edge _).
+    rewrite samex=> /(_ erefl) samey.
+    by apply/(@eqP pt); rewrite pt_eqE samex samey !eqxx.
+  have pin : p \in points.
+    apply: obstacles_point_in; rewrite mem_cat; apply/orP; left.
+    by rewrite plg map_f.
+  have [c' ccl' [pc'r p'al]] := (covered_points pin).
+  have := disj_closed ccl ccl'.
+  move=> [cqc' | ].
+    have := non_empty_closed ccl'.
+    move: pleft; rewrite cqc'.
+    by rewrite (x_right_pts_right_limit (closed_ok ccl')) // lt_irreflexive.
+  move=> /(_ p); rewrite pinc=> /negP; apply.
+  rewrite inside_closed'E p'al.
+  have c'ok := closed_ok ccl'.
+  have /andP[_ /andP[_ /andP[_ /andP[_ /andP[_ ]]] ]] := c'ok.
+  move=> /andP[rn0 /andP[samex /andP[srt /andP[onhigh onlow]]]].
+  have prlq : p_x p = right_limit c' by apply/eqP/(allP samex).
+  rewrite (under_edge_lower_y _ onhigh) /=; last first.
+    rewrite (eqP (allP samex _ pc'r)).
+    by rewrite (eqP (allP samex _ (head_in_not_nil dummy_pt rn0))).
+  have -> /= : p_y p <= p_y (head dummy_pt (right_pts c')).
+    case psq : (right_pts c') => [ | p1 ps]; first by rewrite psq in rn0.
+    move: pc'r; rewrite psq inE=> /orP[/eqP -> | pps]; first by [].
+    apply: ltW.
+    (* TODO : use rev_trans here. *)
+    have gt_trans : transitive (>%R : rel R).
+      by move=> x y z xy yz; apply: (lt_trans yz xy).
+    move: (srt); rewrite psq /= (path_sortedE gt_trans)=> /andP[] + _.
+    by move=> /allP /(_ _ (map_f _ pps)).
+  by rewrite prlq le_refl andbT (non_empty_closed ccl').
+elim: pcc pc1 pcccl highs conn rpcc {lpcc pccn0} =>
+  [ | pc2 pcc Ih] pc1 pcccl highs conn rpcc pc1lp.
+  have pc1cl : pc1 \in closed by apply: pcccl; rewrite inE eqxx.
+  have hpc1 : high pc1 = g by apply: (highs _ (mem_head _ _)).
+  move: rpcc; rewrite /last_cell/= => rpc1.
+  have vgp : valid_edge g p by move: pong=> /andP[].
+  have [pr | pnr ] := eqVneq (p : pt) (right_pt g).
+    have [c' c'in [prc' pin']] : exists2 c', c' \in closed &
+        p_x p = right_limit c' /\ inside_closed' p c'.
+      have pp : p \in points.
+        by apply/obstacles_point_in; rewrite pr mem_cat map_f // orbT.
+      have [c' c'in [pr' pal']] := covered_points pp.
+      exists c'; rewrite // inside_closed'E pal'.
+      rewrite (x_right_pts_right_limit (closed_ok c'in)) // le_refl.
+      rewrite (non_empty_closed c'in).
+      have [vpl' vph'] := right_valid c'in pr'.
+      by rewrite (right_side_under_high (closed_ok c'in)).
+    have [cqc' | ] := disj_closed ccl c'in.
+      by move: pleft; rewrite prc' cqc'; rewrite lt_irreflexive.
+    by move=> /(_ p); rewrite pin' pinc.
+  have noc1 : inter_at_ext (low pc1) (high pc1).
+    by apply/noc; apply: obstacles_sub; rewrite mem_cat map_f //= ?orbT.
+  have ponh : p === high pc1 by rewrite hpc1.
+  have pin1 : inside_closed' p pc1.
+    rewrite inside_closed'E under_onVstrict hpc1 // pong pc1lp /=.
+    rewrite rpc1; move: vgp=> /andP[] _ ->; rewrite andbT.
+    have := closed_cell_in_high_above_low (low_dif_high pc1cl) (low_high pc1cl)
+    noc1 (closed_ok pc1cl) _ ponh; apply.
+    rewrite pc1lp /= rpc1.
+    move: (pong)=> /andP[] _ /andP[] _; rewrite le_eqVlt=> /orP[]; last by [].
+    move=> /eqP abs.
+    move: pnr=> /negP[]; rewrite pt_eqE abs /=.
+    rewrite (on_edge_same_point pong (right_on_edge _)) -abs//.
+    by rewrite !eqxx.
+  have vph1 : valid_edge (high pc1) p by move: ponh=> /andP[].
+  have [cqc' | ] := disj_closed ccl pc1cl.
+    by move: puh; rewrite strict_nonAunder cqc' // ponh.
+  by move=> /(_ p); rewrite pin1 pinc.
+have pcccl' : {subset pc2 :: pcc <= closed}.
+  by move=> c' c'in; apply: pcccl; rewrite inE c'in orbT.
+have highs' : {in pc2 :: pcc, forall c, high c = g}.
+  by move=> c' c'in; apply highs; rewrite inE c'in orbT.
+have conn' : connect_limits (pc2 :: pcc).
+  by move: conn; rewrite /= => /andP[].
+have rpcc' : right_limit (last_cell (pc2 :: pcc)) = p_x (right_pt g).
+  by exact: rpcc.
+have [pleft2 | pright2 ] := lerP (p_x p) (left_limit pc2).
+(* In this case, p is inside pc1, contradiction with pinc *)
+  have v1 : valid_edge g p by move: pong=> /andP[].
+  have pc1cl : pc1 \in closed by apply: pcccl; rewrite inE eqxx.  
+  suff pin1 : inside_closed' p pc1.
+    have [cqpc1 | ] := disj_closed ccl pc1cl.
+      move: puh; rewrite cqpc1 (highs _ (mem_head _ _)) strict_nonAunder //.
+      by rewrite pong.
+  by move=> /(_ p); rewrite pin1 pinc.
+  rewrite inside_closed'E.
+  have r1l2 : right_limit pc1 = left_limit pc2.
+    by apply/eqP; move: conn=> /= /andP[].
+  move: (conn)=> /= /andP[] /eqP -> _; rewrite pleft2 pc1lp !andbT.
+  rewrite (highs _ (mem_head _ _)) under_onVstrict // pong /=.
+  have ponh : p === high pc1 by rewrite (highs _ (mem_head _ _)).
+  have noc1 : inter_at_ext (low pc1) (high pc1).
+    by apply/noc; apply: obstacles_sub; rewrite mem_cat map_f //= ?orbT.
+  move: (pleft2); rewrite le_eqVlt=> /orP[/eqP pat | pltstrict]; last first.
+    have := closed_cell_in_high_above_low (low_dif_high pc1cl) (low_high pc1cl)
+      noc1 (closed_ok pc1cl) _ ponh; apply.
+    move: (conn)=> /= /andP[] /eqP -> _.
+    by rewrite pltstrict pc1lp.
+  have sl : p_x (left_pt g) < p_x p.
+    have llh := left_limit_left_pt_high_cl (closed_ok pc1cl).
+    by rewrite -(highs _ (mem_head _ _)); apply: (le_lt_trans llh).
+  have pc2cl : pc2 \in closed by apply: pcccl'; rewrite mem_head.
+  have sr : p_x p < p_x (right_pt g).
+    rewrite pat.
+    rewrite (lt_le_trans (non_empty_closed pc2cl)) //.
+    have := right_limit_right_pt_high_cl (closed_ok pc2cl).
+    by rewrite (highs' _ (mem_head _ _)).
+  have [vl1 vh1] : valid_edge (low pc1) p /\ valid_edge (high pc1) p.
+    have := in_bound_closed_valid (closed_ok pc1cl) (ltW pc1lp).
+    by rewrite pat r1l2 le_refl=> /(_ isT).
+  have := above_low pc1cl ponh vl1.
+  rewrite strict_nonAunder // negb_and negbK=> /orP[] ponl; last by [].
+  have lo : low pc1 \in bottom :: top :: obstacles.
+    by apply: obstacles_sub; rewrite mem_cat map_f.
+  have ho : high pc1 \in bottom :: top :: obstacles.
+    by apply: obstacles_sub; rewrite mem_cat map_f ?orbT.
+  have [lqh | ] := noc ho lo.
+    by have := low_dif_high pc1cl; rewrite lqh eqxx.
+  move=> /(_ p ponh ponl); rewrite !inE=> /orP[]/eqP pext.
+    by move: sl; rewrite pext (highs _ (mem_head _ _)) lt_irreflexive.
+  by move: sr; rewrite pext (highs _ (mem_head _ _)) lt_irreflexive.
+(* In this case, we use the induction hypothesis *)
+by have := Ih pc2 pcccl' highs' conn' rpcc' pright2.
+Qed.
+
+End safety_property.
+
+Lemma last_no_dup_seq {T : eqType} (s : seq T) d:
+  last d (no_dup_seq s) = last d s.
+Proof.
+elim: s d => [ | a [ | b s'] Ih] //.
+rewrite /=; case: ifP=> [/eqP ab | anb].
+  by apply: Ih.
+move=> d /=; apply: Ih.
+Qed.
+
+Lemma head_no_dup_seq {T : eqType} (s : seq T) d:
+  head d (no_dup_seq s) = head d s.
+Proof.
+elim: s d => [ | a [ | b s'] Ih] //.
+rewrite /=; case: ifP=> [/eqP ab | anb].
+  by move=> d; rewrite Ih ab.
+by [].
+Qed.
+
+Section main_statement.
+
+Variable R : realFieldType.
+
+Notation pt := (@pt R).
+Notation p_x := (p_x R).
+Notation p_y := (p_y R).
+Notation Bpt := (Bpt R).
+Notation edge := (@edge R).
+Notation cell := (@cell R edge).
+Notation low := (low R edge).
+Notation high := (high R edge).
+Notation left_pts := (left_pts R edge).
+Notation right_pts := (right_pts R edge).
+Notation dummy_pt := (dummy_pt R 1).
+Notation event := (@event R edge).
+Notation point := (@point R edge).
+Notation outgoing := (@outgoing R edge).
+
+Definition leftmost_points :=
+ leftmost_points R eq_op le +%R (fun x y => x - y) *%R 
+  (fun x y => x / y) edge (@left_pt R) (@right_pt R).
+
+Arguments pt_eqb : simpl never.
+
+Lemma start_open_cell_ok (bottom top : edge) p :
+  {in [:: bottom; top] &, forall g1 g2, inter_at_ext g1 g2} ->
+  inside_box bottom top p ->
+  open_cell_side_limit_ok (start_open_cell bottom top).
+Proof.
+move=> noc0 /andP[] /andP[] pab put /andP[] /andP[] lbp prb /andP[] ltp prt.
+have noc : below_alt bottom top.
+  by apply: (inter_at_ext_no_crossing noc0); rewrite !inE eqxx ?orbT.
+have vb : valid_edge bottom p by rewrite /valid_edge/generic_trajectories.valid_edge !ltW.
+have vt : valid_edge top p by rewrite /valid_edge/generic_trajectories.valid_edge !ltW.
+rewrite /open_cell_side_limit_ok /=.
+have ln0 : leftmost_points bottom top != [::] :> seq pt.
+  rewrite /leftmost_points/generic_trajectories.leftmost_points.
+  case: ifP=> [lbl | ltl]; rewrite -/(vertical_intersection_point _ _) pvertE //.
+      rewrite R_ltb_lt in lbl.
+      rewrite /valid_edge/generic_trajectories.valid_edge.
+      by rewrite ltW // ?ltW // (lt_trans ltp).
+    by rewrite /no_dup_seq /=; case: ifP=> _.
+  move: ltl=> /negbT; rewrite R_ltb_lt -leNgt=> ltl.
+  by rewrite /valid_edge/generic_trajectories.valid_edge ltl ltW // (lt_trans lbp).
+rewrite ln0 /=.
+have samex : all (fun p => p_x p == left_limit (start_open_cell bottom top))
+               (leftmost_points bottom top).
+  rewrite /left_limit/generic_trajectories.left_limit.
+  rewrite /left_pts/generic_trajectories.left_pts /=.
+  rewrite /leftmost_points/generic_trajectories.leftmost_points.
+  case: ifP=> [lbl | ltl].
+    rewrite R_ltb_lt in lbl.
+    rewrite -/(vertical_intersection_point _ _).
+    rewrite pvertE; last first.
+      by rewrite /valid_edge/generic_trajectories.valid_edge ltW // ltW // (lt_trans ltp).
+    by rewrite /= !eqxx.
+  move: ltl=> /negbT; rewrite R_ltb_lt -leNgt=> ltl.
+  rewrite -/(vertical_intersection_point _ _).
+  rewrite pvertE; last first.
+    by rewrite /valid_edge/generic_trajectories.valid_edge ltl ltW // (lt_trans lbp).
+  set W := (X in no_dup_seq_aux _ X).
+  have -> : no_dup_seq_aux (pt_eqb R eq_op) W = no_dup_seq (W : seq pt).
+    by apply/esym/(@no_dup_seq_aux_eq pt).
+  have := (@eq_all_r pt _ _ (@mem_no_dup_seq pt _)).
+  move=> ->.
+  rewrite (@last_no_dup_seq pt).
+  by rewrite /W /= !eqxx.
+rewrite samex /=.
+have headin : head dummy_pt (leftmost_points bottom top) === top.
+  rewrite /leftmost_points/generic_trajectories.leftmost_points.
+  case: ifP => [lbl | ltl].
+    rewrite R_ltb_lt in lbl.
+    rewrite -/(vertical_intersection_point _ _).
+    rewrite pvertE; last first.
+      by rewrite /valid_edge/generic_trajectories.valid_edge ltW // ltW // (lt_trans ltp).
+    by rewrite /= left_on_edge.
+  move: ltl=> /negbT; rewrite R_ltb_lt -leNgt=> ltl.
+  rewrite -/(vertical_intersection_point _ _).
+  rewrite pvertE; last first.
+    by rewrite /valid_edge/generic_trajectories.valid_edge ltl ltW // (lt_trans lbp).
+  set W := (X in no_dup_seq_aux _ X).
+  have -> : no_dup_seq_aux (pt_eqb R eq_op) W = no_dup_seq (W : seq pt).
+    by apply/esym/(@no_dup_seq_aux_eq pt).
+  rewrite (@head_no_dup_seq pt).
+  rewrite /= pvert_on // /valid_edge/generic_trajectories.valid_edge.
+  by rewrite ltl ltW // (lt_trans lbp).
+have lastin : last dummy_pt (leftmost_points bottom top) === bottom.
+  rewrite /leftmost_points/generic_trajectories.leftmost_points.
+  case: ifP => [lbl | ltl].
+    rewrite R_ltb_lt in lbl.
+    rewrite -/(vertical_intersection_point _ _).
+    rewrite pvertE; last first.
+      by rewrite /valid_edge/generic_trajectories.valid_edge ltW // ltW // (lt_trans ltp).
+    by rewrite /= pvert_on // /valid_edge/generic_trajectories.valid_edge ltW // ltW // (lt_trans ltp).
+  move: ltl=> /negbT; rewrite R_ltb_lt -leNgt=> ltl.
+  rewrite -/(vertical_intersection_point _ _).
+  rewrite pvertE; last first.
+    by rewrite /valid_edge/generic_trajectories.valid_edge ltl ltW // (lt_trans lbp).
+  set W := (X in no_dup_seq_aux _ X).
+  have -> : no_dup_seq_aux (pt_eqb R eq_op) W = no_dup_seq (W : seq pt).
+    by apply/esym/(@no_dup_seq_aux_eq pt).
+  rewrite (@last_no_dup_seq pt).
+  by rewrite /= left_on_edge.
+rewrite headin lastin !andbT.
+have blt : bottom <| top.
+  by have := edge_below_from_point_above noc vb vt (underWC pab) put.
+rewrite /leftmost_points/generic_trajectories.leftmost_points.
+case: ifP => [lbl | ltl].
+  rewrite R_ltb_lt in lbl.
+  have vtb : valid_edge bottom (left_pt top).
+    by rewrite /valid_edge/generic_trajectories.valid_edge ltW // ltW // (lt_trans ltp).
+  rewrite -/(vertical_intersection_point _ _).
+  rewrite pvertE //= andbT.
+  have := order_below_viz_vertical vtb (valid_edge_left top).
+  rewrite pvertE // => /(_ _ (left_pt top) erefl _ blt) /=.
+  have -> : vertical_intersection_point (left_pt top) top = Some (left_pt top).
+   rewrite (pvertE (valid_edge_left _)); congr (Some _); apply/eqP.
+   by rewrite pt_eqE /= (on_pvert (left_on_edge _)) !eqxx.
+  move=> /(_ erefl); rewrite le_eqVlt=> /orP[/eqP abs | -> //].
+  have := pvert_on vtb; rewrite abs => lton.
+  have lteq : Bpt (p_x (left_pt top))(p_y (left_pt top)) =
+        left_pt top.
+    by apply/(@eqP pt); rewrite pt_eqE /= !eqxx.
+  rewrite lteq in lton.
+  have [bqt |]: inter_at_ext bottom top by apply: noc0; rewrite !inE eqxx ?orbT.
+    by rewrite bqt lt_irreflexive in lbl.
+  move=> /(_ _ lton (left_on_edge _)); rewrite !inE=> /orP[] /eqP same.
+    by rewrite same lt_irreflexive in lbl.
+  by have := lt_trans ltp prb; rewrite same lt_irreflexive.
+move: ltl=> /negbT; rewrite R_ltb_lt -leNgt=> ltl.
+have vbt : valid_edge top (left_pt bottom).
+  by rewrite /valid_edge/generic_trajectories.valid_edge ltl ltW // (lt_trans lbp prt).
+rewrite -/(vertical_intersection_point _ _).
+rewrite pvertE //=.
+case: ifP=> [bont | bnont ].
+  by [].
+have := order_below_viz_vertical (valid_edge_left bottom) vbt.
+have -> : vertical_intersection_point (left_pt bottom) bottom =
+               Some (left_pt bottom).
+  rewrite (pvertE (valid_edge_left _)); congr (Some _); apply/eqP.
+  by rewrite pt_eqE /= (on_pvert (left_on_edge _)) !eqxx.
+rewrite pvertE // => /(_ (left_pt bottom) _ erefl erefl blt) /=.
+rewrite le_eqVlt=> /orP[/eqP abs | -> //].
+have := pvert_on vbt; rewrite abs => lton.
+have lteq : Bpt (p_x (left_pt bottom))(p_y (left_pt bottom)) =
+        left_pt bottom.
+  by apply/(@eqP pt); rewrite pt_eqE /= !eqxx.
+rewrite -abs lteq in lton.
+have [bqt |]: inter_at_ext top bottom by apply: noc0; rewrite !inE eqxx ?orbT.
+  by move: pab; rewrite -bqt under_onVstrict // put orbT.
+  move=> /(_ _ lton (left_on_edge _)); rewrite !inE=> /orP[] /eqP same.
+  move: bnont.
+  rewrite same (on_pvert (left_on_edge top)).
+  rewrite -[X in X = false]/(_ == _ :> pt).
+  by rewrite pt_eqE !eqxx.
+by have := lt_trans lbp prt; rewrite same lt_irreflexive.
+Qed.
+
+Lemma has_inside_box_bottom_below_top (bottom top : edge) p :
+  {in [:: bottom; top] &, forall g1 g2, inter_at_ext g1 g2} ->
+  inside_box bottom top p ->
+  bottom <| top.
+Proof.
+move=> noc0.
+have : below_alt bottom top.
+  by apply: (inter_at_ext_no_crossing noc0); rewrite !inE eqxx ?orbT.
+move=> [] // abs.
+move=> /andP[] /andP[] pab put /andP[] /andP[] vb1 vb2 /andP[] vt1 vt2.
+have vb : valid_edge bottom p.
+  by rewrite /valid_edge/generic_trajectories.valid_edge !ltW.
+have vt : valid_edge top p.
+  by rewrite /valid_edge/generic_trajectories.valid_edge !ltW.
+have pub := order_edges_strict_viz_point' vt vb abs put.
+by move: pab; rewrite under_onVstrict // pub orbT.
+Qed.
+
+Lemma edges_inside_from_events_inside (bottom top : edge) evs:
+    all (inside_box bottom top) ([seq point e | e <- evs] : seq pt) ->
+    {in evs, forall ev, out_left_event ev} ->
+    close_edges_from_events evs ->
+   {in events_to_edges evs,
+         forall g : edge,
+         inside_box bottom top (left_pt g) &&
+         inside_box bottom top (right_pt g)}.
+Proof.
+elim: evs => [ | e evs Ih] /=; first by [].
+move=> /andP[] inbox_e inbox_es out_es0.
+have out_e : out_left_event e by apply: out_es0; rewrite mem_head.
+have out_es : {in evs, forall e, out_left_event e}.
+   by move=> e' e'in; apply: out_es0; rewrite inE e'in orbT.
+move=> /andP[] close_e close_es.
+move=> g; rewrite events_to_edges_cons mem_cat=> /orP[] gin; last first.
+  by apply: (Ih   inbox_es out_es close_es).
+apply/andP; split; first by rewrite (eqP (out_e g gin)).
+move: close_e=> /allP /(_ g gin).
+move/hasP=> [e2 e2in /eqP ->].
+by apply: (@allP pt _ _ inbox_es); rewrite map_f.
+Qed.
+
+Notation event' := (generic_trajectories.event R edge).
+Lemma start_yields_safe_cells evs bottom top (open closed : seq cell):
+  sorted (fun e1 e2 => p_x (point e1) < p_x (point e2)) evs ->
+  {in [:: bottom, top &
+         events_to_edges evs] &, forall e1 e2, inter_at_ext e1 e2} ->
+  all (inside_box bottom top) [seq point e | e <- evs] ->
+  {in evs, forall ev : event, out_left_event ev} ->
+  close_edges_from_events evs ->
+  {in events_to_edges evs & evs, forall g e, non_inner g (point e)} ->
+  {in evs, forall e, uniq (outgoing e)} ->
+  main_process bottom top evs = (open, closed) ->
+  {in closed & events_to_edges evs, forall c g p,
+    strict_inside_closed p c -> ~~(p === g)}.
+Proof.
+set event' := generic_trajectories.event _ _.
+set p_x' := generic_trajectories.p_x R.
+set point' := generic_trajectories.point R edge.
+have [ev0 | evsn0] := eqVneq evs [::].
+  rewrite /start /=; rewrite ev0 /=.
+  by move=> _ _ _ _ _ _ _ [] _ <-.
+move=> general_position no_crossing.
+move=> all_points_in out_edges_correct.
+move=> edges_closed no_event_in_edge outgoing_event_unique start_eq.
+have [e0 e0in] : exists e, e \in evs.
+  by case: (evs) evsn0 => [ | a ?] //; exists a; rewrite mem_head.
+have inbox_e : inside_box bottom top (point e0).
+  by apply: (@allP pt _ _ all_points_in); rewrite map_f.
+have noc0 : {in [:: bottom; top] &, forall g1 g2, inter_at_ext g1 g2}.
+  move=> g1 g2 g1in g2in.
+  by apply: no_crossing; rewrite -[_ :: _]/([:: _; _] ++ _) mem_cat ?g1in ?g2in.
+have startok : open_cell_side_limit_ok (start_open_cell bottom top).
+   by have := start_open_cell_ok noc0 inbox_e.
+have bottom_below_top : bottom <| top.
+  by have := has_inside_box_bottom_below_top noc0 inbox_e.
+have sorted_lex : sorted (@lexPtEv _) evs.
+  move: general_position; apply: sub_sorted.
+  by move=> e1 e2; rewrite /lexPtEv/lexPt=> ->.
+have all_edges_in :   {in events_to_edges evs, forall g,
+         inside_box bottom top (left_pt g) &&
+         inside_box bottom top (right_pt g)}.
+  by apply: edges_inside_from_events_inside.
+have [closed_has_disjoint_cells no_intersection_closed_open]:=
+   complete_disjoint_general_position general_position bottom_below_top
+   startok no_crossing all_edges_in all_points_in sorted_lex (@subset_id _ _)
+   out_edges_correct edges_closed start_eq.
+have [all_edges_covered all_points_covered]:=
+   start_edge_covered_general_position general_position bottom_below_top
+   startok no_crossing all_edges_in all_points_in sorted_lex (@subset_id _ _)
+   out_edges_correct edges_closed no_event_in_edge outgoing_event_unique
+   start_eq.
+have [closed_main_properties [subcl [all_closed_ok last_open_props]]] :=
+   start_safe_sides general_position bottom_below_top startok no_crossing
+   all_edges_in all_points_in sorted_lex (@subset_id _ _) out_edges_correct
+   edges_closed no_event_in_edge outgoing_event_unique start_eq.
+move=> c g cin gin p pin.
+set ref_points := [seq point e | e <- evs].
+(* TODO : decide on moving this to a separate lemma. *)
+have sub_ref : {subset [seq left_pt g | g <- events_to_edges evs] ++
+                  [seq right_pt g | g <- events_to_edges evs] <=
+                  (ref_points : seq pt)}.
+  rewrite /ref_points.
+  move: edges_closed out_edges_correct.
+  elim: (evs) => [ | ev evs' Ih] //= => /andP [cl1 /Ih {}Ih].
+  move=> out_evs.
+  have oute : out_left_event ev by apply: out_evs; rewrite mem_head.
+  have {}out_evs : {in evs', forall ev, out_left_event ev}.
+   by move=> e ein; apply: out_evs; rewrite inE ein orbT.
+  have {}Ih := Ih out_evs.
+  rewrite events_to_edges_cons.
+  move=> q; rewrite mem_cat=> /orP[] /mapP[e + ->].
+    rewrite mem_cat => /orP[/oute/eqP -> | ein ]; first by rewrite mem_head.
+    rewrite inE; apply/orP; right; apply: Ih.
+    by rewrite mem_cat map_f.
+  rewrite mem_cat=> /orP[/(allP cl1)/hasP[e' e'in /eqP ->] | e'in].
+    by rewrite inE map_f ?orbT.
+  rewrite inE; apply/orP; right; apply: Ih.
+  by rewrite mem_cat map_f ?orbT.
+have covered_closed :
+  {in events_to_edges evs, forall g, edge_covered g [::] closed}.
+  move: last_open_props=> [slo [lloq [hloq [ocdis last_open_props]]]].
+  case oeq : open slo => [ | lsto [ | ? ?]] // _.
+  move=> g' g'in.
+  (* TODO : make a separate lemma. *)
+  have g'ntop : g' != top.
+    apply/negP=> /eqP abs.
+    have := all_edges_in _ g'in => /andP[] /andP[] _ /andP[] _.
+    by rewrite abs lt_irreflexive.
+  have := all_edges_covered _ g'in; rewrite oeq.
+  move=> [ | closed_covered]; last by right; exact: closed_covered.
+  move=> [opc [pcc [_ [highs [ _ [ opcin _]]]]]].
+  move: g'ntop.
+  rewrite -(highs opc); last by rewrite mem_rcons mem_head.
+  move: opcin; rewrite inE=> /eqP ->.
+  by rewrite -hloq oeq /= eqxx.
+have non_empty_closed :
+ {in closed, forall c, left_limit c < right_limit c}.
+ by move=> c' c'in; have [_ [_ []]]:= closed_main_properties _ c'in.
+have rf_cl : {in closed, forall c, low c <| high c}.
+  by move=> c' c'in; have [it _] := closed_main_properties _ c'in.
+have dif_lh_cl : {in closed, forall c, low c != high c}.
+  by move=> c' c'in; have [_ [it _]] := closed_main_properties _ c'in.
+have points_covered' : {in [seq left_pt g0 | g0 <- events_to_edges evs] ++
+       [seq right_pt g0 | g0 <- events_to_edges evs],
+     forall p0 : pt,
+     exists2 c0 : cell,
+       c0 \in closed & p0 \in (right_pts c0 : seq pt) /\ p0 >>> low c0}.
+  by move=> q /sub_ref/mapP[e ein ->]; apply: all_points_covered.
+have puh : p <<< high c.
+  by move: pin; rewrite /strict_inside_closed => /andP[] /andP[].
+have pal : p >>> low c.
+  by move: pin; rewrite /strict_inside_closed => /andP[] /andP[].
+have p_between : left_limit c < p_x p < right_limit c.
+  by move: pin; rewrite /strict_inside_closed=> /andP[].
+by have := safe_cell_interior subcl (@subset_id _ _) closed_has_disjoint_cells
+  covered_closed points_covered' non_empty_closed (allP all_closed_ok)
+  no_crossing rf_cl dif_lh_cl cin puh pal p_between gin.
+Qed.
+
+End main_statement.
diff --git a/theories/shortest_path.v b/theories/shortest_path.v
new file mode 100644
index 0000000..3f3f537
--- /dev/null
+++ b/theories/shortest_path.v
@@ -0,0 +1,148 @@
+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.
+
+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 update_update q n1 n2 n3 p d p' d' :
+    find (update (update q n1 p d) n2 p' d') n3 =
+    find (update (update q n2 p' d') n1 p d) n3.
+Proof.
+have [n1n3 | n1nn3] := eqVneq n1 n3.
+  rewrite -n1n3.
+  have [n1n2 | n1nn2] := eqVneq n1 n2.
+    rewrite -n1n2.
+    case n1inq : (find q n1) => [ [p1  d1] | ].
+      case cmp1 : (cmp_option _ <%R d d1).
+        case cmp2 :(cmp_option _ <%R d' d).
+          have int1 : find (update q n1 p d) n1 = Some(p, d).
+            by apply: find_update_eq n1inq cmp1.
+          rewrite (find_update_eq _ _ _ _ _ _ int1 cmp2).
+          have [cmp3 | cmp3]:= boolP(cmp_option _ <%R d' d1).
+            have int2 : find (update q n1 p' d') n1 = Some(p', d').
+              by apply: find_update_eq n1inq cmp3.
+            rewrite (update_discard _ _ _ _ _ _ int2); last by apply: oltNgt.
+          by rewrite int2.
+        have int3 : find (update q n1 p' d') n1 = Some (p1, d1).
+          by rewrite (update_discard _ _ _ _ _ _ n1inq).
+        have : ~~ cmp_option _ <%R d d1.
+Admitted.
+
+End shortest_path_proofs.
diff --git a/theories/smooth_trajectories.v b/theories/smooth_trajectories.v
index be6af09..50df61f 100644
--- a/theories/smooth_trajectories.v
+++ b/theories/smooth_trajectories.v
@@ -1,6 +1,7 @@
 From mathcomp Require Import all_ssreflect.
 Require Import ZArith QArith List String OrderedType OrderedTypeEx FMapAVL.
 Require Import generic_trajectories.
+Require Import Qabs.
 
 Definition Qlt_bool x y := andb (negb (Qeq_bool x y)) (Qle_bool x y).
 
@@ -27,9 +28,33 @@ Definition scan :=
   complete_process Q Qeq_bool Qle_bool 
     Qplus Qminus Qmult Qdiv 0 edge Bedge left_pt right_pt.
 
+Definition manhattan_distance (p1x p1y p2x p2y : R) :=
+  Qabs (p2x - p1x) + Qabs (p2y - p1y).
+
+Definition approx_sqrt (x : Q) :=
+  let n := Qnum x in
+  let d := Qden x in
+  let safe_n := (1024 * n)%Z in
+  let safe_d := (1024 * d)%positive in
+  let n' := Z.sqrt safe_n in
+  let d' := Pos.sqrt safe_d in
+  Qred (Qmake n' d').
+
+Definition euclidean_distance  (p1x p1y p2x p2y : R) :=
+  approx_sqrt ((p2x - p1x) ^ 2 + (p2y - p1y) ^ 2).
+
+Definition pt_distance := euclidean_distance.
+
+Definition Qstraight_point_to_point :=
+  point_to_point Q Qeq_bool Qle_bool Qplus Qminus Qmult Qdiv
+   pt_distance 1 edge Bedge left_pt right_pt.
+
+Definition Qoptim_three := optim_three Q Qeq_bool Qle_bool Qplus Qminus
+  Qmult Qdiv 1.
+
 Definition Qsmooth_point_to_point :=
  smooth_point_to_point Q Qeq_bool Qle_bool Qplus Qminus Qmult Qdiv
-   1 edge Bedge left_pt right_pt.
+   pt_distance 1 edge Bedge left_pt right_pt.
 
 Definition Qedges_to_cells :=
    edges_to_cells Q Qeq_bool Qle_bool Qplus Qminus Qmult Qdiv 1
@@ -190,7 +215,7 @@ Definition display_smooth_trajectory (tr_x tr_y scale : Q)
 "stroke"%string :: nil).
 
 Definition Qsmooth_from_cells :=
-  smooth_from_cells Q Qeq_bool Qle_bool Qplus Qminus Qmult Qdiv 1 edge
+  smooth_from_cells Q Qeq_bool Qle_bool Qplus Qminus Qmult Qdiv pt_distance 1 edge
   Bedge left_pt right_pt.
 
 Definition display_full_example tr_x tr_y scale
@@ -295,6 +320,7 @@ Definition leftmost_points :=
    that have a vertical left edge have a neighbor on their left
    that has the same vertical edge on the right. *)
 
+(*
 Lemma all_cells_have_left_neighbor :
   forallb (fun edge_list =>
   let cells := Qedges_to_cells example_bottom example_top edge_list in
@@ -305,7 +331,8 @@ Lemma all_cells_have_left_neighbor :
             (existsb (fun c' => lr_connected Q Qeq_bool 1 edge c' c) cells))) cells)
         example_edge_sets = true.
 Proof. easy. Qed.
-
+*)
+(*
 Definition reference_line edge_list p1 p2 :=
    ("[4 4] 0 setdash 3 setlinewidth"%string ::
    (List.map (fun sg => display_segment 300 400 70 (apt_val (fst sg), apt_val (snd sg)))
@@ -315,7 +342,8 @@ Definition reference_line edge_list p1 p2 :=
    Some l => l
    | None => nil
    end ++ "stroke %debug"%string :: nil)).
-
+*)
+(*
 Definition example_test edge_list (p1 p2 : pt) (extra : seq string) :=
   display_full_example 300 400 70 example_bottom example_top
     edge_list p1 p2 extra.
@@ -329,7 +357,7 @@ Definition example_by_index edge_list_index point_pair_index (with_dotted_line :
      reference_line edge_list (fst pp) (snd pp)
    else
      nil).
-
+*)
 (* To display a more elaborate example that shows in a curved dash line
   the result of smoothening the trajectory without repaing, you can
   execute the following text.
@@ -408,3 +436,12 @@ Compute edges_to_events example_edge_list.
 *)
 
 (* Compute example_by_index 0 0 false. *)
+
+(* Definition approx_sqrt  *)
+
+(*
+Definition euclidean_distance (p1 p2 : pt) :=
+   (p_x p2 - p_x p1) ^ 2 + (p_y p2 - p_y p1) ^ 2.
+
+*)
+
diff --git a/theories/three_circles.v b/theories/three_circles.v
index b0dacba..e782a95 100644
--- a/theories/three_circles.v
+++ b/theories/three_circles.v
@@ -1,3 +1,4 @@
+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.
@@ -153,9 +154,11 @@ Proof.
 split. move=> x y; exact: comp_polyM. by rewrite /scaleX_poly comp_polyC.
 Qed.
 
-Canonical scaleX_poly_additive (c : R) := Additive (scaleX_poly_is_linear c).
-Canonical scaleX_poly_linear c := Linear (scaleX_poly_is_linear c).
-Canonical scaleX_poly_rmorphism c := AddRMorphism (scaleX_poly_multiplicative c).
+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.
@@ -302,7 +305,7 @@ Proof.
 move=> Hp.
 have H0noroot : ~~(root (p %/ 'X^(\mu_0 p)) 0).
   rewrite -mu_gt0.
-    rewrite -eqn0Ngt -(addr0 'X) -(@oppr0 (poly_zmodType R)) -polyC0 mu_div
+    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 //.
@@ -583,9 +586,7 @@ rewrite -exprMn -(ler_sqrt (b^+2)).
     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))).
-rewrite exprMn mulr_gt0 // lt_def sqr_ge0.
-  by rewrite sqrf_eq0 sqrtr_eq0 -ltNge ltr0n.
-by rewrite sqrf_eq0 Ha.
+by rewrite exprMn mulr_ge0 // ?sqr_ge0//.
 Qed.
 
 Lemma Re_invc (z : C) : Re z^-1 = Re z / ((Re z) ^+ 2 + (Im z) ^+2).
diff --git a/html/Makefile b/www/Makefile
similarity index 100%
rename from html/Makefile
rename to www/Makefile
diff --git a/www/Makefile.coq.local b/www/Makefile.coq.local
new file mode 100644
index 0000000..3465d69
--- /dev/null
+++ b/www/Makefile.coq.local
@@ -0,0 +1,40 @@
+post-all::
+	$(MAKE) -f $(SELF) SmoothTrajectories.mli
+
+post-all::
+	$(MAKE) -f $(SELF) SmoothTrajectories.cmi
+
+clean::
+	rm -f SmoothTrajectories.cmi SmoothTrajectories.cmo jSmoothTrajectories.cmi jSmoothTrajectories.cmo
+
+
+SmoothTrajectories.ml SmoothTrajectories.mli : ../theories/smooth_trajectories.vo
+	cd ../theories; echo 'Require Import QArith smooth_trajectories. Extraction "SmoothTrajectories.ml" Qsmooth_point_to_point Qstraight_point_to_point Qedges_to_cells Qreduction.Qred.' | coqtop -R . trajectories
+	cp ../theories/SmoothTrajectories.ml ../theories/SmoothTrajectories.mli .
+
+SmoothTrajectories.cmi : SmoothTrajectories.mli
+	ocamlfind ocamlc SmoothTrajectories.mli
+
+post-all::
+	$(MAKE) -f $(SELF) jSmoothTrajectories.cmi
+clean::
+	rm -f jSmoothTrajectories.cmi
+
+jSmoothTrajectories.cmi :  jSmoothTrajectories.ml
+	ocamlfind ocamlc jSmoothTrajectories.mli
+
+post-all::
+	$(MAKE) -f $(SELF) SmoothTrajectories.bytes
+clean::
+	rm -f SmoothTrajectories.bytes
+
+SmoothTrajectories.bytes :  jSmoothTrajectories.cmi jSmoothTrajectories.ml SmoothTrajectories.ml SmoothTrajectories.cmi
+	ocamlfind ocamlc -package js_of_ocaml -package js_of_ocaml-ppx -linkpkg -o SmoothTrajectories.bytes SmoothTrajectories.ml jSmoothTrajectories.ml
+
+post-all::
+	$(MAKE) -f $(SELF) SmoothTrajectories.js
+clean::
+	rm -f SmoothTrajectories.js
+
+SmoothTrajectories.js :  SmoothTrajectories.bytes
+	js_of_ocaml --opt=3 SmoothTrajectories.bytes
diff --git a/www/add.v b/www/add.v
new file mode 100644
index 0000000..8b13789
--- /dev/null
+++ b/www/add.v
@@ -0,0 +1 @@
+
diff --git a/html/grid.html b/www/grid.html
similarity index 89%
rename from html/grid.html
rename to www/grid.html
index 118df43..d2d69b3 100755
--- a/html/grid.html
+++ b/www/grid.html
@@ -28,6 +28,13 @@
 <label for="Position">Starting and ending positions</label> 
 <input type="checkbox" id="cell" name="Show Cells">
 <label> Show Cells </label>
+<input type="checkbox" id="straight" name="Show Straight">
+<label> Show Straight </label>
+<p>
+<button id="loadButton">Load</button>
+<button id="saveButton">Save</button>
+</p>
+
 <p>
   To add an obstacle, click to a first end-point (blue square)
   then click to the second end-point
diff --git a/html/grid.js b/www/grid.js
similarity index 65%
rename from html/grid.js
rename to www/grid.js
index 7281805..0762b6d 100644
--- a/html/grid.js
+++ b/www/grid.js
@@ -256,6 +256,10 @@ function cleanCurve () {
 }
 
 function getCurve() {
+  console.log("getCurve\n");
+  if ((fromValid == false) || (toValid == false)) {
+    return;
+  }
   let val = "";
   val += outVal(positions.fX) + outVal(positions.fZ) + 
          outVal(positions.tX) + outVal(positions.tZ);
@@ -332,6 +336,105 @@ function getCurve() {
   }
 }
 
+/* The straight */
+
+var straightFlag = true;
+
+const straightButtons = 
+  document.querySelectorAll('input[name="Show Straight"]');
+
+for (const straightButton of straightButtons) {
+    straightButton.addEventListener("click", setStraight, false);
+}
+
+function setStraight() {
+    straightFlag = straightButtons[0].checked;
+    cleanStraight();
+    cleanCurve();
+    if (straightFlag) {
+      getStraight();
+    } else {
+      getCurve();
+    }
+    renderer.render( scene, camera );
+}
+
+
+var straights = [];
+const smaterial = new THREE.LineBasicMaterial( { color: 'blue' } );
+setStraight();
+
+
+function cleanStraight () {
+    let i = 0; 
+    console.log("straights " + straights);
+    while (i < straights.length)
+    for (const straight of straights) {
+        scene.remove(straight);
+        i++;
+    }
+    renderer.render( scene, camera ); 
+    straights = [];
+}
+
+function getStraight() {
+  console.log("getStraight\n");
+  if ((fromValid == false) || (toValid == false)) {
+    return;
+  }
+  let val = "";
+  val += outVal(positions.fX) + outVal(positions.fZ) + 
+         outVal(positions.tX) + outVal(positions.tZ);
+  if (borders.length != 2) {
+    return;
+  }
+  if (borders[0].fZ <= borders[1].fZ) {
+    val += outVal(borders[0].fX) + outVal(borders[0].fZ) + 
+           outVal(borders[0].tX) + outVal(borders[0].tZ);  
+    val += outVal(borders[1].fX) + outVal(borders[1].fZ) + 
+           outVal(borders[1].tX) + outVal(borders[1].tZ);  
+  } else {
+    val += outVal(borders[1].fX) + outVal(borders[1].fZ) + 
+           outVal(borders[1].tX) + outVal(borders[1].tZ);  
+    val += outVal(borders[0].fX) + outVal(borders[0].fZ) + 
+           outVal(borders[0].tX) + outVal(borders[0].tZ);  
+  }
+  for (const obstacle of obstacles) {
+    val += outVal(obstacle.fX) + outVal(obstacle.fZ)
+            + outVal(obstacle.tX) + outVal(obstacle.tZ);  
+  } 
+  console.log("boarders " + borders.length + " obstacles " + obstacles.length);
+  console.log("val " + val);
+  let res = ocamlLib.straight(val);
+  console.log("res " + res);
+  let res1 = res.split(' ').map(Number);
+  let i = 0;
+  while (i < res1.length) {
+    if (res1[i] == 1) {
+        /* Straight line */
+        let fx = res1[i + 2] / res1 [i + 3] * gSize - 0.5 - gSize/2;
+        let fy = 0.3;
+        let fz = res1[i + 4] / res1 [i + 5] * gSize - 0.5 - gSize/2;
+        let tx = res1[i + 6] / res1 [i + 7] * gSize - 0.5 - gSize/2;
+        let ty = 0.3;
+        let tz = res1[i + 8] / res1 [i + 9] * gSize - 0.5 - gSize/2;
+        console.log("Adding a line" + fx + " " + fz + " " + tx + " " + tz);
+        let epoints = [];
+        epoints.push( new THREE.Vector3(fx, fy, fz) );
+        epoints.push( new THREE.Vector3(tx, ty, tz));
+        let egeometry = new THREE.BufferGeometry().setFromPoints( epoints );
+        let sline = new THREE.Line( egeometry, smaterial );
+        straights.push(sline);
+        scene.add( sline );
+        renderer.render( scene, camera );
+        i += 10;
+    } else if (res1[i] == 2) {
+        i += 14;
+    } else {
+        i++;
+    }
+  }
+}
 
 /* The modality */
 
@@ -346,6 +449,7 @@ for (const radioButton of radioButtons) {
 
 function setModality() {
     cleanCurve();
+    cleanStraight();
     fromValid = false;  
     toValid = false;         
     fromCube.position.y = -0.2;
@@ -400,6 +504,7 @@ function onDocumentMouseDown( event ) {
         fromCube.position.y = -0.2;
         toCube.position.y = -0.2;
         cleanCurve();
+        cleanStraight();
         renderer.render( scene, camera );  
     }
     if (fromValid) {
@@ -419,6 +524,7 @@ function onDocumentMouseDown( event ) {
                 return;
             }
             cleanCurve();
+            cleanStraight();
             addObstacle(fromX, fromZ, toX, toZ);
         }
         if (modality == "positions") {
@@ -430,7 +536,12 @@ function onDocumentMouseDown( event ) {
             renderer.render( scene, camera );
             positions = {fX : fromX, fZ : fromZ, tX : toX, tZ : toZ }
             cleanCurve();
-            getCurve();
+            cleanStraight();
+            if (straightFlag) {
+                getStraight();
+            } else {
+                getCurve();
+            }
         }
     } else {
         fromValid = true;         
@@ -441,6 +552,102 @@ function onDocumentMouseDown( event ) {
         fromCube.position.x = fromX;
         toCube.position.y = -0.2;
         cleanCurve();
+        cleanStraight();
         renderer.render( scene, camera );
     }
 }
+
+
+document.getElementById('loadButton').addEventListener('click', function() { 
+  let input = document.createElement('input');
+  input.type = 'file';
+  input.accept = 'text/*'
+  input.onchange = _ => {
+    // you can use this method to get file and perform respective operations
+            let files =   Array.from(input.files);
+            if (files.length < 1) {
+                return;
+            }
+            let file = files[0];
+            var reader = new FileReader();
+            reader.onload = function(progressEvent) {
+                fromValid = false;         
+                toValid = false;         
+                fromCube.position.y = -0.2;
+                toCube.position.y = -0.2;
+                for (const obstacle of obstacles) {
+                    scene.remove(obstacle.line);
+                }
+                obstacles = [];
+                renderer.render( scene, camera );
+                // Entire file
+                const text = this.result;
+                // By lines
+                var lines = text.split('\n');
+                var i = 0;
+                if (lines[i].indexOf('Obstacles') != -1) {
+                    i++;
+                    while ((i < lines.length) && (lines[i].length != 0) && 
+                           (lines[i].indexOf("Positions") == -1)) {
+                        var fX = parseFloat(lines[i]);
+                        var fZ = parseFloat(lines[i+1]);
+                        var tX = parseFloat(lines[i+2]);
+                        var tZ = parseFloat(lines[i+3]);
+                        addObstacle(fX, fZ, tX, tZ);
+                        i += 4;
+                    }
+                }
+                if (lines[i].indexOf("Positions") != -1) {
+                    document.getElementById('positions').checked = true;
+                    setModality();
+                    var fX = parseFloat(lines[i+1]);
+                    var fZ = parseFloat(lines[i+2]);
+                    var tX = parseFloat(lines[i+3]);
+                    var tZ = parseFloat(lines[i+4]);
+                    i += 5;
+                    fromValid = true;         
+                    toValid = true;         
+                    fromCube.position.z = fZ;
+                    fromCube.position.y = fromY;
+                    fromCube.position.x = fX;
+                    toCube.position.z = tZ;
+                    toCube.position.y = toY;
+                    toCube.position.x = tX;
+                    renderer.render( scene, camera );
+                    positions = {fX : fX, fZ : fZ, tX : tX, tZ : tZ }
+                    cleanCurve();
+                    cleanStraight();
+                    if (straightFlag) {
+                        getStraight();
+                    } else {
+                        getCurve();
+                    }
+                    renderer.render( scene, camera );
+                }
+            };
+            reader.readAsText(file);
+        };
+   input.click();
+}); 
+
+document.getElementById('saveButton').addEventListener('click', function() { 
+   const link = document.createElement("a");
+   let val = "";
+   if (obstacles.length != 0) {
+        val += "Obstacles\n";
+                for (const obstacle of obstacles) {
+                    val += obstacle.fX + "\n" + obstacle.fZ + "\n" 
+                            + obstacle.tX + "\n"  + obstacle.tZ + "\n";  
+                    } 
+        if (positions != null) {
+                val += "Positions\n";
+                val += positions.fX + "\n" + positions.fZ + "\n";
+                val += positions.tX + "\n" + positions.tZ + "\n";
+        }
+   }
+   const file = new Blob([val], { type: 'text/plain' });
+   link.href = URL.createObjectURL(file);
+   link.download = "sample.txt";
+   link.click();
+   URL.revokeObjectURL(link.href);
+}); 
diff --git a/html/jSmoothTrajectories.ml b/www/jSmoothTrajectories.ml
similarity index 91%
rename from html/jSmoothTrajectories.ml
rename to www/jSmoothTrajectories.ml
index 67f8520..cd552f3 100644
--- a/html/jSmoothTrajectories.ml
+++ b/www/jSmoothTrajectories.ml
@@ -91,7 +91,7 @@ let call_smooth s =
     l2stringr (curve_elements2n v)
 
 
-let call_smooth1 s = 
+let call_straight s = 
   let l = string2ln s in
   match l with
   | p1n1 :: p1d1 :: p1n2 :: p1d2 :: p2n1 :: p2d1 :: p2n2 ::p2d2 ::
@@ -99,11 +99,13 @@ let call_smooth1 s =
     e2n1 :: e2d1 :: e2n2 :: e2d2 :: e2n3 :: e2d3 :: e2n4 :: e2d4 ::
     ls ->
     let es = list2es ls in 
- ((n2edge e1n1 e1d1 e1n2 e1d2 e1n3 e1d3 e1n4 e1d4),
-  (n2edge e2n1 e2d1 e2n2 e2d2 e2n3 e2d3 e2n4 e2d4),
-      es ,
-      (n2pt p1n1 p1d1 p1n2 p1d2),
-      (n2pt p2n1 p2d1 p2n2 p2d2)) 
+    let v = qstraight_point_to_point (n2edge e1n1 e1d1 e1n2 e1d2 e1n3 e1d3 e1n4 e1d4)
+      (n2edge e2n1 e2d1 e2n2 e2d2 e2n3 e2d3 e2n4 e2d4)
+      es 
+      (n2pt p1n1 p1d1 p1n2 p1d2)
+      (n2pt p2n1 p2d1 p2n2 p2d2) in 
+    l2stringr (curve_elements2n v)
+
 
 let rec cells_element2n ce =
   match ce with
@@ -132,6 +134,7 @@ let call_cells s =
 let _ =
   Js.export "ocamlLib"
     (object%js
+      method straight s = Js.string (call_straight (Js.to_string s))
       method smooth s = Js.string (call_smooth (Js.to_string s))
       method cells s = Js.string (call_cells (Js.to_string s))
     end)
diff --git a/html/jSmoothTrajectories.mli b/www/jSmoothTrajectories.mli
similarity index 100%
rename from html/jSmoothTrajectories.mli
rename to www/jSmoothTrajectories.mli