(*=====================================================
=======================================================
JUNE 2016 - AUGUST 2016

AUTHOR : Wassim Haffaf.
=======================================================
=======================================================*)

Require Import Arith.
Require Import EqNat.
Require Import Ring.
Require Import Field.
Require Import QArith.

(* -------------------------------------------------------------------- *)
From mathcomp Require Import div ssreflect eqtype ssrbool ssrnat seq fintype.
From mathcomp Require Import finset zmodp matrix bigop ssralg matrix ssrnum.
From mathcomp Require Import seq ssrfun finfun matrix ssrnum ssrfun.
From mathcomp Require Import bigop ssralg finset fingroup zmodp poly fingraph.
From mathcomp Require Import tuple choice path.
From mathcomp Require Import finmap rat.
(* -------------------------------------------------------------------- *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Open Scope nat_scope.
Section gensym.

Definition E := nat.

Definition pre_newname (e : {fset nat}) : {n : nat | n \notin e}.
Proof.
exists (\max_(i : e) val i + 1).
set u := _ + 1; apply/negP => abs; move/negP: (ltnn u); apply.
move: abs; rewrite /u addn1 => abs; rewrite ltnS.
apply: (leq_bigmax [` abs ]%fset).
Qed.

Definition newname (e : {fset nat}) := val (pre_newname e).

Lemma new_nameP e : newname e \notin e.
Proof. rewrite /newname; apply: (@valP _ [pred n | n \notin e]). Qed.

End gensym.

Section Delaunay.

(* Notations de départ *)

Notation "zero<1" := (ltn0Sn 0).
Notation "zero<2" := (ltn0Sn 1).
Notation "un<2" := (ltnSn 1).
Notation "zero<3" := (ltn0Sn 2).
Notation "un<3" := (ltn_trans (ltnSn 1) (ltnSn 2)).
Notation "deux<3" := (ltnSn 2).
Notation "zero<4" := (ltn0Sn 3).
Notation "un<4" := (ltn_trans (ltn_trans (ltnSn 1) (ltnSn 2)) (ltnSn 3)).
Notation "deux<4" := (ltn_trans (ltnSn 2) (ltnSn 3)).
Notation "trois<4" := (ltnSn 3).
Notation "zero<5" := (ltn0Sn 4).
Notation "un<5" := (ltn_trans (ltn_trans (ltn_trans (ltnSn 1) (ltnSn 2))
                                 (ltnSn 3)) (ltnSn 4)).
Notation "deux<5" := (ltn_trans (ltn_trans (ltnSn 2) (ltnSn 3)) (ltnSn 4)).
Notation "trois<5" := (ltn_trans (ltnSn 3) (ltnSn 4)).
Notation "quatre<5" := (ltnSn 4).

Lemma deux_dif0 : 2 >0.
by [].
Qed.

Lemma trois_dif0 : 3 >0.
by [].
Qed.

Definition addOrd2 : 'I_2 -> 'I_2 -> 'I_2 :=
  fun (p q : 'I_2) => Ordinal(@ltn_pmod (p+q) 2 deux_dif0).

Definition addOrd3 : 'I_3 -> 'I_3 -> 'I_3 :=
  fun (p q : 'I_3) => Ordinal(@ltn_pmod (p+q) 3 trois_dif0).

Definition minOrd2 : 'I_2 -> 'I_2 -> 'I_2 :=
  fun (p q : 'I_2) => Ordinal(@ltn_pmod (p-q) 2 deux_dif0).

Definition minrd3 : 'I_3 -> 'I_3 -> 'I_3 :=
  fun (p q : 'I_3) => Ordinal(@ltn_pmod (p-q) 3 trois_dif0).

Variable R : numDomainType.
Variable P : finType.
Definition point := 'rV[rat]_2.

Definition point2R1 (p: point) : rat :=
  p (Ordinal zero<1) (Ordinal(zero<2)).

Definition point2R2 (p: point) : rat :=
  p (Ordinal zero<1) (Ordinal(un<2)).

(* La fonction norm_carre p1 p2 donne la norme au carré du vecteur allant
   de p1 à p2 *)
Definition norm_carre (p1:point) (p2 :point) : rat :=
  (point2R1 p2 - point2R1 p1)*(point2R1 p2 - point2R1 p1)
    + (point2R2 p2 - point2R2 p1)*(point2R2 p2 - point2R2 p1).

Section prod_scal.
Open Local Scope ring_scope.
Definition prod_scal (p1 : point) (p2 : point) (p3 : point) (p4 : point) :rat :=
  let v1 := \col_(j<2) if j==0 then point2R1 p2 - point2R1 p1
                       else point2R2 p2 - point2R2 p1 in
  let v2 := \col_(j<2) if j==0 then point2R1 p4 - point2R1 p3
                       else point2R2 p4 - point2R2 p3 in
  let M := (v1 (Ordinal(zero<2)) (Ordinal(zero<1)))
              *(v2 (Ordinal(zero<2)) (Ordinal(zero<1)))
                  + (v1 (Ordinal(un<2)) (Ordinal(zero<1)))
                        *(v2 (Ordinal(un<2)) (Ordinal(zero<1))) in
  M.

End prod_scal.

Open Local Scope type_scope.
Definition T := P^3.

(* Tous les triangles sur lesquels nous allons travailler seront
un triplet de points donnés dans le sens trigo *)
Definition triangle :=  'I_3 -> point.

Variable tnull : triangle.
Variable nompnull : P.

Definition trianglemap := {ffun T -> triangle}.
Definition pointmap := {ffun P -> point}.

Definition point2namefun : point -> pointmap -> option P :=
 fun (p1 : point) (pm : pointmap) =>
 let S := [fset i in P | (pm i ==p1)]%fset in
 if #|S| !=0  then [pick i | i \in S]
 else None.

(* s va etre l'ensemble des points dans la triangulation *)
Variable s: {set P}.

(* graph est une fonction qui à un nom de triangle associe la liste des noms
de triangles qui lui sont adjacents *)
Definition graph := T-> seq T.

Definition triangle2points (t: T) (tm : trianglemap) : {ffun 'I_3 -> point}
                  := [ffun Ord : 'I_3 => (tm t) Ord].

(*adjT dit si 2 triangles sont adjacents*)
Definition adjT (t1: T) (t2: T) (tm : trianglemap) : bool :=
  if [exists (i1 : 'I_3| true),
       [exists (i2: 'I_3 | true),
          (triangle2points t1 tm i1 == triangle2points t2 tm i2) &&
     [exists (i3 : 'I_3|true),
       [exists (i4 : 'I_3 | true),
          (triangle2points t1 tm i3 == triangle2points t2 tm i4)
               && (i1!=i3) && (i2!=i4)]]]]
                   then true
  else false.

Open Local Scope ring_scope.

(* Définition de inCircle, RMQ : si un point est sur le cercle circonscrit
   alors il n'est pas inCircle *)
Definition inCircle (p1 : point) (t1: T) (tm : trianglemap) : bool :=
  let M:= \matrix_(i<4, j<4) if i ==0 then if j==0 then
                                     point2R1 (tm t1 (Ordinal (zero<3)))
                                         else if j==1 then
                                     point2R2 (tm t1 (Ordinal (zero<3)))
                                         else if nat_of_ord j==2 then
                         (point2R1 (tm t1 (Ordinal (zero<3))))^+2
                            + (point2R2 (tm t1 (Ordinal (zero<3))))^+2
                                         else 1
                           else if i ==1 then if j==0 then
                                     point2R1 (tm t1 (Ordinal (un<3)))
                                         else if j==1 then
                                     point2R2 (tm t1 (Ordinal (un<3)))
                                         else if nat_of_ord j==2 then
                         (point2R1 (tm t1 (Ordinal (un<3))))^+2
                            + (point2R2 (tm t1 (Ordinal (un<3))))^+2
                                         else 1
                           else if nat_of_ord i ==2 then if j==0 then
                                     point2R1 (tm t1 (Ordinal (deux<3)))
                                         else if j==1 then
                                     point2R2 (tm t1 (Ordinal (deux<3)))
                                         else if nat_of_ord j==2 then
                         (point2R1 (tm t1 (Ordinal (deux<3))))^+2
                            + (point2R2 (tm t1 (Ordinal (deux<3))))^+2
                                         else 1
                           else if j==0 then
                                     point2R1 p1
                                         else if j==1 then
                                     point2R2 p1
                                         else if nat_of_ord j==2 then
                                     (point2R1 p1)^+2 + (point2R2 p1)^+2
                                         else 1
   in (\det M >0).

(* La fonction isDelaunayLocal va prendre 2 triangles et va renvoyer un bool
   qui vaudra true si la construction des 2 triangles est de Delauney *)
Definition isDelaunayLocal (t1: T) (t2: T)  (tm : trianglemap) : bool :=
  (~~(inCircle (triangle2points t1 tm (Ordinal (zero<3))) t2 tm)
      && (~~inCircle (triangle2points t1 tm (Ordinal (un<3))) t2 tm)
      && (~~inCircle (triangle2points t1 tm (Ordinal (deux<3))) t2 tm)).

(* La fonction remove retire d'une sequence de T, un T donné en argument *)
Definition remove (t:T) (l : seq T) : seq T :=
filter [pred x:T | perm_eq (codom x) (codom t)] l.

(* predicat d'egalité entre 2 triangle basé sur perm_eq (doc à trouver dans
  seq) *)
(* same_triangle t1 t2 dit si t1 et t2 sont des noms qui font référence au
   même triangle *)
Definition same_triangle (t1 t2 : T) : bool :=
  perm_eq (codom t1) (codom t2).

(* unhookT t va retirer le triangle t de la tmap et va faire que g t = nil
  et que les triangles qui étaient attachés à t1 perdent cette attache *)
Definition unhookT (t1:T) (tm : trianglemap) (g:graph) :=
let tm' := [ffun i => if i != t1 then tm i else tnull] in

let g' : T -> seq T := fun i : T =>
  if g t1 is t'::t''::t'''::s then
      if (~~(same_triangle i t1)) && (~~(same_triangle i t'))
          && (~~(same_triangle i t'')) && (~~(same_triangle i t''')) then g i
      else if same_triangle i t1 then nil
      else if same_triangle i t' then remove t1 (g t')
      else if same_triangle i t'' then remove t1 (g t'')
      else remove t1 (g t''')
  else if g t1 is t'::t''::nil then
      if (~~(same_triangle i t1)) && (~~(same_triangle i t'))
          && (~~(same_triangle i t''))then g i
      else if same_triangle i t1 then nil
      else if same_triangle i t' then remove t1 (g t')
      else remove t1 (g t'')
  else if g t1 is t'::nil then
      if (~~(same_triangle i t1))
          && (~~(same_triangle i t'))then g i
      else if same_triangle i t1 then nil
      else remove t1 (g t')
  else
      if (~~(same_triangle i t1)) then g i
      else nil

 in (g', tm').

(* attachT va seulement rajouter un triangle t1 dans la tmap *)
(* Le rajout du nouveau triangle dans le graph sera fait au cas par cas dans
   les fonctions le nécessitant *)
Definition attachT (t1: triangle) (tm : trianglemap) (pm : pointmap)  :=
  if  point2namefun (t1 (Ordinal(zero<3))) pm is Some i1 then let i1' := i1 in
      if  point2namefun (t1 (Ordinal(un<3))) pm is Some i2 then
               let i2' := i2 in
          if point2namefun (t1 (Ordinal(deux<3))) pm is Some i3 then
               let i3' := i3 in
                let tm' :=[ffun i :T => if i != [ffun x : 'I_3 =>
                                                     if x==0 then i1'
                                                     else if x==1 then i2'
                                                     else i3']  then tm i
                                        else t1] in Some tm'
          else None
      else None
  else None.

(* Fonctions inTriangle, inHull, add_point_triangle, add_point_out,
   add_edge et add_triangle *)

Definition leftpoint := fun (p a b : point) =>
  let M1 := \matrix_(i<3, j<3) if i==0 then if j==0 then point2R1 p
                                          else if j==1 then point2R2 p
                                          else 1
                             else if i==1 then if j==0 then point2R1 a
                                               else if j==1 then point2R2 a
                                               else 1
                             else if j==0 then point2R1 b
                                               else if j==1 then point2R2 b
                                               else 1

              in \det M1.

(* La fonction inTriangle va dire si un point donné est à l'intérieur d'un
   triangle donné *)
Definition inTriangle (p:point) (t:T) (tm : trianglemap) : bool :=

  let detM1 := leftpoint p (triangle2points t tm (Ordinal(zero<3)))
                              (triangle2points t tm (Ordinal(un<3))) in
  let detM2 := leftpoint p (triangle2points t tm (Ordinal(un<3)))
                              (triangle2points t tm (Ordinal(deux<3))) in
  let detM3 := leftpoint p (triangle2points t tm (Ordinal(deux<3)))
                           (triangle2points t tm (Ordinal(zero<3))) in

    if (detM1*detM2>0) && (detM2*detM3>0)  then true
    else false.

(* La fonction inHull va dire si un point donné est à l'intérieur de
   l'enveloppe convexe dans ce cas elle retourne true ou sinon elle
   retourne false. Elle est construite grâce à inTriangle*)
Definition inHull (p:point) (tmap : trianglemap) : bool :=
  [exists (i: T| true), inTriangle p i tmap].

(* La fonction ofindtriangle va (si c'est le cas) trouver et retourner un
   Option T, car soit le point est dans l'enveloppe convexe est alors j'ai
   un Some(i), i étant le nom du triangle et la preuve qu'il est dans tmap,
   soit j'ai un None car il est hors enveloppe convexe. *)
(* Cette fonction peut être utilisée pour dire si un point est dans
   l'enveloppe convexe alors elle retourne Some u et si il n'y est pas alors
   elle retourne None *)
Definition ofindtriangle (p:point) (tm : trianglemap)  : option (T) :=
  [pick i: T| inTriangle p i tm].

(* La fonction findtriangle va prendre un argument de plus que ofindtriangle
   une preuve inHull p ptm, que le point est dans l'enveloppe convexe et va
   savoir retourner un domf tm. *)
Definition findtriangle (p:point) (tm : trianglemap) (h : inHull p tm) : T.
Proof.
case h':(@ofindtriangle p tm) => [ v | ].
  exact: v.
move:h'; rewrite /ofindtriangle.
case: pickP =>//.
move => abs _.
Search in_mem in ssrbool fintype.
elimtype False.
move: h.
rewrite /inHull.
move/existsP=> []x /= xP.
have := (abs x).
by rewrite xP.
Defined.

(* Fonction qui va supprimer le triangle extérieur et qui va rajouter les 3
   triangles intérieurs *)
Definition add_point_triangle  (p:point) (t:T) (tm : trianglemap) (g:graph)
                                  (pm :pointmap) :=
let (g1,tm1):= unhookT t tm g in
  let triangle1 := fun x:'I_3 => if x==0 then tm t (Ordinal(zero<3))
                               else if x==1 then tm t (Ordinal(un<3))
                               else p in
          if attachT triangle1 tm1 pm is Some tm2' then let tm2 := tm2' in

  let triangle2 := fun x:'I_3 => if x==0 then tm t (Ordinal(un<3))
                               else if x==1 then tm t (Ordinal(deux<3))
                               else p in
           if attachT triangle2 tm2 pm is Some tm3' then let tm3 := tm3' in

  let triangle3 := fun x:'I_3 => if x==0 then tm t (Ordinal(deux<3))
                               else if x==1 then tm t (Ordinal(zero<3))
                               else p in
            if attachT triangle3 tm3 pm is Some tm4' then let tm4 := tm4' in

(* nomtri1 est le nom de triangle1 *)
if point2namefun p pm is Some (p') then
let nomtri1 := [ffun x:'I_3 => if x==0 then t (Ordinal(zero<3))
                               else if x==1 then t (Ordinal(un<3))
                               else p'] in

(* nomtri1 est le nom de triangle2 *)
let nomtri2 := [ffun x:'I_3 => if x==0 then t (Ordinal(un<3))
                               else if x==1 then t (Ordinal(deux<3))
                               else p'] in

(* nomtri1 est le nom de triangle3 *)
let nomtri3 := [ffun x:'I_3 => if x==0 then t (Ordinal(deux<3))
                               else if x==1 then t (Ordinal(zero<3))
                               else p'] in

  (* mettre à jour le graph g1 *)
let t1 := [pick x | x \in [fset x | x in (g1 t) & [exists (i:'I_3|true),
                 (tm4 x (addOrd3 i (Ordinal(un<3))) ==tm4 t (Ordinal(zero<3)))
                      && (tm4 x i==tm4 t (Ordinal(un<3)))]]%fset] in
let t2 := [pick x | x \in [fset x | x in (g1 t) & [exists (i:'I_3|true),
                 (tm4 x (addOrd3 i (Ordinal(un<3))) ==tm4 t (Ordinal(un<3)))
                      && (tm4 x i==tm4 t (Ordinal(deux<3)))]]%fset] in
let t3 := [pick x | x \in [fset x | x in (g1 t) & [exists (i:'I_3|true),
                 (tm4 x (addOrd3 i (Ordinal(un<3))) ==tm4 t (Ordinal(deux<3)))
                      && (tm4 x i==tm4 t (Ordinal(zero<3)))]]%fset] in

let g' : T -> seq T := fun i :T =>
        if t1 is Some (t1') then
             if same_triangle i t1' then (g1 t1') ++ [::nomtri1]
             else g1 i
        else if t2 is Some (t2') then
             if same_triangle i t2' then (g1 t2') ++ [::nomtri2]
             else g1 i
        else if t3 is Some (t3') then
             if same_triangle i t3' then (g1 t3') ++ [::nomtri3]
             else g1 i
        else if same_triangle i nomtri1 then
             if t1 is Some (t1') then [::t1']++[::nomtri2]++[::nomtri3]
             else [::nomtri2]++[::nomtri3]
        else if same_triangle i nomtri2 then
             if t2 is Some (t2') then [::t2']++[::nomtri1]++[::nomtri3]
             else [::nomtri1]++[::nomtri3]
        else if same_triangle i nomtri3 then
             if t3 is Some (t3') then [::t3']++[::nomtri1]++[::nomtri2]
             else [::nomtri1]++[::nomtri2]
        else g1 i

    in Some (g', tm4)

else None
else None
else None
else None.
(* add_point_triangle renvoie une option d'un nouveau graph et d'une nouvelle
   trianglemap *)

(*
Section add_point_out.
Let detfun := fun (nomp1 : P) (nomp2:P) (p:point) (pm : pointmap) =>
    let M1 := \col_(j < 3) if j==0 then point2R1 (pm nomp1)
                           else if j==1 then point2R1 (pm nomp2)
                           else point2R1 p in
    let M2 := \col_(j < 3) if j==0 then point2R2 (pm nomp1)
                           else if j==1 then point2R2 (pm nomp2)
                           else point2R2 p in
    let M3 := \col_(j < 3) 1 in
    let M := row_mx (row_mx M1 M2) M3 in
    \det M.
(* hullmap1 est la finfun donnant pour un nom de point, le nom du point
   prédecesseur et du successeur dans l'enveloppe convexe *)
Variable hullmap1 : {ffun P -> P*P}.
(* La fonction add_point_out va rajouter les triangles qu'il faut *)
(* Cette fonction (comme add_point_triangle) sera appliquée dans add_point
   qui déterminera à laquelle de ces deux fonctions il faut faire appel *)
Definition add_point_out  (p:point) (tm: trianglemap) (g:graph)
                              (pm : pointmap) :=
  let hullmap2 := [ffun nomp : P => if (inHull (pm nomp) tm)==false
                                        then (hullmap1 nomp)
                                    else (nompnull,nompnull)] in
  let hull := [fset nomp|nomp in P & hullmap2 nomp!=(nompnull,nompnull)]%fset
       in
  (* badHull est l'ensemble des noms de points sur l'enveloppe convexe tel
     que ce point et son successeur forment une arête à enlever *)
  let badHull:= [fset nomp|nomp in hull
                            & detfun nomp (snd(hullmap2 nomp)) p pm < 0]%fset
     in
  (* mise à jour de la tmap *)
  let
  (* mise à jour du graph *)

(* add_point_out va renvoyer une option d'un nouveau graph et d'une nouvelle
   trianglemap  *)
End add_point_out.
*)

(* Fonction add_point globale, qui va faire appel selon les cas à
   add_point_triangle ou add_point_out *)
(* Definition add_point (p:point) (tm:trianglemap) (g:graph) (pm : pointmap)
                            :=
  if (inHull p tm) then
                    let bool1 := inHull p tm in
                    let preuve := is_true(bool1) in
                    let t1 :=@findtriangle p tm preuve in
                      if add_point_triangle p t1 tm g pm is
                            Some (g'', tm'') then
                      let g':= g'' in
                      let tm' := tm'' in (g',tm')
                      else (g, tm)
  else if add_point_out p tm g is Some (g'', tm'') then
        let g':= g'' in let tm' := tm'' in (g', tm')
  else (g,tm). *)

Definition change_ord (T : choiceType)(ss : {fset T}) (h : #|{:ss}| == 2)
                    (x : 'I_2) : 'I_(#|{:ss}|).
rewrite (eqP h); exact x.
Defined.

Section findIllegal.

Variables (tm : trianglemap) (g:graph).

Let triangleSet := [fset t:P^3 | true]%fset.

Definition f := fun x : {:triangleSet} =>
  if g (val x) is t1 :: _ then

let p0t1:= tm t1 (Ordinal(zero<3)) in
let p1t1:= tm t1 (Ordinal(un<3)) in
let p2t1:= tm t1 (Ordinal(deux<3)) in
let p0t2:= tm (val x) (Ordinal(zero<3)) in
let p1t2:= tm (val x) (Ordinal(un<3)) in
let p2t2:= tm (val x) (Ordinal(deux<3)) in

      if isDelaunayLocal (val x) t1 tm==true then None
      else if ~~((p0t1 == p0t2) ||(p0t1 == p1t2) ||(p0t1 == p2t2)) &&
        ~~((p0t2 == p0t1) ||(p0t2 == p1t1) ||(p0t2 == p2t1))
        then let ptext1 := p0t1 in let ptext2 := p0t2 in
            Some(ptext1, ptext2, val x, t1)
      else if ~~((p0t1 == p0t2) ||(p0t1 == p1t2) ||(p0t1 == p2t2)) &&
        ~~((p1t2 == p0t1) ||(p1t2 == p1t1) ||(p1t2 == p2t1))
        then let ptext1 := p0t1 in let ptext2 := p1t2 in
            Some(ptext1, ptext2, val x, t1)
      else if ~~((p0t1 == p0t2) ||(p0t1 == p1t2) ||(p0t1 == p2t2)) &&
        ~~((p2t2 == p0t1) ||(p2t2 == p1t1) ||(p2t2 == p2t1))
        then let ptext1 := p0t1 in let ptext2 := p2t2 in
            Some(ptext1, ptext2, val x, t1)

      else if ~~((p1t1 == p0t2) ||(p1t1 == p1t2) ||(p1t1 == p2t2)) &&
        ~~((p0t2 == p0t1) ||(p0t2 == p1t1) ||(p0t2 == p2t1))
        then let ptext1 := p1t1 in let ptext2 := p0t2 in
            Some(ptext1, ptext2, val x, t1)
      else if ~~((p1t1 == p0t2) ||(p1t1 == p1t2) ||(p1t1 == p2t2)) &&
        ~~((p1t2 == p0t1) ||(p1t2 == p1t1) ||(p1t2 == p2t1))
        then let ptext1 := p1t1 in let ptext2 := p1t2 in
            Some(ptext1, ptext2, val x, t1)
      else if ~~((p1t1 == p0t2) ||(p1t1 == p1t2) ||(p1t1 == p2t2)) &&
        ~~((p2t2 == p0t1) ||(p2t2 == p1t1) ||(p2t2 == p2t1))
        then let ptext1 := p1t1 in let ptext2 := p2t2 in
            Some(ptext1, ptext2, val x, t1)

      else if ~~((p2t1 == p0t2) ||(p2t1 == p1t2) ||(p2t1 == p2t2)) &&
        ~~((p0t2 == p0t1) ||(p0t2 == p1t1) ||(p0t2 == p2t1))
        then let ptext1 := p2t1 in let ptext2 := p0t2 in
            Some(ptext1, ptext2, val x, t1)
      else if ~~((p2t1 == p0t2) ||(p2t1 == p1t2) ||(p2t1 == p2t2)) &&
        ~~((p1t2 == p0t1) ||(p1t2 == p1t1) ||(p1t2 == p2t1))
        then let ptext1 := p2t1 in let ptext2 := p1t2 in
            Some(ptext1, ptext2, val x, t1)
      else let ptext1 := p2t1 in let ptext2 := p2t2 in
            Some(ptext1, ptext2, val x, t1)

  else None.

Let res := [fset f x | x in {: triangleSet} & f x != None]%fset.

Definition findIllegal := match pick (pred_of_simpl (@predT {:res})) with
   Some u => val u | None => None end.

(* findIllegal doit renvoyer un Some(ptext1', ptext2', t1', t2') ou un None *)

End findIllegal.

About f.
About findIllegal.

(* point2index va prendre un point, deux T : t1 et 2 et va fournir un 'I_3
   qui est l'index de p dans le triangle dans lequel il se trouve t1 ou t2 *)
(* RMQ : Si ce point n'est pas un des 3 sommets d'un des 2 triangles alors
   la fonction retourne Ordinal(deux<3) *)
Definition point2indext1t2 (p:point) (t1:T) (t2:T) (tm : trianglemap)
                : 'I_3 :=
let p0t1:= tm t1 (Ordinal(zero<3)) in
let p1t1:= tm t1 (Ordinal(un<3)) in
let p2t1:= tm t1 (Ordinal(deux<3)) in
let p0t2:= tm t2 (Ordinal(zero<3)) in
let p1t2:= tm t2 (Ordinal(un<3)) in
let p2t2:= tm t2 (Ordinal(deux<3)) in

if p == p0t1 then let indexptext1 := (Ordinal(zero<3)) in indexptext1
else if p == p1t1 then let indexptext1 := (Ordinal(un<3)) in indexptext1
else if p == p2t1 then let indexptext1 := (Ordinal(deux<3)) in indexptext1
else if p == p0t2 then let indexptext1 := (Ordinal(zero<3)) in indexptext1
else if p == p1t2 then let indexptext1 := (Ordinal(un<3)) in indexptext1
else let indexptext1 := (Ordinal(deux<3)) in indexptext1.

Definition flip (tm: trianglemap)  (ptext1 : point) (ptext2 : point) (t1:T)
                    (t2 :T) (g:graph) (pm: pointmap) :=
let p0t1:= tm t1 (Ordinal(zero<3)) in
let p1t1:= tm t1 (Ordinal(un<3)) in
let p2t1:= tm t1 (Ordinal(deux<3)) in
let p0t2:= tm t2 (Ordinal(zero<3)) in
let p1t2:= tm t2 (Ordinal(un<3)) in
let p2t2:= tm t2 (Ordinal(deux<3)) in

let indexptext1 := point2indext1t2 ptext1 t1 t2 tm in
let indexptext2 := point2indext1t2 ptext2 t1 t2 tm in

let triangle1 := fun x:'I_3 =>
    if x==0 then if (ptext1 == p0t1) || (ptext1 == p1t1) || (ptext1 == p2t1)
                        then tm t1 indexptext1
                 else tm t2 indexptext1
    else if x==1 then if (ptext2 == p0t1) || (ptext2 == p1t1)
                            || (ptext2 == p2t1) then tm t1 indexptext2
                      else tm t2 indexptext2
    else if (ptext1 == p0t1) || (ptext1 == p1t1) || (ptext1 == p2t1)
            then tm t1 (addOrd3 indexptext1 (Ordinal(deux<3)))
    else tm t2 (addOrd3 indexptext1 (Ordinal(deux<3)))

in let triangle2 := fun x:'I_3 =>
   if x==0 then if (ptext2 == p0t2) || (ptext2 == p1t2) || (ptext2 == p2t2)
                     then tm t2 indexptext2
                else tm t1 indexptext2
   else if x==1 then if (ptext1 == p0t2) || (ptext1 == p1t2)
                           || (ptext1 == p2t2) then tm t2 indexptext1
                     else tm t1 indexptext1
   else if (ptext2 == p0t2) || (ptext2 == p1t2) || (ptext2 == p2t2)
            then tm t2 (addOrd3 indexptext2 (Ordinal(deux<3)))
   else tm t1 (addOrd3 indexptext2 (Ordinal(deux<3)))

in
let (g2, tm2) := unhookT t1 tm g in let (g3,tm3):= unhookT t2 tm2 g2 in

if attachT triangle1 tm3 pm is Some tm4' then let tm4 := tm4' in
      if attachT triangle2 tm4 pm is Some tm5' then let tm5 := tm5' in

(* Mise à jour des adjacences dans le graph g3 : *)

(* nomt1 est le nom du triangle passant par ptext1 et edjacent à l'autre
   triangle *)
let nomt1 := if (ptext1 == p0t1) || (ptext1 == p1t1) || (ptext1 == p2t1)
                 then t1
             else t2 in

(* nomt2 est le nom du triangle passant par ptext2 et edjacent à l'autre
   triangle *)
let nomt2 := if (ptext2 == p0t2) || (ptext2 == p1t2) || (ptext2 == p2t2)
                 then t2
             else t1 in

(* nomtri1 est le nom de triangle1 *)
let nomtri1 := [ffun x:'I_3 =>
      if x==0 then nomt1 indexptext1
      else if x==1 then nomt2 indexptext2
      else nomt2 (addOrd3 indexptext2 (Ordinal(un<3)))] in

(* nomtri2 est le nom de triangle2 *)
let nomtri2 := [ffun x:'I_3 =>
      if x==0 then nomt2 indexptext2
      else if x==1 then nomt1 indexptext1
      else nomt1 (addOrd3 indexptext1 (Ordinal(un<3)))]  in

(* p1 est l'un des 2 points adjacents à t1 et t2, c'est celui qui est dans
   triangle1 *)
let p1 := tm3 nomt1 (addOrd3 indexptext1 (Ordinal(deux<3))) in
(* p2 est l'un des 2 points adjacents à t1 et t2, c'est celui qui est dans
   triangle2 *)
let p2 := tm3 nomt2 (addOrd3 indexptext2 (Ordinal(deux<3))) in

  let tbr := [pick x | x \in [fset x | x in (g3 nomt2) &
      [exists (i:'I_3|true), (tm5 x (addOrd3 i (Ordinal(un<3))) ==p2)
            && (tm5 x i==ptext2)]]%fset] in
  let ttr := [pick x | x \in [fset x | x in (g3 nomt2) &
     [exists (i:'I_3|true), (tm5 x (addOrd3 i (Ordinal(un<3))) ==ptext2)
            && (tm5 x i==p1)]]%fset] in
  let ttl := [pick x | x \in [fset x | x in (g3 nomt1) &
     [exists (i:'I_3|true), (tm5 x (addOrd3 i (Ordinal(un<3))) ==ptext1)
            && (tm5 x i==ptext1)]]%fset] in
  let tbl := [pick x | x \in [fset x | x in (g3 nomt1) &
     [exists (i:'I_3|true), (tm5 x (addOrd3 i (Ordinal(un<3))) ==ptext1)
            && (tm5 x i==p2)]]%fset] in

    let g' : T -> seq T := fun i :T =>

      if tbr is Some (tbr') then if same_triangle i tbr'
                                      then (g tbr') ++ [::nomtri2]
                                 else g i
      else if ttr is Some (ttr') then if same_triangle i ttr'
                                        then g(ttr') ++ [::nomtri1]
                                       else g i
      else if ttl is Some (ttl') then if same_triangle i ttl'
                                        then g(ttl') ++ [::nomtri1]
                                       else g i
      else if tbl is Some (tbl') then if same_triangle i tbl'
                                        then g(tbl') ++ [::nomtri2]
                                      else g i
      else if same_triangle i nomtri1 then if ttr is Some (ttr')
                                       then if ttl is Some (ttl')
                                          then [::nomtri2]++[::ttr']++[::ttl']
                                            else [::nomtri2]++[::ttr']
                                           else if ttl is Some (ttl')
                                                  then [::nomtri2]++[::ttl']
                                                else [::nomtri2]
      else if same_triangle i nomtri2 then if tbr is Some (tbr')
                                       then if tbl is Some (tbl')
                                          then [::nomtri1]++[::tbr']++[::tbl']
                                            else [::nomtri1]++[::tbr']
                                           else if tbl is Some (tbl')
                                                  then [::nomtri1]++[::tbl']
                                                else [::nomtri1]
      else g i in

                 Some (g', tm5)

      else None
   else None.
(* La fonction flip ressorte une option d'un coupe d'un graph et d'une tmap *)

(* Dans makeDelaunay faire un test findIllegal et si oui alors faire flip et
   rappeler makeDelaunay *)
(* Fixpoint makeDelaunay (tmap : trianglemap) (g:graph) (pm : pointmap) :=
  if (findIllegal tmap g) is Some (ptext1', ptext2', t1', t2') then if
        (flip tmap ptext1' ptext2' t1' t2' g pm) is Some (g1',tmap1') then
             let g1 := g1' in
             let tmap1 := tmap1' in makeDelaunay tmap1 g1 pm
      else (tmap, g, pm)
  else (tmap, g, pm). *)

End Delaunay.


From Coq Require Import Psatz.
From CDF Require Import Sequences.

(** Un diagramme de simulation générique, pour montrer l'équivalence sémantique
    entre deux programmes à partir de leurs sémantiques "à petits pas". *)

Section SIMULATION_DIAGRAM.

(** Le diagramme est paramétré par
    - les sémantiques "à petits pas" des deux programmes:
      type des configurations et relation de transition entre configurations;
    - un invariant qui relie les configurations des deux programmes.
*)

Variable C1: Type.	                (**r le type des configurations du programme source *)
Variable step1: C1 -> C1 -> Prop.   (**r sa relation de transition *)

Variable C2: Type.	                (**r le type des configurations du programme transformé *)
Variable step2: C2 -> C2 -> Prop.   (**r sa relation de transition *)

Variable inv: C1 -> C2 -> Prop.     (**r l'invariant *)

Variable measure: C1 -> nat.        (**r la mesure qui évite le bégaiement infini *)

(** Le diagramme proprement dit est l'hypothèse suivante:
    chaque transition du programme source est simulée par zéro, une ou plusieurs
    transitions du programme transformé, en préservant l'invariant, et
    en décrémentant la mesure dans le cas du bégaiement. *)

Hypothesis simulation:
  forall c1 c1', step1 c1 c1' ->
  forall c2, inv c1 c2 ->
  exists c2',
     (plus step2 c2 c2' \/ (star step2 c2 c2' /\ measure c1' < measure c1))
  /\ inv c1' c2'.

(** Tout d'abord nous étendons la simulation aux suites finies de transitions
    dans le programme source.  C'est le lemme crucial pour montrer
    la préservation sémantique dans le cas où le programme source termine. *)

Lemma simulation_star:
  forall c1 c1', star step1 c1 c1' ->
  forall c2, inv c1 c2 ->
  exists c2', star step2 c2 c2' /\ inv c1' c2'.
Proof.
  induction 1; intros.
- (* zéro transition *)
  exists c2; split. apply star_refl. auto.
- (* une ou plusieurs transitions *)
  destruct (simulation _ _ H _ H1) as (c2' & P & Q).
  destruct (IHstar _ Q) as (c2'' & U & V).
  exists c2''; split.
  eapply star_trans; eauto. destruct P. apply plus_star; auto. destruct H2; auto.
  auto.
Qed.

(** Raisonnons maintenant sur un programme source qui effectue
    une infinité de transitions.
    D'abord nous montrons que le programme transformé peut toujours avancer
    dans son exécution tout en préservant la relation [inv].
    La démonstration est par récurrence sur le nombre maximal [N] d'étapes
    de bégaiement que le programme transformé peut faire avant d'effectuer
    au moins une transition. *)

Lemma simulation_infseq_productive:
  forall N c1 c2,
  measure c1 < N ->
  infseq step1 c1 ->
  inv c1 c2 ->
  exists c1', exists c2',
      plus step2 c2 c2'
   /\ infseq step1 c1'
   /\ inv c1' c2'.
Proof.
  induction N; intros c1 c2 MEAS INF1 INV.
- (* N = 0 *)
  lia.
- (* N > 0 *)
  destruct (infseq_inv INF1) as (c1' & STEP1 & INF1').
  destruct (simulation _ _ STEP1 _ INV) as (c2' & P & INV').
  destruct P as [STEPS2 | [STEPS2 MEAS']].
  + (* une ou plusieurs transitions *)
    exists c1'; exists c2'; auto.
  + (* zéro, une ou plusieurs transitions *)
    inversion STEPS2; subst; clear STEPS2.
    * (* zéro transitions *)
      eapply IHN; eauto. lia.
    * (* une ou plusieurs transitions *)
      exists c1'; exists c2'; split. eapply plus_left; eauto. auto.
Qed.

(** En conséquence, le programme transformé effectue une infinité de transitions
    si on le démarre dans une configuration qui correspond à une configuration
    divergente du programme source. *)

Lemma simulation_infseq:
  forall c1 c2,
  infseq step1 c1 ->
  inv c1 c2 ->
  infseq step2 c2.
Proof.
  intros.
  apply infseq_coinduction_principle with
    (X := fun c2 => exists c1, infseq step1 c1 /\ inv c1 c2).
- clear c1 c2 H H0. intros c2 (c1 & INF & INV).
  destruct (simulation_infseq_productive (measure c1 + 1) c1 c2)
  as (c1' & c2' & PLUS2 & INF' & INV').
  lia. auto. auto.
  exists c2'; split. auto. exists c1'; auto.
- exists c1; auto.
Qed.

End SIMULATION_DIAGRAM.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Coq - Calculus of Inductive Constructions V5.10           *)
(*****************************************************************************)
(*                                                                           *)
(*          Category Theory : Dual Category                                  *)
(*                                                                           *)
(*          Amokrane Saibi May 1994                                          *)
(*                                                                           *)
(*****************************************************************************)

Require Export Category.

Set Implicit Arguments.
Unset Strict Implicit.

Section d_cat.

Variable C : Category.

Definition DHom (a b : C) := b --> a.

(* construire un Comp_Type *)

Definition Comp_Darrow (a b c : C) (df : DHom a b) (dg : DHom b c) := dg o df.

Lemma Comp_dual_congl : Congl_law Comp_Darrow.
Proof.
unfold Congl_law in |- *; simpl in |- *.
unfold Comp_Darrow in |- *; simpl in |- *.
intros a b c f g h eqf_g.
unfold DHom in |- *; apply Comp_r; apply eqf_g.
Qed.

Lemma Comp_dual_congr : Congr_law Comp_Darrow.
Proof.
unfold Congr_law in |- *; simpl in |- *.
unfold Comp_Darrow in |- *; simpl in |- *.
intros a b c f g h eqf_g.
unfold DHom in |- *; apply Comp_l; apply eqf_g.
Qed.

Definition Comp_Dual := Build_Comp Comp_dual_congl Comp_dual_congr.

Lemma Assoc_Dual : Assoc_law Comp_Dual.
Proof.
unfold Assoc_law, DHom, Cat_comp, Ap2 in |- *; simpl in |- *.
unfold Comp_Darrow in |- *.
intros a b c d df dg dh.
apply Ass1.
Qed.

Lemma Idl_Dual : Idl_law (Hom:=DHom) Comp_Dual (Id (c:=C)).
Proof.
unfold Idl_law, DHom, Cat_comp, Ap2 in |- *; simpl in |- *.
unfold Comp_Darrow in |- *.
intros a b df.
apply Idr1.
Qed.

Lemma Idr_Dual : Idr_law (Hom:=DHom) Comp_Dual (Id (c:=C)).
Proof.
unfold Idr_law, DHom, Cat_comp, Ap2 in |- *; simpl in |- *.
unfold Comp_Darrow in |- *.
intros a b df.
apply Idl1.
Qed.

Canonical Structure Dual := Build_Category Assoc_Dual Idl_Dual Idr_Dual.

End d_cat.


Require Export featuremodel_spl_int.
Require Export featuremodel_spl_def.
Import FeatureModelSPL.

Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.

  Lemma equals: forall fm1 fm2, fm1 = fm2 -> equivalentFMs_func fm1 fm2.
    Proof.
    intros.
    unfold equivalentFMs_func.
    unfold FMRefinement_func.
    rewrite H. split.
    - rewrite equalsSetDiff.
      + trivial.
      + reflexivity.
    - rewrite equalsSetDiff.
      + trivial.
      + reflexivity.
    Qed.


Set Primitive Projections.

Record StreamF (F : Type -> Type) (A : Type) : Type := ConsF
{
  hd : A;
  tl : F A;
}.

Arguments ConsF {F A} _ _.
Arguments hd {F A} _.
Arguments tl {F A} _.

CoInductive Stream (A : Type) : Type := MkStream
{
  out : StreamF Stream A;
}.

Arguments MkStream {A} _.
Arguments out {A} _.

Notation Stream' A := (StreamF Stream A).
Notation Cons h t := (MkStream (ConsF h t)).

Record BisimF
  {A1 A2 : Type} (R : A1 -> A2 -> Prop)
  {F1 F2 : Type -> Type} (Knot : F1 A1 -> F2 A2 -> Prop)
  (s1 : StreamF F1 A1) (s2 : StreamF F2 A2) : Prop :=
{
  BisimF_hd : R (hd s1) (hd s2);
  BisimF_tl : Knot (tl s1) (tl s2);
}.

CoInductive Bisim {A : Type} (s1 s2 : Stream A) : Prop :=
{
  Bisim_out : BisimF eq Bisim (out s1) (out s2);
}.

Fixpoint PartialStream (A : Type) (n : nat) : Type :=
match n with
| 0 => unit
| S n' => StreamF (fun A => PartialStream A n') A
end.

Definition Undefined {A : Type} : PartialStream A 0 := tt.

Definition Defined
  {n : nat} {A : Type} (ps : PartialStream A (S n)) : PartialStream A (S n) := ps.

Lemma eta_PartialStream_S :
  forall {A : Type} (n : nat) (ps : PartialStream A (S n)),
    ps = Defined {| hd := hd ps; tl := tl ps; |}.
Proof. easy. Qed.

Fixpoint shrink
  {n : nat} {A : Type} {struct n} : PartialStream A (S n) -> PartialStream A n :=
match n with
| 0 => fun _ => Undefined
| S n' => fun ps => Defined {| hd := hd ps; tl := shrink (tl ps); |}
end.

Lemma hd_succ :
  forall {A : Type} (f : forall n : nat, PartialStream A n),
    (forall n : nat, shrink (f (S n)) = f n) ->
      forall n : nat, hd (f (S n)) = hd (f 1).
Proof.
  induction n as [| n']; [easy |].
  now rewrite <- IHn', <- (H (S n')).
Qed.

Fixpoint approx {A : Type} (s : Stream A) (n : nat) : PartialStream A n :=
match n with
| 0 => Undefined
| S n' => Defined {| hd := hd (out s); tl := approx (tl (out s)) n'; |}
end.

Lemma shrink_approx :
  forall {A : Type} (s : Stream A) (n : nat),
    shrink (approx s (S n)) = approx s n.
Proof.
  intros A s n; revert s.
  induction n as [| n']; cbn; intros; [easy |].
  now rewrite <- (IHn' (tl (out s))).
Qed.

CoFixpoint unapprox {A : Type} (f : forall n : nat, PartialStream A n) : Stream A :=
  Cons (hd (f 1)) (unapprox (fun n => tl (f (S n)))).

Lemma approx_unapprox :
  forall {A : Type} (s : Stream A),
    Bisim (unapprox (approx s)) s.
Proof.
  cofix CH.
  constructor; cbn.
  destruct (out s) as [h t]; cbn.
  constructor; cbn; [easy |].
  apply CH.
Qed.

Lemma unapprox_approx :
  forall {A : Type} (f : forall n : nat, PartialStream A n),
    (forall n : nat, shrink (f (S n)) = f n) ->
      forall n : nat, approx (unapprox f) n = f n.
Proof.
  intros A f H n; revert f H.
  induction n as [| n']; cbn; intros.
  - now destruct (f 0).
  - rewrite eta_PartialStream_S, IHn', (hd_succ _ H n'); [easy |].
    now intros; rewrite <- (H (S n)).
Qed.


From Coq Require Import
  Classes.Morphisms Lia Lists.List NArith.NArith Bool.Sumbool.
From DEZ.Is Require Export
  Fixed Injective Monotonic Comonotonic Isomorphic.
From DEZ.Justifies Require Export
  OptionTheorems.

(** TODO This may be built into [setoid_rewrite]. *)

Ltac flatten :=
  repeat match goal with
  | h : context [?f (?f ?x)] |- _ => change (f (f x)) with (f x) in h
  | |- context [?f (?f ?x)] => change (f (f x)) with (f x)
  end.

Ltac flatten' :=
  repeat match goal with
  | h : context [?g (?f ?x)] |- _ =>
    unify f g;
    change (g (f x)) with (f x) in h
  | |- context [?g (?f ?x)] =>
    unify f g;
    change (g (f x)) with (f x)
  end.

Import ListNotations N.

#[local] Open Scope N_scope.

(** We use different names to refer to the domain and the codomain,
    even though they are the same. *)

Definition A : Type := N.
Definition B : Type := N.

Ltac forget := unfold A, B in *.

Ltac lia := flatten'; forget; unfold ord_rel in *; Lia.lia.

(** We are interested in monotonic injective functions
    with a fixed point at zero, which we shall consider miffing.
    In order theory, these are called order embeddings
    with a fixed point at the bottom. *)

Class HasMiff : Type := miff (a : A) : B.

#[export] Typeclasses Transparent HasMiff.

(** Miffs are true to their name. *)

Notation IsMonoMiff miff := (Proper (le ==> le) miff).
Notation mono_miff := (proper_prf (R := le ==> le) miff : IsMonoMiff miff).

#[export] Instance has_ord_rel : HasOrdRel N := le.
#[export] Instance has_str_ord_rel : HasStrOrdRel N := lt.

(** TODO This might be a better way to specialize. Investigate. *)

Class IsInjMiff (f : HasMiff) : Prop :=
  is_inj :> IsInj _=_ f.

Notation inj_miff := (inj (f := miff) : IsInjMiff miff).

Notation IsFixedMiff := (IsFixed _=_ 0).
Notation fixed_miff := (@fixed _ _=_ 0 _ _ : _ 0 = 0).

Notation IsStrMonoMiff miff := (Proper (lt ==> lt) miff).
Notation str_mono_miff := (proper_prf (R := lt ==> lt) miff : IsStrMonoMiff miff).

Notation IsStrComonoMiff := (IsInj lt).
Notation str_comono_miff := (inj : IsStrComonoMiff miff).

(** Such a function is said to be inflationary or progressive. *)

Class IsInflateMiff `(HasMiff) : Prop :=
  inflate_miff (a : A) : a <= miff a.

Fail Class IsExpand (A B : Type)
  `(HasDist A) `(HasDist B) (f : A -> B) : Prop :=
  expand (x y : A) : dist x y <= dist (fn x) (fn y).

(** Strict monotonicity implies strict comonotonicity. *)

#[global] Instance is_str_comono_miff `(HasMiff) `(!IsStrMonoMiff miff) :
  IsStrComonoMiff miff.
Proof.
  intros x y lb.
  destruct (lt_trichotomy x y) as [la | [ea | la']].
  - lia.
  - subst y. lia.
  - pose proof str_mono_miff y x ltac:(lia) as lb'. lia.
Qed.

(** Strict monotonicity implies monotonicity. *)

#[global] Instance is_mono_miff `(HasMiff) `(!IsStrMonoMiff miff) :
  IsMonoMiff miff.
Proof.
  intros x y la.
  pose proof str_mono_miff x y as lb.
  destruct (eqb_spec x y) as [ea | fa].
  - pose proof f_equal miff ea as eb. lia.
  - lia.
Qed.

(** Strict monotonicity implies injectivity. *)

#[global] Instance is_inj_miff `(HasMiff) `(!IsStrMonoMiff miff) :
  IsInjMiff miff.
Proof.
  intros x y eb.
  destruct (lt_trichotomy x y) as [la | [ea | la']].
  - pose proof str_mono_miff x y ltac:(lia) as lb. lia.
  - lia.
  - pose proof str_mono_miff y x ltac:(lia) as lb'. lia.
Qed.

(** Monotonicity and injectivity together imply strict monotonicity. *)

(** TODO This might cause a cycle. *)

#[global] Instance is_str_mono_miff `(HasMiff)
  `(!IsMonoMiff miff) `(!IsInjMiff miff) : IsStrMonoMiff miff.
Proof.
  intros x y la.
  destruct (eqb_spec (miff x) (miff y)) as [ea | fa].
  - pose proof inj_miff x y ltac:(lia) as eb. lia.
  - pose proof mono_miff x y ltac:(lia) as lb. lia.
Qed.

(** Strict monotonicity and fixed point at zero together
    imply that the function is expansive. *)

#[global] Instance is_inflate_fixed_miff `(HasMiff)
  `(!IsStrMonoMiff miff) `(!IsFixedMiff miff) : IsInflateMiff miff.
Proof.
  intros a.
  induction a as [| p lp] using peano_ind.
  - rewrite fixed_miff. reflexivity.
  - pose proof str_mono_miff p (succ p) ltac:(lia) as lb. lia.
Qed.

Class IsMiff `(HasMiff) : Prop := {
  miff_is_mono_miff :> IsMonoMiff miff;
  miff_is_inj_miff :> IsInjMiff miff;
  miff_is_fixed_miff :> IsFixedMiff miff;
}.

(** We investigate three ways to pseudoinvert miffs. *)

(** The first way to form the pseudoinverse is
    to extend the domain with a point. *)

Section Context.

Context `(IsMiff).

Class HasUnmiffError : Type := unmiff_error (b : B) : option A.

Typeclasses Transparent HasUnmiffError.

(** Partially, the pseudoinverse behaves like an inverse. *)

(** The following statements are equivalent,
    although we favor the first one,
    because it does not mention [option_map] or [option_bind]. *)

Class IsPartSectMiffError `(HasUnmiffError) : Prop :=
  part_sect_miff_error (a : A) : unmiff_error (miff a) = Some a.

Class IsPartSectMiffError' `(HasUnmiffError) : Prop :=
  part_sect_miff_error' (x : option A) :
  option_bind unmiff_error (option_map miff x) = x.

Class IsPartRetrMiffError `(HasUnmiffError) : Prop :=
  part_retr_miff_error (a : A) (b : B)
  (e : unmiff_error b = Some a) : b = miff a.

Class IsPartRetrMiffError' `(HasUnmiffError) : Prop :=
  part_retr_miff_error' (x y : B)
  (e : option_map miff (unmiff_error x) = Some y) : x = y.

Class IsPartUnmiffError `(HasUnmiffError) : Prop := {
  unmiff_error_is_part_sect_miff_error :> IsPartSectMiffError unmiff_error;
  unmiff_error_is_part_retr_miff_error :> IsPartRetrMiffError unmiff_error;
}.

(** Totally, the pseudoinverse behaves like a weak inverse. *)

(** TODO Generalize like this. *)

(* Class IsWeakSect (A B : Type)
  (f : A -> B) (unf_error : B -> option A) : Prop :=
  weak_sect (x : option A) : let y := option_map f x in
  option_map f (option_bind unf_error y) = y. *)

Class IsWeakSectMiffError `(HasUnmiffError) : Prop :=
  weak_sect_miff_error (x : option A) : let y := option_map miff x in
  option_map miff (option_bind unmiff_error y) = y.

Class IsWeakRetrMiffError `(HasUnmiffError) : Prop :=
  weak_retr_miff_error (y : option B) : let x := option_bind unmiff_error y in
  option_bind unmiff_error (option_map miff x) = x.

Class IsWeakUnmiffError `(HasUnmiffError) : Prop := {
  unmiff_error_is_weak_sect_miff_error :> IsWeakSectMiffError unmiff_error;
  unmiff_error_is_weak_retr_miff_error :> IsWeakRetrMiffError unmiff_error;
}.

End Context.

Module PartSect'FromPartSect.

#[local] Instance is_part_sect_miff_error' `(IsPartSectMiffError) :
  IsPartSectMiffError' unmiff_error.
Proof.
  intros [a |].
  - unfold option_bind, option_map.
    apply part_sect_miff_error.
  - unfold option_bind, option_map.
    reflexivity.
Qed.

#[export] Hint Resolve is_part_sect_miff_error' : typeclass_instances.

End PartSect'FromPartSect.

Module PartSectFromPartSect'.

#[local] Instance is_part_sect_miff_error `(IsPartSectMiffError') :
  IsPartSectMiffError unmiff_error.
Proof.
  intros a.
  pose proof part_sect_miff_error' (Some a) as e.
  unfold option_bind, option_map in e.
  apply e.
Qed.

#[export] Hint Resolve is_part_sect_miff_error : typeclass_instances.

End PartSectFromPartSect'.

Module PartRetr'FromPartRetr.

#[local] Instance is_part_retr_miff_error' `(IsPartRetrMiffError) :
  IsPartRetrMiffError' unmiff_error.
Proof.
  intros x y e'.
  destruct (unmiff_error x) as [a |] eqn : e.
  - unfold option_map in e'.
    apply part_retr_miff_error in e.
    setoid_rewrite <- e in e'.
    injection e'. clear e'. intros e'. apply e'.
  - unfold option_map in e'.
    inversion e'.
Qed.

#[export] Hint Resolve is_part_retr_miff_error' : typeclass_instances.

End PartRetr'FromPartRetr.

Module PartRetrFromPartRetr'.

#[local] Instance is_part_retr_miff_error `(IsPartRetrMiffError') :
  IsPartRetrMiffError unmiff_error.
Proof.
  intros a b e.
  destruct (unmiff_error b) as [x |] eqn : e'.
  - apply part_retr_miff_error'.
    setoid_rewrite e'. rewrite e.
    unfold option_map.
    reflexivity.
  - inversion e.
Qed.

#[export] Hint Resolve is_part_retr_miff_error : typeclass_instances.

End PartRetrFromPartRetr'.

(** The second way to form the pseudoinverse is
    to restrict the codomain by introducing rounding. *)

(** In the whole codomain of the miff,
    the pseudoinverse behaves like a bound. *)

Notation IsSectMiffRoundDown g := (IsRetr _=_ miff g).
Notation sect_miff_round_down := (retr : IsSectMiffRoundDown _).

Section Context.

Context `(IsMiff).

Class HasUnmiffRoundDown : Type := unmiff_round_down (b : B) : A.

Class HasUnmiffRoundUp : Type := unmiff_round_up (b : B) : A.

Typeclasses Transparent HasUnmiffRoundDown HasUnmiffRoundUp.

Class IsMonoUnmiffRoundDown `(HasUnmiffRoundDown) : Prop :=
  mono_unmiff_round_down (x y : B) (l : x <= y) :
  unmiff_round_down x <= unmiff_round_down y.

Class IsSurjUnmiffRoundDown `(HasUnmiffRoundDown) : Prop :=
  surj_unmiff_round_down (a : A) : exists b : B, unmiff_round_down b = a.

Class IsContractUnmiffRoundDown `(HasUnmiffRoundDown) : Prop :=
  contract_unmiff_round_down (x : A) : unmiff_round_down x <= x.

Fail Fail Class IsSectMiffRoundDown `(HasUnmiffRoundDown) : Prop :=
  sect_miff_round_down (a : A) : unmiff_round_down (miff a) = a.

Class IsSectMiffRoundUp `(HasUnmiffRoundUp) : Prop :=
  sect_miff_round_up (a : A) : unmiff_round_up (miff a) = a.

(** The following statements are a bit awkward,
    because the predecessor function can be saturative. *)

Class IsBoundRetrMiffRoundDown `(HasUnmiffRoundDown) : Prop :=
  bound_retr_miff_round_down (b : B) :
  miff (unmiff_round_down b) <= b < miff (succ (unmiff_round_down b)).

Class IsBoundRetrMiffRoundUp `(HasUnmiffRoundUp) : Prop :=
  bound_retr_miff_round_up (b : B) (l : pred b < b) :
  miff (pred (unmiff_round_up b)) < b <= miff (unmiff_round_up b).

(** TODO Check which classes need [IsMiff] and name them properly. *)

Class IsUnmiffRoundDown `(HasUnmiffRoundDown) : Prop := {
  miff_is_miff_round_down :> IsMiff miff;
  unmiff_round_down_is_sect_miff_round_down :>
    IsSectMiffRoundDown unmiff_round_down;
  unmiff_round_down_is_bound_retr_miff_round_down :>
    IsBoundRetrMiffRoundDown unmiff_round_down;
}.

Class IsUnmiffRoundUp `(HasUnmiffRoundUp) : Prop := {
  miff_is_miff_round_up :> IsMiff miff;
  unmiff_round_up_is_sect_miff_round_up :>
    IsSectMiffRoundUp unmiff_round_up;
  unmiff_round_up_is_bound_retr_miff_round_up :>
    IsBoundRetrMiffRoundUp unmiff_round_up;
}.

(** TODO We could probably use this coherence condition
    to derive the rounding modes from each other. *)

Class IsHomUnmiffRound `(HasUnmiffRoundDown) `(HasUnmiffRoundUp) : Prop :=
  hom_unmiff_round (b : B) :
  unmiff_round_up (succ b) = succ (unmiff_round_down b).

Class IsUnmiffRound `(HasUnmiffRoundDown) `(HasUnmiffRoundUp) : Prop := {
  unmiff_round_down_is_unmiff_round_down :>
    IsUnmiffRoundDown unmiff_round_down;
  unmiff_round_up_is_unmiff_round_up :>
    IsUnmiffRoundUp unmiff_round_up;
  unmiff_round_down_unmiff_round_up_is_hom_unmiff_round :>
    IsHomUnmiffRound unmiff_round_down unmiff_round_up;
}.

End Context.

Section Context.

Context `(IsUnmiffRoundDown).

(** The sketch of this proof was contributed by Paolo Giarrusso. *)

#[global] Instance is_mono_unmiff_round_down :
  IsMonoUnmiffRoundDown unmiff_round_down.
Proof.
  intros x y lb.
  destruct (lt_trichotomy (unmiff_round_down x) (unmiff_round_down y))
  as [la | [ea | la']].
  - apply le_neq. lia.
  - lia.
  - exfalso.
    pose proof bound_retr_miff_round_down x as lx.
    pose proof bound_retr_miff_round_down y as ly.
    assert (l : miff (unmiff_round_down x) < miff (succ (unmiff_round_down y)))
    by lia.
    apply str_comono_miff in l.
    lia.
Qed.

#[global] Instance is_surj_unmiff_round_down :
  IsSurjUnmiffRoundDown unmiff_round_down.
Proof.
  intros a.
  exists (miff a).
  pose proof sect_miff_round_down as e.
  rewrite e.
  reflexivity.
Qed.

#[global] Instance is_contract_unmiff_round_down :
  IsContractUnmiffRoundDown unmiff_round_down.
Proof.
  intros a.
  pose proof inflate_miff a as l.
  apply mono_unmiff_round_down in l.
  rewrite sect_miff_round_down in l.
  apply l.
Qed.

Lemma unmiff_round_down_elim (a : A) (b : B)
  (ll : miff a <= b < miff (succ a)) : unmiff_round_down b = a.
Proof.
  destruct (eqb_spec (unmiff_round_down b) (succ a)) as [eb | fb].
  - exfalso.
    apply (f_equal miff) in eb.
    pose proof bound_retr_miff_round_down b as lb.
    lia.
  - assert (lb : b <= miff (succ a)) by lia.
    apply mono_unmiff_round_down in lb.
    rewrite sect_miff_round_down in lb.
    assert (lb1 : unmiff_round_down b <= a) by lia.
    clear fb lb.
    pose proof mono_unmiff_round_down (miff a) b ltac:(lia) as lb0.
    rewrite sect_miff_round_down in lb0.
    lia.
Qed.

End Context.

Section Context.

Context `(IsUnmiffRoundUp).

(** TODO Use generalizations here. *)

#[global] Instance is_mono_unmiff_round_up :
  IsMonoUnmiffRoundDown unmiff_round_up.
Proof.
  intros x y lb.
  unfold unmiff_round_down.
  destruct (lt_trichotomy (unmiff_round_up x) (unmiff_round_up y))
  as [la | [ea | la']].
  - apply le_neq. lia.
  - lia.
  - exfalso.
    destruct (eqb_spec x 0) as [ex | fx].
    subst x.
    rewrite <- fixed_miff in la'.
    rewrite sect_miff_round_up in la'.
    lia.
    destruct (eqb_spec y 0) as [ey | fy].
    subst y.
    lia.
    pose proof bound_retr_miff_round_up x ltac:(lia) as lx.
    pose proof bound_retr_miff_round_up y ltac:(lia) as ly.
    assert (l : miff (pred (unmiff_round_up x)) < miff (unmiff_round_up y))
    by lia.
    apply str_comono_miff in l.
    lia.
Qed.

#[global] Instance is_surj_unmiff_round_up :
  IsSurjUnmiffRoundDown unmiff_round_up.
Proof.
  intros a.
  unfold unmiff_round_down.
  exists (miff a).
  rewrite sect_miff_round_up.
  reflexivity.
Qed.

#[global] Instance is_contract_unmiff_round_up :
  IsContractUnmiffRoundDown unmiff_round_up.
Proof.
  intros a.
  unfold unmiff_round_down.
  pose proof inflate_miff a as l.
  apply (@mono_unmiff_round_down unmiff_round_up _) in l.
  setoid_rewrite sect_miff_round_up in l.
  apply l.
Qed.

Lemma unmiff_round_up_elim (a : A) (b : B)
  (ll : miff (pred a) < b <= miff a) : unmiff_round_up b = a.
Proof.
  destruct (eqb_spec (unmiff_round_up b) (pred a)) as [eb | fb].
  - exfalso.
    apply (f_equal miff) in eb.
    pose proof bound_retr_miff_round_up b as lb.
    lia.
  - assert (lb : miff (pred a) <= b) by lia.
    apply (@mono_unmiff_round_down unmiff_round_up _) in lb.
    unfold unmiff_round_down in lb.
    rewrite sect_miff_round_up in lb.
    assert (lb1 : a <= unmiff_round_up b) by lia.
    clear fb lb.
    pose proof (@mono_unmiff_round_down unmiff_round_up _) b (miff a) ltac:(lia) as lb0.
    setoid_rewrite sect_miff_round_up in lb0.
    lia.
Qed.

End Context.

Module RoundUpFromRoundDown.

Section Context.

Context `(IsUnmiffRoundDown).

Equations unmiff_round_up_def (b : B) : A :=
  unmiff_round_up_def N0 := 0;
  unmiff_round_up_def (Npos p) := succ (unmiff_round_down (Pos.pred_N p)).

Instance has_unmiff_round_up : HasUnmiffRoundUp := unmiff_round_up_def.

Instance is_sect_miff_round_up : IsSectMiffRoundUp unmiff_round_up.
Proof.
  intros a.
  unfold unmiff_round_up, has_unmiff_round_up.
  induction a as [| p e] using peano_ind.
  - rewrite fixed_miff.
    simp unmiff_round_up_def.
    reflexivity.
  - simp unmiff_round_up_def. Admitted.

Instance is_bound_retr_miff_round_up : IsBoundRetrMiffRoundUp unmiff_round_up.
Proof.
  intros b l.
  unfold unmiff_round_up, has_unmiff_round_up.
  pose proof bound_retr_miff_round_down b as ll. Admitted.

Instance is_unmiff_round_up : IsUnmiffRoundUp unmiff_round_up.
Proof. esplit; typeclasses eauto. Qed.

End Context.

#[export] Hint Resolve has_unmiff_round_up is_sect_miff_round_up
  is_bound_retr_miff_round_up is_unmiff_round_up : typeclass_instances.

End RoundUpFromRoundDown.

(** In the image of the miff,
    the pseudoinverse behaves like an inverse. *)

Section Context.

(** Forming the quotient would be much nicer with higher inductive types,
    because then we would not need to choose an arbitrary rounding mode. *)

Context `(IsUnmiffRoundDown).

Definition R (x y : B) : Prop :=
  exists a : A, miff a <= x < miff (succ a) /\ miff a <= y < miff (succ a).

Definition B_R : Type := {b : B $ Squash (miff (unmiff_round_down b) = b)}.

Equations pr (b : B) : B_R :=
  pr b := Sexists _ (miff (unmiff_round_down b)) _.
Next Obligation.
  intros b.
  apply squash.
  rewrite (sect_miff_round_down (unmiff_round_down b)).
  reflexivity.
Qed.

Lemma quotient (x y : B) (r : R x y) : pr x = pr y.
Proof.
  unfold pr.
  apply Spr1_inj.
  unfold Spr1.
  f_equal.
  destruct r as [a [lx ly]].
  rewrite (unmiff_round_down_elim _ a x),
  (unmiff_round_down_elim _ a y) by assumption.
  reflexivity.
Qed.

Equations miff_round_dep (a : A) : B_R :=
  miff_round_dep a := pr (miff a).

Class HasUnmiffRoundDep : Type := unmiff_round_dep (x : B_R) : A.

Typeclasses Transparent HasUnmiffRoundDep.

Class IsSectMiffRoundDep `(HasUnmiffRoundDep) : Prop :=
  sect_miff_round_dep (a : A) : unmiff_round_dep (miff_round_dep a) = a.

Class IsRetrMiffRoundDep `(HasUnmiffRoundDep) : Prop :=
  retr_miff_round_dep (x : B_R) : miff_round_dep (unmiff_round_dep x) = x.

Class IsUnmiffRoundDep `(HasUnmiffRoundDep) : Prop := {
  miff_is_miff_round_dep :> IsMiff miff;
  unmiff_round_dep_is_sect_miff_round_dep :>
    IsSectMiffRoundDep unmiff_round_dep;
  unmiff_round_dep_is_retr_miff_round_dep :>
    IsRetrMiffRoundDep unmiff_round_dep;
}.

End Context.

(** The third way to form the pseudoinverse is
    to extend the domain by carrying a remainder. *)

(** With an arbitrary remainder,
    the pseudoinverse behaves like a weak inverse. *)

Section Context.

Context `(IsMiff).

Equations miff_rem_down (x : A + A * B) : B :=
  miff_rem_down (inl a) := miff a;
  miff_rem_down (inr (a, b)) := b + miff a.

Equations miff_rem_up (x : A + A * B) : B :=
  miff_rem_up (inl a) := miff a;
  miff_rem_up (inr (a, b)) := miff a - b.

Class HasUnmiffRemDown : Type := unmiff_rem_down (b : B) : A + A * B.

Class HasUnmiffRemUp : Type := unmiff_rem_up (b : B) : A + A * B.

Typeclasses Transparent HasUnmiffRemDown HasUnmiffRemUp.

Class IsPartSectMiffRemDown `(HasUnmiffRemDown) : Prop :=
  part_sect_miff_rem_down (a : A) : unmiff_rem_down (miff a) = inl a.

Class IsPartSectMiffRemUp `(HasUnmiffRemUp) : Prop :=
  part_sect_miff_rem_up (a : A) : unmiff_rem_up (miff a) = inl a.

Class IsRetrMiffRemDown `(HasUnmiffRemDown) : Prop :=
  retr_miff_rem_down (b : B) : miff_rem_down (unmiff_rem_down b) = b.

Class IsRetrMiffRemUp `(HasUnmiffRemUp) : Prop :=
  retr_miff_rem_up (b : B) : miff_rem_up (unmiff_rem_up b) = b.

Class IsUnmiffRemDown `(HasUnmiffRemDown) : Prop := {
  miff_is_miff_rem_down :> IsMiff miff;
  unmiff_rem_down_is_part_sect_miff_rem_down :>
    IsPartSectMiffRemDown unmiff_rem_down;
  unmiff_rem_down_is_retr_miff_rem_down :> IsRetrMiffRemDown unmiff_rem_down;
}.

Class IsUnmiffRemUp `(HasUnmiffRemUp) : Prop := {
  miff_is_miff_rem_up :> IsMiff miff;
  unmiff_rem_up_is_part_sect_miff_rem_up :>
    IsPartSectMiffRemUp unmiff_rem_up;
  unmiff_rem_up_is_retr_miff_rem_up :> IsRetrMiffRemUp unmiff_rem_up;
}.

Class IsUnmiffRem `(HasUnmiffRemDown) `(HasUnmiffRemUp) : Prop := {
  unmiff_rem_down_is_unmiff_rem_down :> IsUnmiffRemDown unmiff_rem_down;
  unmiff_rem_up_is_unmiff_rem_up :> IsUnmiffRemUp unmiff_rem_up;
}.

End Context.

(** With a well-formed remainder,
    the pseudoinverse behaves like an inverse. *)

Section Context.

Context `(IsMiff).

Definition P_down (a : A) (b : B) : Prop :=
  miff a < b + miff a < miff (succ a).

Definition P_up (a : A) (b : B) : Prop :=
  miff (pred a) < miff a - b < miff a.

Definition S_down : Type := A + {x : A * B $ Squash (prod_uncurry P_down x)}.

Definition S_up : Type := A + {x : A * B $ Squash (prod_uncurry P_up x)}.

Equations miff_rem_down_dep (x : S_down) : B :=
  miff_rem_down_dep (inl a) := miff a;
  miff_rem_down_dep (inr (Sexists _ (a, b) _)) := b + miff a.

Equations miff_rem_up_dep (x : S_up) : B :=
  miff_rem_up_dep (inl a) := miff a;
  miff_rem_up_dep (inr (Sexists _ (a, b) _)) := miff a - b.

Class HasUnmiffRemDownDep : Type := unmiff_rem_down_dep (b : B) : S_down.

Class HasUnmiffRemUpDep : Type := unmiff_rem_up_dep (b : B) : S_up.

Typeclasses Transparent HasUnmiffRemDownDep HasUnmiffRemUpDep.

Class IsSectMiffRemDownDep `(HasUnmiffRemDownDep) : Prop :=
  sect_miff_rem_down_dep (x : S_down) :
  unmiff_rem_down_dep (miff_rem_down_dep x) = x.

Class IsSectMiffRemUpDep `(HasUnmiffRemUpDep) : Prop :=
  sect_miff_rem_up_dep (x : S_up) :
  unmiff_rem_up_dep (miff_rem_up_dep x) = x.

Class IsRetrMiffRemDownDep `(HasUnmiffRemDownDep) : Prop :=
  retr_miff_rem_down_dep (b : B) :
  miff_rem_down_dep (unmiff_rem_down_dep b) = b.

Class IsRetrMiffRemUpDep `(HasUnmiffRemUpDep) : Prop :=
  retr_miff_rem_up_dep (b : B) :
  miff_rem_up_dep (unmiff_rem_up_dep b) = b.

Class IsUnmiffRemDownDep `(HasUnmiffRemDownDep) : Prop := {
  miff_is_miff_rem_down_dep :> IsMiff miff;
  unmiff_rem_down_dep_is_sect_miff_rem_down_dep :>
    IsSectMiffRemDownDep unmiff_rem_down_dep;
  unmiff_rem_down_dep_is_retr_miff_rem_down_dep :>
    IsRetrMiffRemDownDep unmiff_rem_down_dep;
}.

Class IsUnmiffRemUpDep `(HasUnmiffRemUpDep) : Prop := {
  miff_is_miff_rem_up_dep :> IsMiff miff;
  unmiff_rem_up_dep_is_sect_miff_rem_up_dep :>
    IsSectMiffRemUpDep unmiff_rem_up_dep;
  unmiff_rem_up_dep_is_retr_miff_rem_up_dep :>
    IsRetrMiffRemUpDep unmiff_rem_up_dep;
}.

Class IsUnmiffRemDep `(HasUnmiffRemDownDep) `(HasUnmiffRemUpDep) : Prop := {
  unmiff_rem_down_dep_is_unmiff_rem_down_dep :>
    IsUnmiffRemDownDep unmiff_rem_down_dep;
  unmiff_rem_up_dep_is_unmiff_rem_up_dep :>
    IsUnmiffRemUpDep unmiff_rem_up_dep;
}.

End Context.

(** TODO Now show the relative strength lattice. *)