Require Import Arith.
Require Import EqNat.
Require Import Ring.

(* -------------------------------------------------------------------- *)
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 finmap seq ssrfun finfun matrix ssrnum ssrfun.
From mathcomp Require Import bigop ssralg finset fingroup zmodp poly fingraph.
From mathcomp Require Import tuple choice path.
(* -------------------------------------------------------------------- *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section gensym.

Open Scope fmap_scope.

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).

Axiom modulo : forall i n:nat,  (i%%n)< n.

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

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

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

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

Definition addOrdn (n:nat) : 'I_n -> 'I_n -> 'I_n :=
  fun (p q : 'I_n) => Ordinal(modulo (p-q) n).

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

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

Definition point2R2 (p: point) : R :=
  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) : R :=
  (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) :R :=
  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 M1 := \col_(j < 4) if j==0 then
                           point2R1 (triangle2points t1 tm (Ordinal (zero<3)))
                         else if  j==1 then
                           point2R1 (triangle2points t1 tm (Ordinal (un<3)))
                         else if  nat_of_ord j==2 then
                           point2R1 (triangle2points t1 tm (Ordinal (deux<3)))
                         else point2R1 p1 in

  let M2 := \col_(j < 4) if j==0 then
                           point2R2 (triangle2points t1 tm (Ordinal (zero<3)))
                         else if  j==1 then
                           point2R2 (triangle2points t1 tm (Ordinal (un<3)))
                         else if  nat_of_ord j==2 then
                           point2R2 (triangle2points t1 tm (Ordinal (deux<3)))
                         else point2R2 p1 in

  let M3 := \col_(j < 4) if j==0 then
                (point2R1 (triangle2points t1 tm (Ordinal (zero<3))))^+2
                   + (point2R2 (triangle2points t1 tm (Ordinal (zero<3))))^+2
                         else if j==1 then
                (point2R1 (triangle2points t1 tm (Ordinal (un<3))))^+2
                   + (point2R2 (triangle2points t1 tm (Ordinal (un<3))))^+2
                         else if  nat_of_ord j==2 then
                (point2R1 (triangle2points t1 tm (Ordinal (deux<3))))^+2
                   + (point2R2 (triangle2points t1 tm (Ordinal (deux<3))))^+2
                         else (point2R1 p1)^+2 + (point2R2 p1)^+2 in

  let M4 := \col_(j < 4) 1 in
  let M := row_mx (row_mx M1 M2) (row_mx M3 M4) in if \det M > 0 then true
                                                   else false.

(* 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 :=
  if (inCircle (triangle2points t1 tm (Ordinal (zero<3))) t2 tm == false
      && inCircle (triangle2points t1 tm (Ordinal (un<3))) t2 tm== false
      && inCircle (triangle2points t1 tm (Ordinal (deux<3))) t2 tm== false)
              then true
              else false.

(* 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 M11 := \col_(j < 3) if j==0 then point2R1 p
                         else if j==1 then point2R1 a
                         else point2R1 b in

  let M12 := \col_(j < 3) if j==0 then point2R2 p
                         else if j==1 then point2R2  a
                         else point2R2 b in

  let M13 := \col_(j < 3) 1 in
     let M1 := row_mx (row_mx M11 M12) M13 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). *)

(* -------------------------------------------------------------------- *)
(* Dans cette section, on va prouver que l'orientation des triangles est
   maintenue par les opérations add_point_triangle et flip *)
(* -------------------------------------------------------------------- *)

(* oriented est le prédicat booléen d'orientation. oriented t tm vaut vrai
   si le triangle (tm t) est un triplet de points orientés en sens trigo *)
Definition oriented (t : T) (tm :trianglemap) :=
  leftpoint (tm t (Ordinal(zero<3))) (tm t (Ordinal(un<3)))
                                             (tm t (Ordinal(deux<3))) > 0.

(* orientedpostadd_point_triangle prouve que si la tmap contenant t
   ne contient que des triangles oriented alors la tmap obtenue
   post-add_point_triangle ne contiendra que des triangles oriented *)
Lemma orientedpostadd_point_triangle (p:point) (t:T) (tm : trianglemap)
                                        (g:graph) (pm :pointmap) :
forall nomt:T, oriented t tm
         -> if add_point_triangle (p:point) (t:T) (tm : trianglemap)
                                           (g:graph) (pm :pointmap)
    is Some (g', tm') then forall t1:T, oriented t1 tm'
                 else oriented t tm.
Proof.
rewrite /=.
move=>t0 Htm_oriented.
rewrite /add_point_triangle.
Abort.

(* orientedpostflip prouve que si la tmap contenant t1 et t2 ne contient
   que des triangles oriented et si il faut flipper alors la tmap obtenue
   post-flip ne contiendra que des triangles oriented *)
Lemma orientedpostflip (tm: trianglemap)  (ptext1 : point) (ptext2 : point)
                           (t1:T) (t2 :T) (g:graph) (pm: pointmap) :
forall t:T, oriented t tm -> (oriented t1 tm)
 -> (oriented t2 tm) -> isDelaunayLocal t1 t2 tm == false
  -> if flip (tm: trianglemap) (ptext1 : point)
                                  (ptext2 : point) (t1:T) (t2 :T) (g:graph)
                                     (pm: pointmap) is Some (g',tm') then
        forall tt:T, oriented tt tm'
     else (oriented t1 tm) && (oriented t2 tm).
Proof.
Abort.

(* -------------------------------------------------------------------- *)
(* Dans cette section, on va prouver l'équivalence entre être <<dans>>
   un triangle et s'écrire comme un barycentre des 3 sommets *)
(* -------------------------------------------------------------------- *)

Lemma eq_bar (t:T) (tm : trianglemap) (p:point) :
  (leftpoint ((tm t) (Ordinal(zero<3))) ((tm t) (Ordinal(un<3)))
                  ((tm t) (Ordinal(deux<3))) > 0)
&& (leftpoint p ((tm t) (Ordinal(zero<3))) ((tm t) (Ordinal(un<3)))
                   > 0)
&& (leftpoint p ((tm t) (Ordinal(un<3))) ((tm t) (Ordinal(deux<3)))
                   > 0)
&& (leftpoint p ((tm t) (Ordinal(deux<3))) ((tm t) (Ordinal(zero<3)))
                  > 0)
<-> exists k1, exists k2, exists k3,
 (point2R1 p == k1*point2R1 ((tm t) (Ordinal(zero<3)))
                + k2*point2R1 ((tm t) (Ordinal(un<3)))
                + k3*point2R1 ((tm t) (Ordinal(deux<3)))) && (k1+k2+k3 ==1).
Proof.
Abort.

(* -------------------------------------------------------------------- *)
(* Dans cette section, on va s'intéresser aux surfaces qui sont conservées
   par les opérations de flip et add_point_triangle *)
(* -------------------------------------------------------------------- *)

Definition surface_sans_bord (t:T) (tm: trianglemap) (pm : pointmap) :=
  [set nomp : P | (leftpoint (pm nomp) ((tm t) (Ordinal(zero<3)))
                        ((tm t) (Ordinal(un<3))) >0) &&
                  (leftpoint (pm nomp) ((tm t) (Ordinal(un<3)))
                        ((tm t) (Ordinal(deux<3)))>0) &&
                  (leftpoint (pm nomp) ((tm t) (Ordinal(deux<3)))
                        ((tm t) (Ordinal(zero<3)))>0)].

Definition bord1 (t:T) (tm: trianglemap) (pm :pointmap) :=
[set nomp :P | (leftpoint (pm nomp) ((tm t) (Ordinal(zero<3)))
                        ((tm t) (Ordinal(un<3))) == 0)
                 &&  (norm_carre ((tm t) (Ordinal(zero<3))) (pm nomp)
                              <= norm_carre ((tm t) (Ordinal(zero<3)))
                                              ((tm t) (Ordinal(un<3))))
                 && (prod_scal ((tm t) (Ordinal(zero<3))) (pm nomp)
                                    ((tm t) (Ordinal(zero<3)))
                                              ((tm t) (Ordinal(un<3))) >0)].

Definition bord2 (t:T) (tm: trianglemap) (pm :pointmap) :=
[set nomp :P | (leftpoint (pm nomp) ((tm t) (Ordinal(un<3)))
                        ((tm t) (Ordinal(deux<3))) == 0)
                 &&  (norm_carre ((tm t) (Ordinal(un<3))) (pm nomp)
                              <= norm_carre ((tm t) (Ordinal(un<3)))
                                              ((tm t) (Ordinal(deux<3))))
                 && (prod_scal ((tm t) (Ordinal(un<3))) (pm nomp)
                                    ((tm t) (Ordinal(un<3)))
                                              ((tm t) (Ordinal(deux<3))) >0)].

Definition bord3 (t:T) (tm: trianglemap) (pm :pointmap) :=
[set nomp :P | (leftpoint (pm nomp) ((tm t) (Ordinal(deux<3)))
                        ((tm t) (Ordinal(zero<3))) == 0)
                 &&  (norm_carre ((tm t) (Ordinal(deux<3))) (pm nomp)
                              <= norm_carre ((tm t) (Ordinal(deux<3)))
                                              ((tm t) (Ordinal(zero<3))))
                 && (prod_scal ((tm t) (Ordinal(deux<3))) (pm nomp)
                                    ((tm t) (Ordinal(deux<3)))
                                              ((tm t) (Ordinal(zero<3))) >0)].

Definition surface (t:T) (tm: trianglemap) (pm :pointmap) :=
  surface_sans_bord t tm pm :|: bord1 t tm pm :|: bord2 t tm pm
        :|: bord3 t tm pm.

Lemma surface_flip (tm: trianglemap)  (ptext1 : point) (ptext2 : point)
                       (t1:T) (t2 :T) (g:graph) (pm: pointmap) (p:point)
                        (nomp : P) :
pm nomp ==p
-> (nomp \in surface t1 tm pm)
    || (nomp \in surface t2 tm pm)
      -> exists t:T, if flip (tm: trianglemap) (ptext1 : point)
                                  (ptext2 : point) (t1:T) (t2 :T) (g:graph)
                                     (pm: pointmap) is Some (g',tm') then
                            nomp \in surface t tm' pm
                   else (nomp \in surface t1 tm pm)
                          || (nomp \in surface t2 tm pm).
Abort.

Lemma surface_add_point_triangle (p:point) (t:T) (tm : trianglemap)
                                     (g:graph) (pm :pointmap) (nomp : P) :
pm nomp ==p ->
  (nomp \in surface t tm pm) -> if add_point_triangle (p:point) (t:T)
                                (tm : trianglemap) (g:graph) (pm :pointmap)
              is Some (g', tm') then exists t1:T, nomp \in surface t1 tm' pm
                          else (nomp \in surface t tm pm).
Abort.

(* -------------------------------------------------------------------- *)
(* Dans cette section, on va démontrer une propriété combinatoire *)
(* -------------------------------------------------------------------- *)

Lemma combi_flip (tm: trianglemap) (ptext1 : point) (ptext2 : point)
             (t3 t4: T) (t1:T) (t2 :T) (g:graph) (pm: pointmap) (p:point) :
 (t3 \in g t4 -> t4 \in g t3)
-> forall (t5 t6 :T), if flip (tm: trianglemap) (ptext1 : point)
                                  (ptext2 : point) (t1:T) (t2 :T) (g:graph)
                                     (pm: pointmap) is Some (g',tm') then
                             (t5 \in g' t6 -> t6 \in g' t5)
                   else (t3 \in g t4 -> t4 \in g t3).
Abort.

Lemma combi_add_point_triangle (p:point) (t:T) (tm : trianglemap)
                                 (g:graph) (pm :pointmap) (t1:T) (t2 :T) :
  (t1 \in g t2 -> t2 \in g t1)
-> forall (t3 t4 :T), if add_point_triangle (p:point) (t:T)
                                (tm : trianglemap) (g:graph) (pm :pointmap)
              is Some (g', tm') then   (t3 \in g' t4 -> t4 \in g' t3)
                          else (t1 \in g t2 -> t2 \in g t1).
Abort.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Preservation.

Lemma canonical_form_abs : forall e U1 U2 S,
  value e ->
  typing empty e S ->
  sub empty S (typ_arrow U1 U2) ->
  exists V, exists e1, e = exp_abs V e1.
Proof with auto.
  intros.
  generalize dependent U1.
  generalize dependent U2.
  dependent induction H0;intros;
    try solve [inversion H;inv_rt|inversion H1;inv_rt|inversion H2;inv_rt
    |inversion H3;inv_rt]...
  -
    exists V.
    exists e1...
  -
    inversion H0;subst;inv_rt. inversion H2;inv_rt. inversion H2;inv_rt.
  -
    apply IHtyping with (U1:=U1) (U2:=U2)...
    apply sub_transitivity with (Q:=T)...
Qed.

Lemma canonical_form_tabs : forall e U1 U2 S,
  value e ->
  typing empty e S ->
  sub empty S (typ_all U1 U2) ->
  exists V, exists e1, e = exp_tabs V e1.
Proof with auto.
  intros.
  generalize dependent U1.
  generalize dependent U2.
  dependent induction H0;intros;
  try solve [inversion H;inv_rt|inversion H1;inv_rt|inversion H2;inv_rt
  |inversion H3;inv_rt]...
  -
    exists V.
    exists e1...
  -
    inversion H0;subst;inv_rt. inversion H2;inv_rt. inversion H2;inv_rt.
  -
    apply IHtyping with (U1:=U1) (U2:=U2)...
    apply sub_transitivity with (Q:=T)...
Qed.

Lemma canonical_form_fold : forall e U S,
  value e ->
  typing empty e S ->
  sub empty S (typ_mu U) ->
  exists V, exists e1, exists T,
   (sub empty (typ_mu V) (typ_mu U) /\ value e1 /\ e = exp_fold T e1 /\
   WF empty T).
Proof with auto.
  intros.
  generalize dependent U.
  dependent induction H0;intros;
  try solve [inversion H;inv_rt|inversion H1;inv_rt|inversion H2;inv_rt
  |inversion H3;inv_rt]...
  -
    dependent destruction H.
    exists A...
    exists e...
    exists T... repeat split...
    apply sub_transitivity with (Q:=T)... get_well_form...
  -
    apply IHtyping with (U:=U)...
    apply sub_transitivity with (Q:=T)...
Qed.

(*
Lemma canonical_form_fold' : forall e U S,
  typing empty e S ->
  sub empty S (typ_mu U) ->
  exists V, exists e1, (sub empty (typ_mu V) (typ_mu U) /\ value e1 /\ e = exp_fold (typ_mu V) e1).
Proof with auto.
  intros.
  generalize dependent U.
  dependent induction H;intros;try solve [inversion H0|inversion H1].

  |inversion H2]...
  -
    dependent destruction H.
    exists A...
    exists e...
  -
    apply IHtyping with (U:=U)...
    apply sub_transitivity with (Q:=T)...
Qed. *)

Lemma value_expr: forall e,
    value e -> expr e.
Proof with auto.
  intros.
  induction H...
Qed.

Lemma progress : forall e T,
  typing empty e T ->
  value e \/ exists e', step e e'.
Proof with eauto.
  intros.
  dependent induction H...
  -
    inversion H0...
  - (* abs *)
    left.
    constructor.
    apply expr_abs with (L:=L).
    pick fresh Y.
    specialize_x_and_L Y L.
    apply typing_regular in H.
    destruct_hypos.
    dependent destruction H...
    apply WF_type in H0...
    intros.
    apply H in H1.
    apply typing_regular in H1.
    destruct_hypos...
  - (* app *)
    right.
    destruct IHtyping1;destruct IHtyping2...
    +
      apply canonical_form_abs with (S:=typ_arrow T1 T2) (U1:=T1) (U2:=T2) in H...
      destruct_hypos.
      exists (open_ee x0 e2).
      subst.
      apply step_beta...
      apply value_expr...
      apply Reflexivity...
      apply typing_regular in H.
      destruct_hypos...
    +
      destruct_hypos.
      exists (exp_app e1 x).
      apply step_app2...
    +
      destruct_hypos.
      exists (exp_app x e2).
      apply step_app1...
      apply value_expr...
    +
      destruct_hypos.
      exists (exp_app x0 e2).
      apply step_app1...
      apply typing_regular in H0.
      destruct_hypos...
  - (* tabs *)
    left.
    constructor.
    apply expr_tabs with (L:=L).
    pick fresh Y.
    specialize_x_and_L Y L.
    apply typing_regular in H.
    destruct_hypos.
    dependent destruction H...
    apply WF_type in H0...
    intros.
    apply H in H1.
    apply typing_regular in H1.
    destruct_hypos...
  - (* tapp *)
    right.
    destruct IHtyping...
    +
      apply canonical_form_tabs with (U1:=T1) (U2:=T2) in H...
      destruct_hypos.
      exists (open_te x0 T).
      subst.
      apply step_tabs...
      apply value_expr...
      get_type...
      apply Reflexivity...
      apply typing_regular in H.
      destruct_hypos...
    +
      destruct_hypos.
      exists (exp_tapp x T).
      apply step_tapp...
      get_type...
  - (* fold *)
    assert (empty ~= empty) by auto.
    apply IHtyping in H1.
    destruct H1.
    left.
    constructor...
    { get_well_form. apply WF_type in H3... }
    right.
    destruct H1.
    exists (exp_fold T x).
    constructor...
    { get_well_form. apply WF_type in H3... }
    (* apply typing_regular in H0.
    destruct_hypos...
    apply WF_type in H1... *)
  - (* unfold *)
    right.
    destruct IHtyping...
    +
      apply canonical_form_fold with (e:=e) (S:=A) (U:=T) in H0...
      destruct_hypos.
      exists x0...
      rewrite H3.
      get_well_form...
      apply step_fld...
      apply WF_type in H4...
      apply typing_regular in H.
      destruct_hypos.
      apply WF_type in H8...
    +
      destruct_hypos.
      exists (exp_unfold A x).
      (* apply canonical_form_fold with (e:=e) (S:=A) (U:=T) in H0... *)
      apply step_unfold...
      apply typing_regular in H...
      destruct_hypos.
      apply WF_type in H3...
  -
    destruct IHtyping...
    +
      right. assert (Ht:=H1).
      apply lookup_field_in_value with (T:=T) (i:=i) (Ti:=Ti) in H1...
      destruct H1.
      destruct H1.
      exists x...
    +
      right. destruct H1...
  -
    destruct IHtyping1;destruct IHtyping2...
    +
      destruct H5...
    +
      destruct H4...
    +
      destruct H4;destruct H5...
Qed.


Require Import CSet CMap CMapDomain CMapPartialOrder.
Require Import Infra.PartialOrder Infra.Lattice Infra.OptionR.

Require Import MapNotations.
Set Implicit Arguments.

Definition joinMap X `{OrderedType X} Y `{JoinSemiLattice Y}
           (d d':Map [X, Y]) := @map2 _ H _ Y Y Y join d d'.

Lemma leMap_join X `{OrderedType X} Y `{JoinSemiLattice Y} (x y x' y':Map[X, Y])
  : leMap y x
    -> leMap y' x'
    -> leMap (joinMap y y') (joinMap x x').
Proof.
  unfold leMap, joinMap.
  intros LE1 LE2 z.
  repeat rewrite MapFacts.map2_1bis; eauto.
  specialize (LE1 z). specialize (LE2 z).
  revert LE1 LE2.
  case_eq (find z y); case_eq (find z x);
    case_eq (find z y'); case_eq (find z x'); intros; simpl in *;
      clear_trivial_eqs; simpl; repeat cases; try reflexivity;
        eauto using fstNoneOrR, join_struct, join_poLe.
Qed.

Lemma empty_bottom X `{OrderedType X} Y `{PartialOrder Y}
  :  forall a : Map [X, Y], @empty _ _ _ _ ⊑ a.
Proof.
  intros. econstructor.
Qed.

Lemma joinDom_bound X `{OrderedType X} Y `{JoinSemiLattice Y}
  : forall a b : Map [X, Y], poLe a b -> poLe (joinMap a b) b.
Proof.
  unfold joinMap. intros.
  hnf; intros.
  rewrite MapFacts.map2_1bis; eauto.
  rewrite join_bound; eauto.
Qed.

Lemma joinDom_sym X `{OrderedType X} Y `{JoinSemiLattice Y}
  : forall a b : Map [X, Y], joinMap a b ≣ joinMap b a.
Proof.
  unfold joinMap; intros. hnf; intros.
  rewrite !MapFacts.map2_1bis; eauto.
  rewrite join_commutative. reflexivity.
Qed.

Lemma joinDom_assoc X `{OrderedType X} Y `{JoinSemiLattice Y}
  : forall a b c : Map [X, Y], joinMap (joinMap a b) c ≣ joinMap a (joinMap b c).
Proof.
  unfold joinMap; intros. hnf; intros.
  rewrite !MapFacts.map2_1bis; eauto.
  rewrite join_associative. reflexivity.
Qed.

Lemma joinDom_exp X `{OrderedType X} Y `{JoinSemiLattice Y}
  : forall a b : Map [X, Y], a ⊑ joinMap a b.
Proof.
  intros. unfold joinMap. hnf; intros.
  rewrite !MapFacts.map2_1bis; eauto.
  eapply join_poLe.
Qed.

Instance joinDom_eq X `{OrderedType X} Y `{JoinSemiLattice Y}
  : Proper (poEq ==> poEq ==> poEq) (@joinMap X _ Y _ _).
Proof.
  unfold Proper, respectful; intros.
  hnf in H, H0.
  unfold joinMap.
  hnf; intros.
  rewrite !MapFacts.map2_1bis; eauto.
  rewrite H2, H3. reflexivity.
Qed.

Instance joinDom_poLe X `{OrderedType X} Y `{JoinSemiLattice Y}
  : Proper (poLe ==> poLe ==> poLe) (@joinMap X _ Y _ _).
Proof.
  unfold Proper, respectful; intros.
  eapply leMap_join; eauto.
Qed.

Instance map_semilattice X `{OrderedType X} Y `{JoinSemiLattice Y}
  : JoinSemiLattice (Map [X, Y]) := {
  join := @joinMap X _ Y _ _
                                                    }.

- eapply joinDom_bound.
- eapply joinDom_sym.
- eapply joinDom_assoc.
- eapply joinDom_exp.
Defined.

Instance map_lower_bounded X `{OrderedType X} Y `{PartialOrder Y}
  : LowerBounded (Map [X, Y]) :=
  {
    bottom := (@empty X _ _ Y)
  }.
Proof.
  - eapply empty_bottom; eauto.
Defined.

Import Terminating.

Lemma leMap_domain X `{OrderedType X} Y `{PartialOrder Y} x y
  : leMap x y -> domain x ⊆ domain y.
Proof.
  unfold leMap. intros.
  hnf; intros.
  specialize (H1 a).
  eapply domain_find in H2. dcr.
  rewrite H3 in H1. inv H1.
  eapply find_domain. congruence.
Qed.

Instance ltMap_proper X `{OrderedType X} Y `{PartialOrder Y} (d d':Map [X, Y])
  : Proper (_eq ==> iff) (fun x => find x d ⊏ find x d').
Proof.
  unfold Proper, respectful; intros.
  split; intros.
  - rewrite <- H1; eauto.
  - rewrite H1; eauto.
Qed.

Lemma domain_join X `{OrderedType X} Y `{JoinSemiLattice Y} (d d':Map[X,Y])
: domain (map2 join d d') [=] domain d ∪ domain d'.
Proof.
  split; intros.
  - eapply domain_find in H2; dcr.
    rewrite MapFacts.map2_1bis in H3; eauto.
    revert H3.
    case_eq (find a d); intros.
    + eapply find_domain' in H2. cset_tac.
    + revert H3.
      case_eq (find a d'); intros; simpl in *;
        clear_trivial_eqs.
      * eapply find_domain' in H3. cset_tac.
  - eapply find_domain.
    rewrite MapFacts.map2_1bis; eauto.
    cset_tac'.
    + eapply domain_find in H4. dcr.
      rewrite H2 in H3.
      destruct (find a d'); clear_trivial_eqs.
    + eapply domain_find in H4. dcr.
      rewrite H2 in H3.
      destruct (find a d); clear_trivial_eqs.
Qed.