(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import znat.
Require Import grid.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* Mattes are finite sets of grid squares that are delimited by a simple grid  *)
(* ring; we explicitly include the enumeration of the region and the ring.     *)
(* Mattes will be used to define conservative approximations of aribitrary     *)
(* connected open sets of points (regions). We therefore need to provide       *)
(* operations for extending a matte in order to improve the approximation.     *)
(* This involves three different operations :                                  *)
(*   - adding pixels within a specified rectangle that the matte meets, so     *)
(*     that a specific pixel is covered.                                       *)
(*   - adding the pixels surrounding a grid point of the matte boundary.       *)
(*   - refining the grid to ensure that the two previous operations are safe.  *)
(* Note that we can't add large rectangle blindly to a matte if we want to     *)
(* preserve its geometrical properties (we might end up with a disconnected    *)
(* contour). We reduce the first two operations above to two primitives, which *)
(* add a pixel that has exactly one or two consecutive sides in common with    *)
(* the matte, respectively (more precisely, 2 or 3 consecutive vertices in     *)
(* common with the matte contour vertices). We don't actually provide the      *)
(* second operation here, because it requires multiple grid refinement.        *)
(* Instead we provide a basic have that needs to be iterated to accomplish the *)
(* operation, along with the metric ("matte_order") that decreases with that   *)
(* step.                                                                       *)

Definition mrlink p1 p2 := end1g p1 =d end0g p2.

Record matte : Set := Matte {
  mdisk :> gpointseq;
  mring : gpointseq;
  matte_ne : 0 < size mdisk;
  cycle_mring : cycle mrlink mring;
  simple_mring : uniq (maps end0g mring);
  mring_def : mring =1 (fun x => mdisk (halfg x) && negb (mdisk (halfg (gedge x))))
}.

Lemma mring_edge : forall m p, mring m p -> negb (mring m (gedge p)).
Proof.
by case=> /= [c d _ _ _ Dc] p; rewrite !Dc; move/andP=> [_ H]; rewrite (negbE H).
Qed.

(* Initial single_square matte. *)

Section PointMatte.

Variable p : gpoint.

Let pmdisk : gpointseq := Adds p seq0.
Let pmring : gpointseq := maps (fun d => consg d p) (Seq Gb00 Gb10 Gb11 Gb01).

Lemma pmatte_ne : 0 < size pmdisk. Proof. done. Qed.

Lemma cycle_pmring : cycle mrlink pmring.
Proof. by rewrite /= /mrlink /end0g /end1g !halfg_cons !oddg_cons /= !set11. Qed.

Lemma simple_pmring : uniq (maps end0g pmring).
Proof.
by rewrite /= /setU1 /end0g !halfg_cons !oddg_cons !(monic_eqd (addg_inv p)).
Qed.

Lemma pmring_def :
  pmring =1 (fun x => pmdisk (halfg x) && negb (pmdisk (halfg (gedge x)))).
Proof.
move=> x; rewrite -{1}[x]consg_odd_half halfg_edge.
case Hx: (pmdisk (halfg x)).
  rewrite /= /setU1 orbF in Hx; rewrite -(eqP Hx) /= /setU1 !orbF.
  rewrite -{9}[p]addg0 (monic_eqd (addg_inv p)).
  by case (oddg x); rewrite set11 ?orbT.
apply/mapsP => [[d _ Dx]]; move: (congr1 halfg Dx); rewrite !halfg_cons.
by move=> Dp; rewrite /pmdisk Dp /= setU11 in Hx.
Qed.

Definition point_matte := Matte pmatte_ne cycle_pmring simple_pmring pmring_def.

End PointMatte.

(* Grid refinement for mattes.                                                  *)

Section RefineMatte.

Fixpoint refine_mring (c : gpointseq) : gpointseq :=
  if c is Adds p c' then
    Seq (consg (oddg p) p) (consg (oddg p) (gface p)) & (refine_mring c')
  else seq0.

Fixpoint refine_mdisk (md : gpointseq) : gpointseq :=
  if md is Adds p md' then
    Seq (consg Gb00 p) (consg Gb10 p) (consg Gb11 p) (consg Gb01 p)
      & (refine_mdisk md')
  else seq0.

Lemma mem_refine_mdisk : forall md p, refine_mdisk md p = md (halfg p).
Proof.
move=> md p; elim: md => //= [q md Hrec]; rewrite /setU1 Hrec !orbA; congr orb.
rewrite -!orbA; apply/idP/eqP; first by case/or4P=> H; rewrite -(eqP H) halfg_cons.
by rewrite -{-1}[p]consg_odd_half=> <-; case (oddg p); rewrite set11 /= ?orbT.
Qed.

Variable m : matte.

Lemma refine_matte_ne : 0 < size (refine_mdisk m).
Proof. by case: (mdisk m) (matte_ne m). Qed.

Lemma cycle_refine_mring : cycle mrlink (refine_mring (mring m)).
Proof.
case: (mring m) (cycle_mring m) => // [p0 c]; rewrite !(cycle_path p0).
rewrite {1}/last -/(last p0); set q := last p0 c.
have <-: consg (oddg q) (gface q) = last p0 (refine_mring (Adds p0 c)).
  by rewrite {}/q /=; elim: c p0 => /=.
elim: {p0 c}(Adds p0 c) q => //= [p c Hrec] q; move/andP=> [Hqp Hc]; move: Hqp.
rewrite {}Hrec {c Hc}// andbT /mrlink /end0g /end1g !halfg_cons !oddg_cons.
move/eqP=> Dp; rewrite /gface -{1 3}[p]consg_odd_half /consg.
rewrite addgA -addgA -(addgC (halfg q)) {}Dp addgA (addgC (halfg p)) !addgA set11.
by rewrite addgC -!addgA addgCA addgC -!addgA set11.
Qed.

Lemma mem_refine_mring : forall (c : gpointseq) p,
 reflect (exists2 q, c q & p = consg (oddg q) q \/ p = consg (oddg q) (gface q))
         (refine_mring c p).
Proof.
move=> c p; elim: c => [|q c Hrec] /=; first by right; case.
apply: (iffP setU1P).
  case; first by exists q; [ exact: setU11 | left ].
  case/setU1P; first by exists q; [ exact: setU11 | right ].
  by case/Hrec=> [q' Hq' Dp]; exists q'; first exact: setU1r.
case=> q'; case/setU1P=> [<-|Hq'].
  by case=> <-; [ left | right; exact: setU11 ].
by right; apply setU1r; apply/Hrec; exists q'.
Qed.

Lemma simple_refine_mring : uniq (maps end0g (refine_mring (mring m))).
Proof.
elim: (mring m) (simple_mring m) (@mring_edge m) => //= [p c Hrec].
move/andP=> [Hp Uc] HpcE.
have HcE: forall q, c q -> negb (c (gedge q)).
  by move=> q Hq; case/norP: (HpcE _ (setU1r _ Hq)).
rewrite {}Hrec {Hc HcE}// andbT; apply/andP; split.
  apply/setU1P => [[Dp|Hp']].
    rewrite /end0g !halfg_cons !oddg_cons -!(addgC (oddg p)) in Dp.
    move: (congr1 oddg (monic_inj (addg_inv _) Dp)).
    by rewrite oddg_face; case (oddg p).
  case/mapsP: Hp' => [q Hq Dq].
  case/mem_refine_mring: Hq => [q' Hq' [Dq'|Dq']].
    case/mapsP: Hp; exists q'; auto; rewrite -halfg_add_odd addgC.
    move: Dq; rewrite -!halfg_add_odd Dq' !oddg_cons addgC /consg addgA.
    rewrite (addgC (oddg p)) -(addgA (p +g p)) !halfg_add_double !halfg_double.
    by move <-.
  move: Dq; rewrite -!halfg_add_odd Dq' !oddg_cons addgC /consg addgA.
  rewrite (addgC (oddg p)) -(addgA (p +g p)) !halfg_add_double !halfg_double.
  move/(congr1 oddg); rewrite /gface /consg addgA oddg_add_double.
  rewrite (addgC p) -{2}[p]consg_odd_half /consg addgA oddg_add_double oddg_double.
  by case (oddg q').
apply/mapsP => [[q Hq]]; move/esym; rewrite -!halfg_add_odd oddg_cons.
rewrite addgC /consg addgA halfg_add_double halfg_double (addgC q).
case/mem_refine_mring: Hq => [q' Hq' [Dq|Dq]];
  rewrite {}Dq oddg_cons /consg addgA halfg_add_double halfg_double.
- move/(congr1 oddg); rewrite /gface /consg addgA oddg_add_double.
  rewrite -{2}[q']consg_odd_half /consg addgA oddg_add_double oddg_double.
  by case (oddg p).
case/norP: {HpcE}(HpcE _ (setU1r _ Hq')) => [Epq' _].
rewrite /gface /consg addgCA -/(consg (oddg p) (halfg p)) consg_odd_half.
rewrite addgCA consgI consg_odd_half=> Dq'.
rewrite /gedge addgA (addgC q') -Dq' -addgA addgCA -{1}[p]addg0 in Epq'.
rewrite (monic_eqd (addg_inv p)) in Epq'.
have Dq1: oddg q' = oddg p.
  move: (congr1 oddg Dq'); rewrite oddg_add {1}[oddg]lock oddg_add -lock.
  by case: (oddg p) Epq'; case: (oddg q').
rewrite Dq1 in Dq'; case/mapsP: Hp; exists q'; auto.
by rewrite (monic_inj (addg_inv _) Dq').
Qed.

Lemma refine_mring_def : let md' := refine_mdisk (mdisk m) in
 refine_mring (mring m)
   =1 (fun p => md' (halfg p) && negb (md' (halfg (gedge p)))).
Proof.
move: (mdisk m) (mring_def m) (mem_refine_mdisk (mdisk m)) => md Dmd Dmd' /= p.
rewrite /= !{}Dmd' halfg_edge.
apply/(mem_refine_mring _ _)/andP => [[q Hq Dp]|[Hp Hep]].
  rewrite Dmd halfg_edge addgC in Hq; case/andP: Hq => [Hq HqE].
  by case: Dp => ->; rewrite !halfg_cons oddg_cons ?halfg_face; split;
    rewrite // addgC halfg_add ?halfg_face ?oddg_face; case: (oddg q) HqE.
set q := halfg p; set d := oddg p; rewrite addgC halfg_add addgC -/q -/d in Hep.
have Hqd: set2 d (ccw d) (oddg q).
  move: Hp Hep; rewrite -/q -{1}[halfg q]addg0.
  by case: d; case: (oddg q) => //= H; case/idP.
exists (consg (oddg p) (halfg (halfg p))).
  rewrite Dmd halfg_edge halfg_cons oddg_cons Hp -/q -/d /=.
  by case: (oddg q) Hqd Hep; case d.
rewrite oddg_cons /gface oddg_cons halfg_cons -/d -/q.
case/orP: Hqd; move/eqP=> Dq; rewrite {2}[d]Dq /q /d !consg_odd_half; auto.
Qed.

Definition refine_matte :=
  Matte refine_matte_ne cycle_refine_mring simple_refine_mring refine_mring_def.

Lemma mem_refine_matte : forall p, refine_matte p = m (halfg p).
Proof. exact: mem_refine_mdisk. Qed.

Lemma refine_matte_refined : forall r, refined_in (refine_matte : set _) r.
Proof. by move=> r p q _ Dq; rewrite !mem_refine_matte Dq. Qed.

End RefineMatte.

Section ExtendMatte.

Variable m : matte.

Definition ext_mdisk p : gpointseq := Adds (halfg p) m.

Lemma ext_mdisk_ne : forall p, 0 < size (ext_mdisk p).
Proof. done. Qed.

Definition ehex p := gchop_rect (gtouch (halfg p)) p.

Definition equad p := gchop_rect (ehex p) (gface p).

Lemma ehexF : forall p, sub_set (equad p) (ehex (gface p)).
Proof.
move=> p q; rewrite /equad /ehex halfg_face !mem_gchop_rect /setI.
by rewrite mem_gchop_rect /setI -andbA andbCA; case/andP.
Qed.

Lemma end0g_equad : forall p, negb (has (equad (gface p)) m) ->
  m (end0g p) = false.
Proof.
move=> p Hp; apply/idP => [Hmp]; case/idP: {Hp Hmp}(hasPn Hp _ Hmp).
rewrite /equad /ehex /gchop_rect !halfg_face !oddg_face /= /end0g.
case: (halfg p) => [x y] /=; rewrite !leq_decz_z !leq_z_incz.
case (oddg p); rewrite /= ?addz0 -?incz_def -?decz_def;
 do 2 rewrite ?leqzz ?leq_decz_z ?leq_z_incz //.
Qed.

Lemma mring_equad : forall p, negb (has (equad (gface p)) m) ->
  maps end0g (mring m) (end0g p) = false.
Proof.
move=> p Hp; apply/mapsP => [[q Hq Eqp]].
rewrite mring_def in Hq; move/andP: Hq => [Hq _]; case/idP: (hasPn Hp _ Hq).
rewrite /equad /ehex /gchop_rect !halfg_face !oddg_face /=.
rewrite /end0g addgC in Eqp; rewrite (monic_move (addg_inv _) Eqp) addgC -addgA.
case: (halfg p) => [x y] /=; rewrite !leq_decz_z !leq_z_incz.
case (oddg p); case (oddg q); rewrite /= ?addz0 -?incz_def -?decz_def;
 do 2 rewrite ?leqzz ?leq_decz_z ?leq_z_incz //.
Qed.

Section Extend1.

Variable p : gpoint.

Definition ext1_hex := m (halfg (gedge p)) && negb (has (ehex p) m).

Hypothesis HpE : ext1_hex.

Remark Extend1_HpF : mdisk m (halfg p) = false.
Proof.
apply/idP => [Hdp]; case/andP: HpE => _; case/hasP; exists (halfg p); auto.
by rewrite /ehex mem_gchop_rect /setI gtouch_refl gchop_halfg.
Qed.
Let HpF := Extend1_HpF.

Remark Extend1_Hp : mring m (gedge p).
Proof. by rewrite mring_def gedge2 HpF andbT; case/andP: HpE. Qed.
Let Hp := Extend1_Hp.

Remark Extend1_Hp1 : negb (has (equad (iter 3 gface p)) m).
Proof.
apply/hasP => [[q Hmq Hq]]; case/andP: HpE => _; case/hasP; exists q; first done.
by rewrite -[p]gface4; apply ehexF.
Qed.
Let Hp1 := Extend1_Hp1.

Remark Extend1_Hp2 : negb (has (equad (iter 4 gface p)) m).
Proof.
apply/hasP => [[q Hmq Hq]]; case/andP: HpE => _; case/hasP; exists q; first done.
by rewrite /iter gface4 /equad mem_gchop_rect in Hq; case/andP: Hq.
Qed.
Let Hp2 := Extend1_Hp2.

Definition ext1_mring : gpointseq :=
  let: RotToSpec _ c _ := rot_to Hp in cat (traject gface (gface p) 3) c.

Lemma cycle_ext1_mring : cycle mrlink ext1_mring.
Proof.
rewrite /ext1_mring; case: (rot_to Hp) (cycle_mring m) => [i c Dc].
rewrite -(cycle_rot i) {i}Dc !(cycle_path p) /=.
rewrite {1 3 4 5}/mrlink !end0g_face !set11 /= end0g_edge.
case: c => [|q c] /=; first by rewrite end1g_edge -{1}[p]gface4 end0g_face.
by rewrite {1 3}/mrlink end1g_edge -{2}[p]gface4 end0g_face.
Qed.

Lemma simple_ext1_mring : uniq (maps end0g ext1_mring).
Proof.
rewrite /ext1_mring; move: (mring_equad Hp2) (simple_mring m).
case: (rot_to Hp) => [i c Dc]; rewrite -(uniq_rot i) -(mem_rot i).
move: (mring_equad Hp1); rewrite -(mem_rot i) -maps_rot.
rewrite {i}Dc [uniq]lock /= !end0g_edge -!end0g_face -lock.
move: {c}(maps end0g c) (gface p) => c q /=; rewrite /setU1.
move/norP=> [Uqq1 Ucq1]; move/norP=> [Uqq2 Ucq2]; move/andP=> [Ucq Uc].
rewrite {}Uc (negbE Ucq) (negbE Ucq1) (negbE Ucq2) eqd_sym (negbE Uqq1).
rewrite eqd_sym (negbE Uqq2) /= orbF andbT end0g_face; apply/eqP.
by move/(monic_inj (addg_inv _)); case (oddg (gface q)).
Qed.

Remark Extend1_HpEF :
  all (fun q => negb (m (halfg (gedge q)))) (traject gface (gface p) 3).
Proof.
apply/allP => [q Hq]; apply/idP => [Hmq]; case/andP: HpE => _; case/hasP.
exists (halfg (gedge q)); first done; case/trajectP: Hq => [i Hi <-] {q Hmq}.
rewrite halfg_edge iter_f halfg_iter_face oddg_iter_face /ehex /gchop_rect.
case: (halfg p) => [x y]; rewrite /= ?leq_decz_z ?leq_z_incz.
case (oddg p); case: i Hi => [|[|[|i]]] //= _; rewrite ?addz0 -?incz_def;
 by rewrite -?decz_def ?leqzz ?leq_decz_z ?leq_z_incz ?leq_decz_incz.
Qed.
Let HpEF := Extend1_HpEF.

Lemma ext1_mring_def :
  ext1_mring
    =1 (fun q => ext_mdisk p (halfg q) && negb (ext_mdisk p (halfg (gedge q)))).
Proof.
move=> q; rewrite /ext1_mring; case: (rot_to Hp) => [i c Dc] /=.
case/and4P: HpEF => [Hep1 Hep2 Hep3 _].
rewrite /setU1; case Hq1: (gface p =d q).
  move/eqP: Hq1 => <- {q}/=; rewrite halfg_face set11 /=.
  by rewrite -halfg_face neq_halfg_edge /=.
case Hq2: (gface (gface p) =d q).
  move/eqP: Hq2 => <- {q Hq1}/=; rewrite !halfg_face set11 /=; symmetry.
  by rewrite -2!halfg_face neq_halfg_edge /=.
case Hq3: (gface (gface (gface p)) =d q).
  move/eqP: Hq3 => <- {q Hq1 Hq2}/=; rewrite !halfg_face set11 /=; symmetry.
  by rewrite -3!halfg_face neq_halfg_edge /=.
case Hcq: (mring m q).
  move: (Hcq) (maps_uniq (simple_mring m)) (Hcq) => Hdq.
  rewrite -(mem_rot i) -(uniq_rot i) Dc /= /setU1; case/andP.
  case Hpq: (gedge p =d q).
    by move/eqP: Hpq => <-; rewrite gedge2 set11 andbF; move/negPf.
  rewrite mring_def in Hdq; case/andP: Hdq => [Hdq Hdeq] _ _ /= Hcq'.
  rewrite {}Hcq' {}Hdq {Hdeq}(negbE Hdeq) orbT orbF; symmetry; apply/eqP => Dp.
  move: (Hcq); rewrite mring_def; case/nandP; left.
  case Heq1: (gedge (gface p) =d q); first by move/eqP: Heq1 => <-.
  case Heq2: (gedge (gface (gface p)) =d q); first by move/eqP: Heq2 => <-.
  case Heq3: (gedge (gface (gface (gface p))) =d q); first by move/eqP: Heq3 => <-.
  elimtype False; move: Hpq Heq1 Heq2 Heq3; rewrite !(monic2_eqd gedge2 gedge2).
  rewrite -[gedge q]consg_odd_half -{1}[p]consg_odd_half -Dp.
  rewrite {1 2 4}/gface !halfg_face !oddg_face /consg.
  set p2 := halfg p +g halfg p; rewrite -!(addgC p2) !(monic_eqd (addg_inv p2)).
  by case (oddg p); case (oddg (gedge q)).
move: (Hcq); rewrite -(mem_rot i) Dc /=; move/norP=> [Hpq Hcq'].
rewrite (negbE Hcq') /=; symmetry.
case Hpq': (halfg p =d halfg q).
  case Hq0: (p =d q).
    move: Hp; rewrite (eqP Hq0) mring_def; move/andP=> [Dp _].
    by rewrite Dp orbT andbF.
  move: Hq0 Hq1 Hq2 Hq3; rewrite -[p]consg_odd_half -[q]consg_odd_half (eqP Hpq').
  rewrite /gface !oddg_cons !halfg_cons /consg.
  set q2 := halfg q +g halfg q; rewrite -!(addgC q2) !(monic_eqd (addg_inv q2)).
  by case (oddg p); case (oddg q).
case: (halfg p =d halfg (gedge q)); first by rewrite andbF.
by rewrite /= -mring_def.
Qed.

Definition ext1_matte :=
  Matte (ext_mdisk_ne _) cycle_ext1_mring simple_ext1_mring ext1_mring_def.

End Extend1.

Section Extend2.

Variable p : gpoint.

Definition ext2_quad :=
  and3b (mdisk m (halfg (gedge p))) (mdisk m (halfg (gedge (gface p))))
        (negb (has (equad p) m)).

Hypothesis HpE : ext2_quad.

Remark Extend2_HpF : m (halfg p) = false.
Proof.
apply/idP => Hp; case/and3P: HpE => _ _; case/hasP; exists (halfg p); auto.
rewrite /equad /ehex /gchop_rect halfg_face oddg_face.
case: (halfg p) => [x y]; rewrite /= ?leq_decz_z ?leq_z_incz.
by case (oddg p); rewrite /= ?leq_decz_z ?leq_z_incz ?leqzz.
Qed.
Let HpF := Extend2_HpF.

Remark Extend2_Hp1 : negb (has (equad (iter 4 gface p)) m).
Proof. by rewrite /iter gface4; case/and3P: HpE. Qed.
Let Hp1 := Extend2_Hp1.

Remark Extend2_Hefp : mring m (gedge (gface p)).
Proof. by rewrite mring_def gedge2 halfg_face HpF andbT; case/and3P: HpE. Qed.
Let Hefp := Extend2_Hefp.

Remark Extend2_Hep : mring m (gedge p).
Proof. by rewrite mring_def gedge2 HpF andbT; case/andP: HpE. Qed.
Let Hep := Extend2_Hep.

Remark Extend2_Hp : {c : gpointseq & {i : nat |
  rot i (mring m) = Seq (gedge (gface p)) (gedge p) & c}}.
Proof.
case/rot_to: Hefp => [i [|p' c] Dp].
move: (cycle_mring m); rewrite -(cycle_rot i) Dp /= /mrlink.
  rewrite /end0g /end1g (monic_eqd (addg_inv _)) oddg_edge oddg_face.
  by case (oddg p).
exists c; exists i; rewrite Dp; do 2 congr Adds.
move: (cycle_mring m) Hep (simple_mring m).
rewrite -(cycle_rot i) -(mem_rot i) -(uniq_rot i) -maps_rot Dp /mrlink.
move/andP=> [Dp' _]; rewrite end1g_edge end0g_face in Dp'.
rewrite -(mem_rot 1) -(uniq_rot 1) -maps_rot rot1_adds /=.
case/setU1P=> // [Hp']; case/andP; case/mapsP; exists (gedge p); auto.
by rewrite end0g_edge (eqP Dp').
Qed.
Let Hp := Extend2_Hp.

Definition ext2_mring : gpointseq :=
  let: existS c _ := Hp in cat (traject gface (gface (gface p)) 2) c.

Lemma cycle_ext2_mring : cycle mrlink ext2_mring.
Proof.
rewrite /ext2_mring; case: Hp (cycle_mring m) => [c [i Dc]].
rewrite -(cycle_rot i) {i}Dc !(cycle_path p) /=.
rewrite {1 2 4 5}/mrlink end1g_edge !end0g_face !end0g_edge !set11 /=.
case: c => [|q c] /=; first by rewrite end1g_edge -{1}[p]gface4 end0g_face.
by rewrite {1 3}/mrlink end1g_edge -{2}[p]gface4 end0g_face.
Qed.

Lemma simple_ext2_mring : uniq (maps end0g ext2_mring).
Proof.
rewrite /ext2_mring -(uniq_rot 1).
case: Hp (mring_equad Hp1) (simple_mring m) => [c [i Dc]].
rewrite -(uniq_rot i) -(mem_rot i) -(uniq_rot 1) -(mem_rot 1) -!maps_rot.
rewrite {i}Dc [maps]lock /= -!lock !rot1_adds /= !maps_add_last.
by rewrite !end0g_edge !end0g_face; move/norP=> [_ ->]; case/andP.
Qed.

Remark Extend2_HpEF :
  all (fun q => negb (m (halfg (gedge q)))) (traject gface (gface (gface p)) 2).
Proof.
apply/allP => q Hq; apply/idP => Hmq; case/and3P: HpE => _ _; case/hasP.
exists (halfg (gedge q)); first done; case/trajectP: Hq => [i Hi <-] {q Hmq}.
rewrite halfg_edge !iter_f halfg_iter_face oddg_iter_face.
rewrite /equad /ehex /gchop_rect halfg_face oddg_face.
case: (halfg p) => [x y]; rewrite /= ?leq_decz_z ?leq_z_incz.
case (oddg p); rewrite /= ?leq_decz_z ?leq_z_incz;
 case: i Hi => [|[|i]] //= _; rewrite ?addz0 -?incz_def -?decz_def;
 by rewrite ?leqzz ?leq_decz_z ?leq_z_incz.
Qed.
Let HpEF := Extend2_HpEF.

Lemma ext2_mring_def :
 ext2_mring
   =1 (fun q => ext_mdisk p (halfg q) && negb (ext_mdisk p (halfg (gedge q)))).
Proof.
move=> q; rewrite /ext2_mring; case: Hp => [c [i Dc]] /=; rewrite /setU1.
case/and3P: HpEF => Hep2 Hep3 _.
case Hq2: (gface (gface p) =d q).
  move/eqP: Hq2 => <- {q}/=; rewrite !halfg_face set11 /=; symmetry.
  by rewrite -2!halfg_face neq_halfg_edge /=.
case Hq3: (gface (gface (gface p)) =d q).
  move/eqP: Hq3 => <- {q Hq2}/=; rewrite !halfg_face set11 /=; symmetry.
  by rewrite -3!halfg_face neq_halfg_edge /=.
case Hcq: (mring m q).
  move: (Hcq) (maps_uniq (simple_mring m)) (Hcq) => Hdq.
  rewrite -(mem_rot i) -(uniq_rot i) Dc /= /setU1; case/and3P; case/norP=> _.
  case Hepq: (gedge (gface p) =d q).
    by rewrite -(eqP Hepq) gedge2 halfg_face set11 andbF; move/negPf.
  case Hpq: (gedge p =d q).
    by rewrite -(eqP Hpq) gedge2 set11 andbF; clear; move/negPf.
  rewrite mring_def in Hdq; case/andP: Hdq => Hdq Hdeq _ _ _ /= ->.
  rewrite {}Hdq {Hdeq}(negbE Hdeq) orbT orbF; symmetry; apply/eqP => Dp.
  move: (Hcq); rewrite mring_def; case/nandP; left.
  case Heq2: (gedge (gface (gface p)) =d q); first by rewrite -(eqP Heq2).
  case Heq3: (gedge (gface (gface (gface p))) =d q); first by rewrite -(eqP Heq3).
  elimtype False; move: Hpq Hepq Heq2 Heq3; rewrite !(monic2_eqd gedge2 gedge2).
  rewrite -[gedge q]consg_odd_half -{1}[p]consg_odd_half -Dp.
  rewrite {1 2 4}/gface !halfg_face !oddg_face /consg.
  set p2 := halfg p +g halfg p; rewrite -!(addgC p2) !(monic_eqd (addg_inv p2)).
  by case (oddg p); case (oddg (gedge q)).
move: (Hcq); rewrite -(mem_rot i) Dc /=.
case/norP=> Hpq; case/norP=> Hpeq Hcq'; rewrite (negbE Hcq') /=; symmetry.
case Hpq': (halfg p =d halfg q).
  case Hq0: (p =d q).
    by move: Hep; rewrite (eqP Hq0) mring_def; case/andP=> ->; rewrite orbT andbF.
  case Hq1: (gface p =d q).
    by move: Hefp; rewrite (eqP Hq1) mring_def; case/andP=> ->; rewrite orbT andbF.
  move: Hq0 Hq1 Hq2 Hq3; rewrite -[p]consg_odd_half -[q]consg_odd_half (eqP Hpq').
  rewrite /gface !oddg_cons !halfg_cons /consg.
  set q2 := halfg q +g halfg q; rewrite -!(addgC q2) !(monic_eqd (addg_inv q2)).
  by case (oddg p); case (oddg q).
case: (halfg p =d halfg (gedge q)); first by rewrite andbF.
by rewrite /= -mring_def.
Qed.

Definition ext2_matte :=
  Matte (ext_mdisk_ne _) cycle_ext2_mring simple_ext2_mring ext2_mring_def.

End Extend2.

End ExtendMatte.

Section MatteExtension.

Variable m : matte.

Inductive matte_extension : matte -> Set :=
  | Mext_nil : matte_extension m
  | Mext_add : forall (p : gpoint) (xm' xm : matte),
      matte_extension xm' -> mring xm' (gedge p) -> xm =1 ext_mdisk xm' p ->
    matte_extension xm.

Implicit Arguments Mext_add [].

Lemma mem_extension : forall xm, matte_extension xm -> sub_set m xm.
Proof.
move=> xm; elim: xm / => [|p xm' xm _ Hrec _ Dxm] q Hq //.
by rewrite Dxm /= setU1r ?Hrec.
Qed.

Inductive extends_in (r : grect) (p : gpoint) : Set :=
    ExtendIn (xm : matte)
      (_ : matte_extension xm) (_ : sub_set xm (setU r m)) (_ : xm p).

Lemma extends_in_sub : forall r1 r2 : grect, sub_set r1 r2 ->
  forall p, extends_in r1 p -> extends_in r2 p.
Proof.
move=> r1 r2 Hr12 p [xm Hxm Hxmr Hp]; exists xm; auto.
by move=> q Hq; apply/orP; case/orP: (Hxmr _ Hq); auto.
Qed.

Definition inset r p := sub_grect (gtouch p) r.

Lemma refined_extends_in : forall r : grect,
   refined_in (m : set _) r -> has r m ->
  forall p, inset r p -> extends_in r p.
Proof.
move=> r Hr0m Hrm p Hirp; have Hrr0: sub_set r r by move.
have Hr0r: sub_set (setI r m) r by move=> q; case/andP.
have Hr0p: sub_set (gtouch p) r by apply mem_sub_grect.
have Hrp: r p by apply Hr0p; exact: gtouch_refl.
move: {-1}r {1 3 4 5 8 11}r p (ltnSn (garea r)) Hrm Hrp Hrr0 Hr0r Hr0p Hr0m {Hirp}.
elim: {r}(S (garea r)) => // [n Hrec] r0 r p Hn Hrm Hrp Hrr0 Hr0r Hr0p Hr0m.
set G := extends_in r p; rewrite ltnS in Hn.
case Hmp: (mdisk m p).
  by exists m; try first [ left | move=> q Hq; rewrite /setU Hq orbT ].
have Hxm1: forall p', halfg p' = p -> negb (has (ehex p') m) ->
    extends_in (gchop_rect r (gedge p')) (halfg (gedge p')) -> G.
  move=> p' Dp' Hep' [xm Hxm Hxmr' Hxmp'].
  have Hp': ext1_hex xm p'.
    rewrite /ext1_hex Hxmp'; apply/hasPn => q Hq.
    case/orP: {Hq}(Hxmr' _ Hq); last by move=> *; apply (hasPn Hep').
    rewrite /ehex !mem_gchop_rect /setI gchop_edge.
    by case/andP=> *; apply/nandP; right.
  exists (ext1_matte Hp'); rewrite /= ?Dp' ?setU11 //.
    right with p' xm; rewrite // mring_def gedge2 Dp' Hxmp'.
    apply/idP; move/Hxmr'; rewrite /setU Hmp mem_gchop_rect /setI gchop_edge.
    by rewrite -Dp' /setC gchop_halfg andbF.
  move=> q; case/setU1P=> [<-|Hq]; first by rewrite /setU Hrp.
  apply/orP; case/orP: (Hxmr' _ Hq); try (rewrite mem_gchop_rect; case/andP); auto.
have Hcut: forall p', halfg p' = p -> has (setD r0 (gchop1 p')) m -> G.
  move=> p' Dp' Hr0p'; set r0' := gchop1_rect r0 p'.
  case Hr0': (has r0' m).
    set r' := gchop1_rect r p'.
    have Hr'r: sub_set r' r by exact: gchop_rect_sub.
    apply: (extends_in_sub Hr'r); apply (Hrec r0').
    - case/hasP: Hr0p' => [q Hmq]; move/andP=> [Hp'q Hr0q].
      apply: leq_trans Hn; apply: ((ltn_garea_sub_rect Hr'r) q).
      by rewrite /setD /r' mem_gchop1_rect /setI (negbE Hp'q) Hr0r //= /setI Hr0q.
    - case/hasP: Hr0' => [q Hmq]; rewrite /r0' mem_gchop1_rect.
      move/andP=> [Hr0q Hp'q]; apply/hasP; exists q; first done.
      by rewrite /r' mem_gchop1_rect /setI Hp'q Hr0r //= /setI Hr0q.
    - by rewrite /r' mem_gchop1_rect /setI Hrp gchop_chop1 // -Dp' gchop_halfg.
    - move=> q; rewrite /r' /r0' !mem_gchop1_rect /setI.
      by case/andP=> *; apply/andP; auto.
    - move=> q; rewrite /r' /r0' /setI !mem_gchop1_rect /setI -andbA andbCA.
      by case/andP=> *; apply/andP; auto.
    - move=> q Hq; rewrite /r0' mem_gchop1_rect; apply/andP; split; auto.
      by move: Hq; rewrite -Dp' gtouch_chop1; case/andP.
    move=> q q' Hq; exact (Hr0m q q' (gchop_rect_sub Hq)).
  apply (Hxm1 _ Dp').
    apply/hasP => [[q Hmq]]; rewrite /ehex mem_gchop_rect Dp'.
    move/andP=> [Hpq _]; case/hasP: Hr0'; exists q; first done.
    rewrite /r0' mem_gchop1_rect /setI Hr0p //=.
    by move: Hpq; rewrite -Dp' gtouch_chop1; case/andP.
  set r' := gchop_rect r (gedge p').
  have Hr'r: sub_set r' r by exact: gchop_rect_sub.
  have Hr'm: has r' m.
    case/hasP: Hr0p' => [q Hmq]; move/andP=> [Hp'q1 Hr0q]; apply/hasP.
    exists q; rewrite // /r' mem_gchop_rect /setI Hr0r /setI ?Hr0q // gchop_edge.
    by apply/idP => Hp'q; case/idP: Hp'q1; apply gchop_chop1.
  apply (Hrec r0); auto.
  - apply: leq_trans Hn; apply ((ltn_garea_sub_rect Hr'r) p); rewrite /setD /r'.
    by rewrite mem_gchop_rect /setI Hrp gchop_edge /setC -Dp' gchop_halfg.
  - by case/hasP: Hr'm => q _ Hq; apply: gchop_rect_edge Hq; rewrite gedge2 Dp'.
  - by move; auto.
  - move=> q Hq; rewrite /r' mem_gchop_rect /setI Hr0r //= gchop_edge.
    apply/idP => [Hp'q]; case/andP: Hq => [Hr0q Hmq]; case/hasP: Hr0'.
    by exists q; rewrite // /r0' mem_gchop1_rect /setI Hr0q; apply: gchop_chop1.
  set p2 := gedge (gface (gface (gedge p'))).
  have Hp2: gchop_rect r0 p2 (halfg p2).
    case/hasP: Hr0p' => [q Hmq Hq0]; apply gchop_rect_edge with q.
      by apply Hr0p; rewrite /p2 gedge2 !halfg_face -Dp' gtouch_edge.
    by rewrite mem_gchop_rect /p2 /setI gchop_edge andbC.
  rewrite mem_gchop_rect /setI gchop_halfg andbT in Hp2.
  have Hp1: r0 (halfg (gedge (gface p'))).
    by apply Hr0p; rewrite -Dp' -halfg_face gtouch_edge.
  have Hp3: r0 (halfg (gedge (gface (gface (gface p'))))).
    by apply Hr0p; rewrite -Dp' -3!halfg_face gtouch_edge.
  apply mem_sub_grect; move: Hp1 Hp2 Hp3.
  rewrite /p2 !halfg_edge !oddg_face !halfg_face !oddg_edge halfg_edge ccw4 Dp'.
  rewrite -!addgA; case: (r0) (p) => [x0 x1 y0 y1] [x y].
  case (oddg p'); case/and4P=> [Hx01 Hx11 Hy01 Hy11];
   case/and4P=> [Hx02 Hx12 Hy02 Hy12]; case/and4P=> [Hx03 Hx13 Hy03 Hy13];
   by rewrite /= ?incz_def ?decz_def -!addzA; apply/and4P; split.
pose np q := consg (ccw (ccw (ccw (oddg q)))) q.
have Enph: forall q, halfg (np q) = q by move=> *; rewrite /np halfg_cons.
have Enpo: forall q, oddg (np q) = ccw (ccw (ccw (oddg q))).
  by move=> *; rewrite /np oddg_cons.
have EnpE: forall q, halfg (gedge (np q)) = gnode q.
  by move=> q; rewrite halfg_edge /gnode /np halfg_cons oddg_cons; case (oddg q).
have DnpN: forall q, np (gnode q) = gedge (gnode (gedge (np q))).
  move=> q; apply (monic_move gmonicF).
  by rewrite /gface Enph Enpo oddg_node -Enpo -oddg_edge -EnpE consg_odd_half.
have Hnp4: forall q, r0 q -> has (equad (np q)) m -> m q.
  move=> q0 Hr0q0; move/hasP=> [q Hmq Hq]; rewrite -(Hr0m _ q Hr0q0) //.
  apply: eqP; move: Hq {Hmq}; rewrite /equad /ehex /gchop_rect halfg_face.
  rewrite oddg_face Enph Enpo ccw4 -{1 2 4}[q0]consg_odd_half /consg addgC.
  case: (halfg q0) q => [x y] [x' y']; rewrite eqd_sym /eqd /=.
  rewrite !eqz_leq -!andbA !leqz_halfl !leqz_halfr.
  case (oddg q0);
    by rewrite /= ?addz0 ?addn0 ?leq_decz_z ?leq_z_incz -?incz_def ?decz_inc.
have Eq2x2: forall q q', ehex q q' \/ ehex (gface (gedge (gface q))) q' ->
                        equad q q' \/ equad (gedge (gface q)) q'.
  have Ec1c: forall q q' b, gchop1 q q' && b && gchop q q' = gchop q q' && b.
    move=> q q' b; case Hqq': (gchop q q'); last by rewrite andbF.
    by rewrite andbT (gchop_chop1 Hqq').
  move=> q q'; repeat rewrite /equad /ehex mem_gchop_rect /setI.
  rewrite !gtouch_chop1 /all /traject !andbT gface4 !Ec1c.
  rewrite {-12 13}[andb]lock andbCA -!lock Ec1c gchopFEF.
  case (gchop q q'); rewrite // !andTb Ec1c.
  set q2q' := gchop1 (gface (gface q)) q'.
  have <-: q2q' = gchop1 (gface (gface (gface (gedge (gface q))))) q'.
    rewrite /gchop1 -gchopFEF -!gnode_face !gface4; congr gchop; congr gface.
    by symmetry; apply: (monic_move gmonicN); rewrite gnode4.
  case: q2q'; rewrite ?andbF // !andTb !andbT gchop_edge /setC.
  case Hqq': (gchop (gface q) q').
    by case; case/andP; left; rewrite // -[gface q]gedge2; apply: gchop_chop1.
  by case; case/andP; right; first exact: gchop_chop1.
have Hr0np: r0 (gnode p) by apply Hr0p; rewrite -EnpE -{1}[p]Enph gtouch_edge.
have EnpFE: forall q, np (gface (gedge q)) = gedge (gface (np q)).
  by move=> q; rewrite -{2}[q]gmonicE DnpN gmonicN gedge2.
have Hr0fep: r0 (gface (gedge p)).
  apply Hr0p; rewrite -[gface (gedge p)]Enph -[np (gface (gedge p))]gedge2.
  by rewrite -{1}[p]gmonicE -EnpE gtouch_edge.
case Hqpm: (has (equad (np p)) m); first by rewrite Hnp4 ?Hrr0 in Hmp.
case Hhpm: (has (ehex (np p)) m).
  have Hmefp: m (halfg (gedge (gface (np p)))).
    rewrite -EnpFE Enph Hnp4 //.
    case/hasP: Hhpm => [q Hmq Hq]; apply/hasP; exists q; first done.
    case: (Eq2x2 (np p) q) => //; rewrite -?EnpFE //; first by left.
    by move=> *; case/hasP: Hqpm; exists q.
  case Hhfpm: (has (ehex (gface (np p))) m).
    have Hmep: m (halfg (gedge (np p))).
      rewrite EnpE Hnp4 //; case/hasP: Hhfpm => [q Hmq Hq].
      case: (Eq2x2 (np (gnode p)) q); try rewrite -EnpFE gmonicN; auto.
        by move=> *; apply/hasP; exists q.
      by move=> *; case/hasP: Hqpm; exists q.
    have Hext: ext2_quad m (np p) by rewrite /ext2_quad Hmep Hmefp Hqpm.
    exists (ext2_matte Hext); rewrite /= ?Enph ?setU11 //.
      right with (np p) m; [ left | idtac | split ].
      by rewrite mring_def gedge2 Enph Hmp Hmep.
    by move=> q; case/setU1P=> [<-|Hq]; apply/orP; auto.
  apply: (Hxm1 (gface (np p))); rewrite ?Hhfpm ?halfg_face //.
  exists m; [ left | move=> q Hq; apply/orP; auto | done ].
case Hpm: (negb (has (gtouch p) m)).
  pose hrp i := has (setD r0 (gchop1 (iter i gface (np p)))) m.
  suffice: {i : nat | hrp i} by case=> i; apply: Hcut; rewrite halfg_iter_face.
  case Hh0: (hrp 0); first by exists 0.
  case Hh1: (hrp 1); first by exists 1.
  case Hh2: (hrp 2); first by exists 2.
  case Hh3: (hrp 3); first by exists 3.
  case/hasP: Hpm; case/hasP: Hrm => [q Hmq Hq]; exists q; first done.
  rewrite -[p]Enph gtouch_chop1; apply/allP => p'; move/trajectP=> [i Hi <-].
  case Hhi: (hrp i); first by case/negPf: Hhi; case: i Hi => [|[|[|[|i]]]] //.
  by move: (elimFn hasPn Hhi _ Hmq); rewrite /setD Hrr0 //= andbT negb_elim.
apply: (Hxm1 (np p)); rewrite ?Hhpm // EnpE.
case Hmnp: (m (gnode p)).
  by exists m; try first [ left | move=> q Hq; rewrite /setU Hq orbT ].
case Hqnpm: (has (equad (np (gnode p))) m); first by rewrite Hnp4 in Hmnp.
have Hr0n2p: r0 (gnode (gnode p)).
  rewrite {1}/gnode oddg_node /gnode -!addgA; apply Hr0p; case: {1 2}p => [x y].
  by case (oddg p); rewrite /= -?incz_def -?decz_def !leqzz !leq_decz_incz.
have Hmn2p: m (gnode (gnode p)).
  apply: Hnp4 => //; apply/hasP; move/hasP: Hpm => [q Hmq Hq]; exists q; auto.
  have Hnpq: gchop (gface (np (gnode p))) q.
    rewrite DnpN gmonicN gchop_edge; apply/idP => [Hpq]; case/hasP: Hhpm.
    by exists q; last by rewrite /ehex mem_gchop_rect Enph /setI Hq.
  case: (Eq2x2 (np (gnode (gnode p))) q) => //.
    right; rewrite /ehex -EnpFE gmonicN mem_gchop_rect /setI Hnpq halfg_face Enph.
    move: Hq Hnpq; rewrite /gchop halfg_face oddg_face Enph Enpo oddg_node ccw4.
    rewrite /gnode; case: (p) (q) (oddg p) => [x y] [x' y'] /=.
    case; rewrite /= -?incz_def -?decz_def ?addz0 ?decz_inc ?incz_dec andbT;
    rewrite !leqz_dec_inc ?leqz_inc_dec; case/and4P=> *; apply/and4P; split;
    by rewrite // leqz_dec ?decz_inc; apply/orP; right.
  by rewrite -EnpFE gmonicN; move=> *; case/hasP: Hqnpm; exists q.
have Hrnp: r (gnode p).
  have Hrn2p: r (gnode (gnode p)) by apply Hr0r; rewrite /setI Hr0n2p.
  move: Hrn2p; do 3 rewrite {1}/gnode ?oddg_node; rewrite -!addgA.
  case: (r) (p) (oddg p) Hrp => [x0 x1 y0 y1] [x y].
  by case; rewrite /= -?incz_def -?decz_def ?decz_inc ?incz_dec ?addz0;
     move/and4P=> [Hx0 Hx1 Hy0 Hy1]; case/and4P=> *; apply/and4P; split.
have Hext: ext1_hex m (np (gnode p)).
  rewrite /ext1_hex EnpE Hmn2p; apply/hasP => [[q Hmq Hq]].
  case: (Eq2x2 (np (gnode p)) q); rewrite -?EnpFE ?gmonicN; auto.
    by move=> *; case/hasP: Hqnpm; exists q.
  by move=> *; case/hasP: Hqpm; exists q.
exists (ext1_matte Hext); rewrite /= ?Enph ?setU11 //.
  right with (np (gnode p)) m; try by try left.
  by rewrite mring_def EnpE Hmn2p gedge2 Enph Hmnp.
move=> q /=; case/setU1P=> [<-|Hq]; apply/orP; [ left | by right ].
rewrite mem_gchop_rect /setI Hrnp /gchop EnpE oddg_edge Enpo ccw4.
by case: (gnode p) (oddg p) => [x y]; case; apply: leqzz.
Qed.

(* The refined_extends_in lemma is used directly to show that the union of a   *)
(* set of extension mattes included in a region is closed (relatively to the   *)
(* region). To show that this union is open we will need the MatteOrder lemmas *)
(* below. We use the refined_extend_meet lemma to extend the mattes of         *)
(* adjacent regions so that their contours have a common edge.                 *)

Lemma extend_meet : forall (m2 : matte) (r : grect),
   refined_in (m : set _) r -> has r m -> has (inset r) m2 -> negb (has m m2) ->
 {xm : matte | sub_set m xm /\ sub_set xm (setD (setU r m) m2) &
               has (fun q => mring m2 (gedge q)) (mring xm)}.
Proof.
move=> m2 r Hmr Hrm Hrm2 Hmm2; rewrite has_sym in Hmm2.
have [p Hm2p Hp]: {p : gpoint | m2 p &  inset r p}.
  exists (sub neg1g m2 (find (inset r) m2)); last by apply: sub_find.
  by apply: mem_sub; rewrite -has_find.
  case: (refined_extends_in Hmr Hrm Hp) => [xm Hxm Hxmr Hxmp].
have Hxm2: has m2 xm by apply/hasP; exists p.
elim: {xm}Hxm Hxmr Hxm2 {p Hm2p Hrm2 Hp Hxmp}; first by rewrite (negbE Hmm2).
move=> p xm' xm Hxm' Hrec Hxm'p Dxm Hxmr Hxm2.
have Hxm'r: sub_set xm' (setU r m).
  by move=> q Hq; apply Hxmr; rewrite Dxm /= /setU1 Hq orbT.
case Hxm'2: (has m2 xm'); [ eauto | exists xm' ].
  split; [ by apply mem_extension | move=> q Hq; rewrite /setD andbC Hxm'r //= ].
  by apply (elimFn hasPn Hxm'2).
apply/hasP; exists (gedge p); rewrite // gedge2 mring_def; apply/andP; split.
  apply/idPn => Hm2p; case/hasPn: Hxm2; move=> q; rewrite Dxm /=.
  by case/setU1P=> [<-|Hq] //; apply (elimFn hasPn Hxm'2).
by apply (elimFn hasPn Hxm'2); rewrite mring_def in Hxm'p; case/andP: Hxm'p.
Qed.

End MatteExtension.

Section MatteOrder.

Definition matte_order (m : matte) p : nat :=
  let m' := setC m in
  double (m' (p +g oppg Gb01) + m' (p +g oppg Gb10))
       + (m' (p +g oppg Gb11) + m' (p +g oppg Gb00)).

Lemma zspan_decz_z : forall x, zspan (decz x) x = Seq (decz x) x.
Proof.
move=> x; rewrite /zspan /zwidth {2}(decz_def x) -subz_sub subzz /=.
by rewrite incz_dec.
Qed.

Definition ltouch p := let: Gpoint mx my := p in Grect (decz mx) mx (decz my) my.

Lemma matte_order0 : forall m p, matte_order m p = 0 -> sub_set (ltouch p) m.
Proof.
move=> m p; move/(introT eqP); rewrite /matte_order double_addnn !eqn_add0 andbb.
have Em': (fun q => (setC m q : nat) =d 0) =1 m by rewrite /setC /eqfun; case/m.
case: p => [x y] Hp q; rewrite -mem_enum_grect /= !zspan_decz_z /=.
rewrite !Em' /= !addz0 -!decz_def -!andbA in Hp.
by case/and4P: Hp => [Hp01 Hp10 Hp11 Hp00]; do 4 case/setU1P=> [<-|] //.
Qed.

Definition inset2 r p := inset r p && inset r (p +g neg1g).

Lemma inset2_refine : forall r p, inset r (halfg p) -> inset2 (refine_rect r) p.
Proof.
move=> [x0 x1 y0 y1] [x y]; rewrite /inset2 /inset /= -?decz_def.
rewrite !leqz_inc2 -2!leqz_inc_dec !leqz_halfr 4!incz_def -!addzA.
rewrite -!(addzCA x0) -!(addzCA y0) !addzA -!incz_def 6!leqz_inc_dec !leqz_halfl.
rewrite 2!incz_def (decz_def x1) (decz_def y1) -!addzA !addz0.
rewrite -!(addzC x1) -!(addzC y1) !addzA -?decz_def.
move/and4P=> [Hx0 Hx1 Hy0 Hy1]; rewrite Hx0 Hy0 leqz_dec Hx0 leqz_dec Hx1.
rewrite leqz_dec Hy0 leqz_dec Hy1 2!leqz_dec leqz_dec2 Hx1.
by rewrite 2!leqz_dec leqz_dec2 Hy1 !orbT.
Qed.

Lemma refine_matte_order : forall (m : matte) r p,
   m (halfg p) -> inset r (halfg p) -> 0 < matte_order m (halfg p) ->
 {xm : matte | sub_set (fun q => m (halfg q)) xm /\
               sub_set xm (fun q => setU r m (halfg q)) &
             matte_order xm p < matte_order m (halfg p)}.
Proof.
move=> m r p Hmp Hrp; pose dp (d : gbits) :=  p +g oppg d.
have Hdp: forall d,
    {xm : matte | sub_set (fun q => m (halfg q)) xm /\
                  sub_set xm (fun q => setU r m (halfg q)) &
       forall d' : gbits,
       xm (p +g oppg d') = or3b (d =d d') (m (halfg (dp d'))) (xm (dp d'))}.
  pose r' := refine_rect r; pose m' := refine_matte m.
  have Hr'p: forall d, inset r' (dp d).
    move=> d; case/andP: (inset2_refine Hrp); rewrite -/r' {}/dp {Hmp Hrp}.
    case: p r' => [x y] [x0 x1 y0 y1].
    rewrite /inset /= -?decz_def ?incz_dec.
    move/and4P=> [Hx0 Hx1 Hy0 Hy1]; move/and4P=> [Hx0' Hx1' Hy0' Hy1'].
    case: d;
      by rewrite /= -?decz_def -?incz_def ?incz_dec ?addz0; apply/and4P; split.
  have Hm'r': refined_in (m' : set _) r' by exact: refine_matte_refined.
  have Hr'm': has r' m'.
    apply/hasP; exists (dp Gb00); first by rewrite /m' mem_refine_matte /dp addg0.
    apply (mem_sub_grect (Hr'p Gb00)); exact: gtouch_refl.
  move=> d; case: (refined_extends_in Hm'r' Hr'm' (Hr'p d)) => [xm Hxm Hxmr' Hxmd].
  exists xm.
    split; move=> q Hq.
      by apply (mem_extension Hxm); rewrite /m' mem_refine_matte.
    apply/orP; case/orP: (Hxmr' _ Hq).
      by rewrite /r' mem_refine_rect; left.
    by rewrite /m' mem_refine_matte; right.
  move=> d'; rewrite -/(dp d') -mem_refine_matte -/m'.
  case: (d =P d') => [<-|_]; first by rewrite Hxmd orbT.
  by case Hd': (m' (dp d')); first by rewrite (mem_extension Hxm).
have leq_norb: forall b b', negb (b || b') <= negb b by do 2 case.
have Edp: forall d, halfg (dp d) = halfg p +g halfg (oddg p +g oppg d).
  by move=> d; rewrite /dp addgC halfg_add addgC; congr addg; rewrite addgC.
case Dp: (oddg p) Edp => [|||] Edp.
- move=> Hmp0; pose dhp d := negb (m (halfg p +g oppg d)).
  have [d Dd Hd]: {d : gbits | setC1 d Gb00 &  dhp d}.
    move: Hmp0; rewrite /matte_order /setC addg0 Hmp.
    rewrite -/(dhp Gb01) -/(dhp Gb10) -/(dhp Gb11).
    case H01: (dhp Gb01); first by exists Gb01.
    case H10: (dhp Gb10); first by exists Gb10.
    by case H11: (dhp Gb11); first by exists Gb11.
  rewrite {}/dhp in Hd; case: (Hdp d) => [xm Hxm Dxm]; exists xm; first done.
  rewrite /matte_order /setC !Dxm !Edp !addg0 Hmp !addn0.
  by case: (d) Dd Hd => [|||] //= _ Hd;
    rewrite (negbE Hd) /= ?addn1 ?add1n ?doubleS ?addSn ltnS ?addn0 ?add0n;
    try apply leqW; try apply leq_add2; rewrite ?leq_double; try apply leq_add2.
- case: (Hdp Gb01) => [xm Hxm Dxm] Hmp0; exists xm; first done.
  rewrite {1}/matte_order /setC !Dxm !Edp !addg0 Hmp /= add0n addn0.
  case Hm01: (m _) => //.
  by rewrite /matte_order /= /setC Hm01 /= add1n doubleS; case (xm (dp Gb11)).
- case: (Hdp Gb00) => [xm Hxm Dxm] Hmp0; exists xm; first done.
  by rewrite {1}/matte_order /setC !Dxm !Edp !addg0 Hmp.
case: (Hdp Gb10) => [xm Hxm Dxm] Hmp0; exists xm; first done.
rewrite {1}/matte_order /setC !Dxm !Edp !addg0 Hmp /= add0n addn0.
case Hm01: (m _) => //.
by rewrite /matte_order /= /setC Hm01 /= addn1 doubleS; case (xm (dp Gb11)).
Qed.

End MatteOrder.

Set Strict Implicit.
Unset Implicit Arguments.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ]
      as defined abstractly in CyclicAxioms. *)

(** Even if the construction provided here is not reused for building
  the efficient arbitrary precision numbers, it provides a simple
  implementation of CyclicAxioms, hence ensuring its coherence. *)

Set Implicit Arguments.

Require Import Bool.
Require Import ZArith.
Require Import Znumtheory.
Require Import Zpow_facts.
Require Import DoubleType.
Require Import CyclicAxioms.

Local Open Scope Z_scope.

Section ZModulo.

 Variable digits : positive.
 Hypothesis digits_ne_1 : digits <> 1%positive.

 Definition wB := base digits.

 Definition t := Z.
 Definition zdigits := Zpos digits.
 Definition to_Z x := x mod wB.

 Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).

 Notation "[+| c |]" :=
   (interp_carry 1 wB to_Z c)  (at level 0, c at level 99).

 Notation "[-| c |]" :=
   (interp_carry (-1) wB to_Z c)  (at level 0, c at level 99).

 Notation "[|| x ||]" :=
   (zn2z_to_Z wB to_Z x)  (at level 0, x at level 99).

 Lemma spec_more_than_1_digit: 1 < Zpos digits.
 Proof.
  generalize digits_ne_1; destruct digits; red; auto.
  destruct 1; auto.
 Qed.
 Let digits_gt_1 := spec_more_than_1_digit.

 Lemma wB_pos : wB > 0.
 Proof.
  apply Z.lt_gt.
  unfold wB, base; auto with zarith.
 Qed.
 Hint Resolve wB_pos.

 Lemma spec_to_Z_1 : forall x, 0 <= [|x|].
 Proof.
  unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
 Qed.

 Lemma spec_to_Z_2 : forall x, [|x|] < wB.
 Proof.
  unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
 Qed.
 Hint Resolve spec_to_Z_1 spec_to_Z_2.

 Lemma spec_to_Z : forall x, 0 <= [|x|] < wB.
 Proof.
  auto.
 Qed.

 Definition of_pos x :=
   let (q,r) := Z.pos_div_eucl x wB in (N_of_Z q, r).

 Lemma spec_of_pos : forall p,
   Zpos p = (Z.of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|].
 Proof.
  intros; unfold of_pos; simpl.
  generalize (Z_div_mod_POS wB wB_pos p).
  destruct (Z.pos_div_eucl p wB); simpl; destruct 1.
  unfold to_Z; rewrite Zmod_small; auto.
  assert (0 <= z).
   replace z with (Zpos p / wB) by
    (symmetry; apply Zdiv_unique with z0; auto).
   apply Z_div_pos; auto with zarith.
  replace (Z.of_N (N_of_Z z)) with z by
    (destruct z; simpl; auto; elim H1; auto).
  rewrite Z.mul_comm; auto.
 Qed.

 Lemma spec_zdigits : [|zdigits|] = Zpos digits.
 Proof.
  unfold to_Z, zdigits.
  apply Zmod_small.
  unfold wB, base.
  split; auto with zarith.
  apply Zpower2_lt_lin; auto with zarith.
 Qed.

 Definition zero := 0.
 Definition one := 1.
 Definition minus_one := wB - 1.

 Lemma spec_0 : [|zero|] = 0.
 Proof.
  unfold to_Z, zero.
  apply Zmod_small; generalize wB_pos; auto with zarith.
 Qed.

 Lemma spec_1 : [|one|] = 1.
 Proof.
  unfold to_Z, one.
  apply Zmod_small; split; auto with zarith.
  unfold wB, base.
  apply Z.lt_trans with (Zpos digits); auto.
  apply Zpower2_lt_lin; auto with zarith.
 Qed.

 Lemma spec_Bm1 : [|minus_one|] = wB - 1.
 Proof.
  unfold to_Z, minus_one.
  apply Zmod_small; split; auto with zarith.
  unfold wB, base.
  cut (1 <= 2 ^ Zpos digits); auto with zarith.
  apply Z.le_trans with (Zpos digits); auto with zarith.
  apply Zpower2_le_lin; auto with zarith.
 Qed.

 Definition compare x y := Z.compare [|x|] [|y|].

 Lemma spec_compare : forall x y,
   compare x y = Z.compare [|x|] [|y|].
 Proof. reflexivity. Qed.

 Definition eq0 x :=
   match [|x|] with Z0 => true | _ => false end.

 Lemma spec_eq0 : forall x, eq0 x = true -> [|x|] = 0.
 Proof.
  unfold eq0; intros; now destruct [|x|].
 Qed.

 Definition opp_c x :=
   if eq0 x then C0 0 else C1 (- x).
 Definition opp x := - x.
 Definition opp_carry x := - x - 1.

 Lemma spec_opp_c : forall x, [-|opp_c x|] = -[|x|].
 Proof.
 intros; unfold opp_c, to_Z; auto.
 case_eq (eq0 x); intros; unfold interp_carry.
 fold [|x|]; rewrite (spec_eq0 x H); auto.
 assert (x mod wB <> 0).
  unfold eq0, to_Z in H.
  intro H0; rewrite H0 in H; discriminate.
 rewrite Z_mod_nz_opp_full; auto with zarith.
 Qed.

 Lemma spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB.
 Proof.
 intros; unfold opp, to_Z; auto.
 change ((- x) mod wB = (0 - (x mod wB)) mod wB).
 rewrite Zminus_mod_idemp_r; simpl; auto.
 Qed.

 Lemma spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1.
 Proof.
 intros; unfold opp_carry, to_Z; auto.
 replace (- x - 1) with (- 1 - x) by omega.
 rewrite <- Zminus_mod_idemp_r.
 replace ( -1 - x mod wB) with (0 + ( -1 - x mod wB)) by omega.
 rewrite <- (Z_mod_same_full wB).
 rewrite Zplus_mod_idemp_l.
 replace (wB + (-1 - x mod wB)) with (wB - x mod wB -1) by omega.
 apply Zmod_small.
 generalize (Z_mod_lt x wB wB_pos); omega.
 Qed.

 Definition succ_c x :=
  let y := Z.succ x in
  if eq0 y then C1 0 else C0 y.

 Definition add_c x y :=
  let z := [|x|] + [|y|] in
  if Z_lt_le_dec z wB then C0 z else C1 (z-wB).

 Definition add_carry_c x y :=
  let z := [|x|]+[|y|]+1 in
  if Z_lt_le_dec z wB then C0 z else C1 (z-wB).

 Definition succ := Z.succ.
 Definition add := Z.add.
 Definition add_carry x y := x + y + 1.

 Lemma Zmod_equal :
  forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z.
 Proof.
 intros.
 generalize (Z_div_mod_eq (x-y) z H); rewrite H0, Z.add_0_r.
 remember ((x-y)/z) as k.
 rewrite Z.sub_move_r, Z.add_comm, Z.mul_comm. intros ->.
 now apply Z_mod_plus.
 Qed.

 Lemma spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1.
 Proof.
 intros; unfold succ_c, to_Z, Z.succ.
 case_eq (eq0 (x+1)); intros; unfold interp_carry.

 rewrite Z.mul_1_l.
 replace (wB + 0 mod wB) with wB by auto with zarith.
 symmetry. rewrite Z.add_move_r.
 assert ((x+1) mod wB = 0) by (apply spec_eq0; auto).
 replace (wB-1) with ((wB-1) mod wB) by
  (apply Zmod_small; generalize wB_pos; omega).
 rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto.
 apply Zmod_equal; auto.

 assert ((x+1) mod wB <> 0).
  unfold eq0, to_Z in *; now destruct ((x+1) mod wB).
 assert (x mod wB + 1 <> wB).
  contradict H0.
  rewrite Z.add_move_r in H0; simpl in H0.
  rewrite <- Zplus_mod_idemp_l; rewrite H0.
  replace (wB-1+1) with wB; auto with zarith; apply Z_mod_same; auto.
 rewrite <- Zplus_mod_idemp_l.
 apply Zmod_small.
 generalize (Z_mod_lt x wB wB_pos); omega.
 Qed.

 Lemma spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|].
 Proof.
 intros; unfold add_c, to_Z, interp_carry.
 destruct Z_lt_le_dec.
 apply Zmod_small;
  generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r.
 apply Zmod_small;
  generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 Qed.

 Lemma spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1.
 Proof.
 intros; unfold add_carry_c, to_Z, interp_carry.
 destruct Z_lt_le_dec.
 apply Zmod_small;
  generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r.
 apply Zmod_small;
  generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 Qed.

 Lemma spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB.
 Proof.
 intros; unfold succ, to_Z, Z.succ.
 symmetry; apply Zplus_mod_idemp_l.
 Qed.

 Lemma spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB.
 Proof.
 intros; unfold add, to_Z; apply Zplus_mod.
 Qed.

 Lemma spec_add_carry :
	 forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB.
 Proof.
 intros; unfold add_carry, to_Z.
 rewrite <- Zplus_mod_idemp_l.
 rewrite (Zplus_mod x y).
 rewrite Zplus_mod_idemp_l; auto.
 Qed.

 Definition pred_c x :=
  if eq0 x then C1 (wB-1) else C0 (x-1).

 Definition sub_c x y :=
  let z := [|x|]-[|y|] in
  if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z.

 Definition sub_carry_c x y :=
  let z := [|x|]-[|y|]-1 in
  if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z.

 Definition pred := Z.pred.
 Definition sub := Z.sub.
 Definition sub_carry x y := x - y - 1.

 Lemma spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1.
 Proof.
 intros; unfold pred_c, to_Z, interp_carry.
 case_eq (eq0 x); intros.
 fold [|x|]; rewrite spec_eq0; auto.
 replace ((wB-1) mod wB) with (wB-1); auto with zarith.
 symmetry; apply Zmod_small; generalize wB_pos; omega.

 assert (x mod wB <> 0).
  unfold eq0, to_Z in *; now destruct (x mod wB).
 rewrite <- Zminus_mod_idemp_l.
 apply Zmod_small.
 generalize (Z_mod_lt x wB wB_pos); omega.
 Qed.

 Lemma spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|].
 Proof.
 intros; unfold sub_c, to_Z, interp_carry.
 destruct Z_lt_le_dec.
 replace ((wB + (x mod wB - y mod wB)) mod wB) with
   (wB + (x mod wB - y mod wB)).
 omega.
 symmetry; apply Zmod_small.
 generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.

 apply Zmod_small.
 generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 Qed.

 Lemma spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1.
 Proof.
 intros; unfold sub_carry_c, to_Z, interp_carry.
 destruct Z_lt_le_dec.
 replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with
   (wB + (x mod wB - y mod wB -1)).
 omega.
 symmetry; apply Zmod_small.
 generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.

 apply Zmod_small.
 generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 Qed.

 Lemma spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB.
 Proof.
 intros; unfold pred, to_Z, Z.pred.
 rewrite <- Zplus_mod_idemp_l; auto.
 Qed.

 Lemma spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB.
 Proof.
 intros; unfold sub, to_Z; apply Zminus_mod.
 Qed.

 Lemma spec_sub_carry :
  forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.
 Proof.
 intros; unfold sub_carry, to_Z.
 rewrite <- Zminus_mod_idemp_l.
 rewrite (Zminus_mod x y).
 rewrite Zminus_mod_idemp_l.
 auto.
 Qed.

 Definition mul_c x y :=
  let (h,l) := Z.div_eucl ([|x|]*[|y|]) wB in
  if eq0 h then if eq0 l then W0 else WW h l else WW h l.

 Definition mul := Z.mul.

 Definition square_c x := mul_c x x.

 Lemma spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|].
 Proof.
 intros; unfold mul_c, zn2z_to_Z.
 assert (Z.div_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)).
  unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
 generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Z.div_eucl as (h,l).
 destruct 1; injection H as ? ?.
 rewrite H0.
 assert ([|l|] = l).
  apply Zmod_small; auto.
 assert ([|h|] = h).
  apply Zmod_small.
  subst h.
  split.
  apply Z_div_pos; auto with zarith.
  apply Zdiv_lt_upper_bound; auto with zarith.
  apply Z.mul_lt_mono_nonneg; auto with zarith.
 clear H H0 H1 H2.
 case_eq (eq0 h); simpl; intros.
 case_eq (eq0 l); simpl; intros.
 rewrite <- H3, <- H4, (spec_eq0 h), (spec_eq0 l); auto with zarith.
 rewrite H3, H4; auto with zarith.
 rewrite H3, H4; auto with zarith.
 Qed.

 Lemma spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB.
 Proof.
 intros; unfold mul, to_Z; apply Zmult_mod.
 Qed.

 Lemma spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|].
 Proof.
 intros x; exact (spec_mul_c x x).
 Qed.

 Definition div x y := Z.div_eucl [|x|] [|y|].

 Lemma spec_div : forall a b, 0 < [|b|] ->
      let (q,r) := div a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
 intros; unfold div.
 assert ([|b|]>0) by auto with zarith.
 assert (Z.div_eucl [|a|] [|b|] = ([|a|]/[|b|], [|a|] mod [|b|])).
  unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
 generalize (Z_div_mod [|a|] [|b|] H0).
 destruct Z.div_eucl as (q,r); destruct 1; intros.
 injection H1 as ? ?.
 assert ([|r|]=r).
  apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
   auto with zarith.
 assert ([|q|]=q).
  apply Zmod_small.
  subst q.
  split.
  apply Z_div_pos; auto with zarith.
  apply Zdiv_lt_upper_bound; auto with zarith.
  apply Z.lt_le_trans with (wB*1).
  rewrite Z.mul_1_r; auto with zarith.
  apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith.
 rewrite H5, H6; rewrite Z.mul_comm; auto with zarith.
 Qed.

 Definition div_gt := div.

 Lemma spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
      let (q,r) := div_gt a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
 intros.
 apply spec_div; auto.
 Qed.

 Definition modulo x y := [|x|] mod [|y|].
 Definition modulo_gt x y := [|x|] mod [|y|].

 Lemma spec_modulo :  forall a b, 0 < [|b|] ->
      [|modulo a b|] = [|a|] mod [|b|].
 Proof.
 intros; unfold modulo.
 apply Zmod_small.
 assert ([|b|]>0) by auto with zarith.
 generalize (Z_mod_lt [|a|] [|b|] H0) (Z_mod_lt b wB wB_pos).
 fold [|b|]; omega.
 Qed.

 Lemma spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
      [|modulo_gt a b|] = [|a|] mod [|b|].
 Proof.
 intros; apply spec_modulo; auto.
 Qed.

 Definition gcd x y := Z.gcd [|x|] [|y|].
 Definition gcd_gt x y := Z.gcd [|x|] [|y|].

 Lemma Zgcd_bound : forall a b, 0<=a -> 0<=b -> Z.gcd a b <= Z.max a b.
 Proof.
 intros.
 generalize (Zgcd_is_gcd a b); inversion_clear 1.
 destruct H2 as (q,H2); destruct H3 as (q',H3); clear H4.
 assert (H4:=Z.gcd_nonneg a b).
 destruct (Z.eq_dec (Z.gcd a b) 0) as [->|Hneq].
 generalize (Zmax_spec a b); omega.
 assert (0 <= q).
  apply Z.mul_le_mono_pos_r with (Z.gcd a b); auto with zarith.
 destruct (Z.eq_dec q 0).

 subst q; simpl in *; subst a; simpl; auto.
 generalize (Zmax_spec 0 b) (Zabs_spec b); omega.

 apply Z.le_trans with a.
 rewrite H2 at 2.
 rewrite <- (Z.mul_1_l (Z.gcd a b)) at 1.
 apply Z.mul_le_mono_nonneg; auto with zarith.
 generalize (Zmax_spec a b); omega.
 Qed.

 Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|].
 Proof.
 intros; unfold gcd.
 generalize (Z_mod_lt a wB wB_pos)(Z_mod_lt b wB wB_pos); intros.
 fold [|a|] in *; fold [|b|] in *.
 replace ([|Z.gcd [|a|] [|b|]|]) with (Z.gcd [|a|] [|b|]).
 apply Zgcd_is_gcd.
 symmetry; apply Zmod_small.
 split.
 apply Z.gcd_nonneg.
 apply Z.le_lt_trans with (Z.max [|a|] [|b|]).
 apply Zgcd_bound; auto with zarith.
 generalize (Zmax_spec [|a|] [|b|]); omega.
 Qed.

 Lemma spec_gcd_gt : forall a b, [|a|] > [|b|] ->
      Zis_gcd [|a|] [|b|] [|gcd_gt a b|].
 Proof.
  intros. apply spec_gcd; auto.
 Qed.

 Definition div21 a1 a2 b :=
  Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|].

 Lemma spec_div21 : forall a1 a2 b,
      wB/2 <= [|b|] ->
      [|a1|] < [|b|] ->
      let (q,r) := div21 a1 a2 b in
      [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
 intros; unfold div21.
 generalize (Z_mod_lt a1 wB wB_pos); fold [|a1|]; intros.
 generalize (Z_mod_lt a2 wB wB_pos); fold [|a2|]; intros.
 assert ([|b|]>0) by auto with zarith.
 remember ([|a1|]*wB+[|a2|]) as a.
 assert (Z.div_eucl a [|b|] = (a/[|b|], a mod [|b|])).
  unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
 generalize (Z_div_mod a [|b|] H3).
 destruct Z.div_eucl as (q,r); destruct 1; intros.
 injection H4 as ? ?.
 assert ([|r|]=r).
  apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
   auto with zarith.
 assert ([|q|]=q).
  apply Zmod_small.
  subst q.
  split.
  apply Z_div_pos; auto with zarith.
  subst a; auto with zarith.
  apply Zdiv_lt_upper_bound; auto with zarith.
  subst a.
  replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring.
  apply Z.lt_le_trans with ([|a1|]*wB+wB); auto with zarith.
 rewrite H8, H9; rewrite Z.mul_comm; auto with zarith.
 Qed.

 Definition add_mul_div p x y :=
   ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos digits) - [|p|]))).
 Lemma spec_add_mul_div : forall x y p,
       [|p|] <= Zpos digits ->
       [| add_mul_div p x y |] =
         ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB.
 Proof.
 intros; unfold add_mul_div; auto.
 Qed.

 Definition pos_mod p w := [|w|] mod (2 ^ [|p|]).
 Lemma spec_pos_mod : forall w p,
       [|pos_mod p w|] = [|w|] mod (2 ^ [|p|]).
 Proof.
 intros; unfold pos_mod.
 apply Zmod_small.
 generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros.
 split.
 destruct H; auto using Z.lt_gt with zarith.
 apply Z.le_lt_trans with [|w|]; auto with zarith.
 apply Zmod_le; auto with zarith.
 Qed.

 Definition is_even x :=
   if Z.eq_dec ([|x|] mod 2) 0 then true else false.

 Lemma spec_is_even : forall x,
      if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1.
 Proof.
 intros; unfold is_even; destruct Z.eq_dec; auto.
 generalize (Z_mod_lt [|x|] 2); omega.
 Qed.

 Definition sqrt x := Z.sqrt [|x|].
 Lemma spec_sqrt : forall x,
       [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2.
 Proof.
 intros.
 unfold sqrt.
 repeat rewrite Z.pow_2_r.
 replace [|Z.sqrt [|x|]|] with (Z.sqrt [|x|]).
 apply Z.sqrt_spec; auto with zarith.
 symmetry; apply Zmod_small.
 split. apply Z.sqrt_nonneg; auto.
 apply Z.le_lt_trans with [|x|]; auto.
 apply Z.sqrt_le_lin; auto.
 Qed.

 Definition sqrt2 x y :=
  let z := [|x|]*wB+[|y|] in
  match z with
   | Z0 => (0, C0 0)
   | Zpos p =>
      let (s,r) := Z.sqrtrem (Zpos p) in
      (s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB))
   | Zneg _ => (0, C0 0)
  end.

 Lemma spec_sqrt2 : forall x y,
       wB/ 4 <= [|x|] ->
       let (s,r) := sqrt2 x y in
          [||WW x y||] = [|s|] ^ 2 + [+|r|] /\
          [+|r|] <= 2 * [|s|].
 Proof.
 intros; unfold sqrt2.
 simpl zn2z_to_Z.
 remember ([|x|]*wB+[|y|]) as z.
 destruct z.
 auto with zarith.
 generalize (Z.sqrtrem_spec (Zpos p)).
 destruct Z.sqrtrem as (s,r); intros [U V]; auto with zarith.
 assert (s < wB).
  destruct (Z_lt_le_dec s wB); auto.
  assert (wB * wB <= Zpos p).
   rewrite U.
   apply Z.le_trans with (s*s); try omega.
   apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith.
  assert (Zpos p < wB*wB).
   rewrite Heqz.
   replace (wB*wB) with ((wB-1)*wB+wB) by ring.
   apply Z.add_le_lt_mono; auto with zarith.
   apply Z.mul_le_mono_nonneg; auto with zarith.
   generalize (spec_to_Z x); auto with zarith.
   generalize wB_pos; auto with zarith.
  omega.
 replace [|s|] with s by (symmetry; apply Zmod_small; auto with zarith).
 destruct Z_lt_le_dec; unfold interp_carry.
 replace [|r|] with r by (symmetry; apply Zmod_small; auto with zarith).
 rewrite Z.pow_2_r; auto with zarith.
 replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith).
 rewrite Z.pow_2_r; omega.

 assert (0<=Zneg p).
  rewrite Heqz; generalize wB_pos; auto with zarith.
 compute in H0; elim H0; auto.
 Qed.

 Lemma two_p_power2 : forall x, x>=0 -> two_p x = 2 ^ x.
 Proof.
 intros.
 unfold two_p.
 destruct x; simpl; auto.
 apply two_power_pos_correct.
 Qed.

 Definition head0 x := match [|x|] with
   | Z0 => zdigits
   | Zpos p => zdigits - log_inf p - 1
   | _ => 0
  end.

 Lemma spec_head00:  forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits.
 Proof.
  unfold head0; intros.
  rewrite H; simpl.
  apply spec_zdigits.
 Qed.

 Lemma log_inf_bounded : forall x p, Zpos x < 2^p -> log_inf x < p.
 Proof.
 induction x; simpl; intros.

 assert (0 < p) by (destruct p; compute; auto with zarith; discriminate).
 cut (log_inf x < p - 1); [omega| ].
 apply IHx.
 change (Zpos x~1) with (2*(Zpos x)+1) in H.
 replace p with (Z.succ (p-1)) in H; auto with zarith.
 rewrite Z.pow_succ_r in H; auto with zarith.

 assert (0 < p) by (destruct p; compute; auto with zarith; discriminate).
 cut (log_inf x < p - 1); [omega| ].
 apply IHx.
 change (Zpos x~0) with (2*(Zpos x)) in H.
 replace p with (Z.succ (p-1)) in H; auto with zarith.
 rewrite Z.pow_succ_r in H; auto with zarith.

 simpl; intros; destruct p; compute; auto with zarith.
 Qed.

 Lemma spec_head0  : forall x,  0 < [|x|] ->
	 wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB.
 Proof.
 intros; unfold head0.
 generalize (spec_to_Z x).
 destruct [|x|]; try discriminate.
 intros.
 destruct (log_inf_correct p).
 rewrite 2 two_p_power2 in H2; auto with zarith.
 assert (0 <= zdigits - log_inf p - 1 < wB).
  split.
  cut (log_inf p < zdigits); try omega.
  unfold zdigits.
  unfold wB, base in *.
  apply log_inf_bounded; auto with zarith.
  apply Z.lt_trans with zdigits.
  omega.
  unfold zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith.

 unfold to_Z; rewrite (Zmod_small _ _ H3).
 destruct H2.
 split.
 apply Z.le_trans with (2^(zdigits - log_inf p - 1)*(2^log_inf p)).
 apply Zdiv_le_upper_bound; auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 rewrite Z.mul_comm; rewrite <- Z.pow_succ_r; auto with zarith.
 replace (Z.succ (zdigits - log_inf p -1 +log_inf p)) with zdigits
   by ring.
 unfold wB, base, zdigits; auto with zarith.
 apply Z.mul_le_mono_nonneg; auto with zarith.

 apply Z.lt_le_trans
   with (2^(zdigits - log_inf p - 1)*(2^(Z.succ (log_inf p)))).
 apply Z.mul_lt_mono_pos_l; auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 replace (zdigits - log_inf p -1 +Z.succ (log_inf p)) with zdigits
   by ring.
 unfold wB, base, zdigits; auto with zarith.
 Qed.

 Fixpoint Ptail p := match p with
  | xO p => (Ptail p)+1
  | _ => 0
 end.

 Lemma Ptail_pos : forall p, 0 <= Ptail p.
 Proof.
 induction p; simpl; auto with zarith.
 Qed.
 Hint Resolve Ptail_pos.

 Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d.
 Proof.
 induction p; try (compute; auto; fail).
 intros; simpl.
 assert (d <> xH).
  intro; subst.
  compute in H; destruct p; discriminate.
 assert (Z.succ (Zpos (Pos.pred d)) = Zpos d).
  simpl; f_equal.
  rewrite Pos.add_1_r.
  destruct (Pos.succ_pred_or d); auto.
  rewrite H1 in H0; elim H0; auto.
 assert (Ptail p < Zpos (Pos.pred d)).
  apply IHp.
  apply Z.mul_lt_mono_pos_r with 2; auto with zarith.
  rewrite (Z.mul_comm (Zpos p)).
  change (2 * Zpos p) with (Zpos p~0).
  rewrite Z.mul_comm.
  rewrite <- Z.pow_succ_r; auto with zarith.
  rewrite H1; auto.
 rewrite <- H1; omega.
 Qed.

 Definition tail0 x :=
  match [|x|] with
   | Z0 => zdigits
   | Zpos p => Ptail p
   | Zneg _ => 0
  end.

 Lemma spec_tail00:  forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits.
 Proof.
  unfold tail0; intros.
  rewrite H; simpl.
  apply spec_zdigits.
 Qed.

 Lemma spec_tail0  : forall x, 0 < [|x|] ->
         exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]).
 Proof.
 intros; unfold tail0.
 generalize (spec_to_Z x).
 destruct [|x|]; try discriminate; intros.
 assert ([|Ptail p|] = Ptail p).
  apply Zmod_small.
  split; auto.
  unfold wB, base in *.
  apply Z.lt_trans with (Zpos digits).
  apply Ptail_bounded; auto with zarith.
  apply Zpower2_lt_lin; auto with zarith.
 rewrite H1.

 clear; induction p.
 exists (Zpos p); simpl; rewrite Pos.mul_1_r; auto with zarith.
 destruct IHp as (y & Yp & Ye).
 exists y.
 split; auto.
 change (Zpos p~0) with (2*Zpos p).
 rewrite Ye.
 change (Ptail p~0) with (Z.succ (Ptail p)).
 rewrite Z.pow_succ_r; auto; ring.

 exists 0; simpl; auto with zarith.
 Qed.

 Definition lor := Z.lor.
 Definition land := Z.land.
 Definition lxor := Z.lxor.

 Lemma spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|].
 Proof.
 unfold lor, to_Z.
 apply Z.bits_inj'; intros n Hn. rewrite Z.lor_spec.
 unfold wB, base.
 destruct (Z.le_gt_cases (Z.pos digits) n).
 - rewrite !Z.mod_pow2_bits_high; auto with zarith.
 - rewrite !Z.mod_pow2_bits_low, Z.lor_spec; auto with zarith.
 Qed.

 Lemma spec_land x y : [|land x y|] = Z.land [|x|] [|y|].
 Proof.
 unfold land, to_Z.
 apply Z.bits_inj'; intros n Hn. rewrite Z.land_spec.
 unfold wB, base.
 destruct (Z.le_gt_cases (Z.pos digits) n).
 - rewrite !Z.mod_pow2_bits_high; auto with zarith.
 - rewrite !Z.mod_pow2_bits_low, Z.land_spec; auto with zarith.
 Qed.

 Lemma spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|].
 Proof.
 unfold lxor, to_Z.
 apply Z.bits_inj'; intros n Hn. rewrite Z.lxor_spec.
 unfold wB, base.
 destruct (Z.le_gt_cases (Z.pos digits) n).
 - rewrite !Z.mod_pow2_bits_high; auto with zarith.
 - rewrite !Z.mod_pow2_bits_low, Z.lxor_spec; auto with zarith.
 Qed.

 (** Let's now group everything in two records *)

 Instance zmod_ops : ZnZ.Ops Z := ZnZ.MkOps
    (digits : positive)
    (zdigits: t)
    (to_Z   : t -> Z)
    (of_pos : positive -> N * t)
    (head0  : t -> t)
    (tail0  : t -> t)

    (zero   : t)
    (one    : t)
    (minus_one : t)

    (compare     : t -> t -> comparison)
    (eq0         : t -> bool)

    (opp_c       : t -> carry t)
    (opp         : t -> t)
    (opp_carry   : t -> t)

    (succ_c      : t -> carry t)
    (add_c       : t -> t -> carry t)
    (add_carry_c : t -> t -> carry t)
    (succ        : t -> t)
    (add         : t -> t -> t)
    (add_carry   : t -> t -> t)

    (pred_c      : t -> carry t)
    (sub_c       : t -> t -> carry t)
    (sub_carry_c : t -> t -> carry t)
    (pred        : t -> t)
    (sub         : t -> t -> t)
    (sub_carry   : t -> t -> t)

    (mul_c       : t -> t -> zn2z t)
    (mul         : t -> t -> t)
    (square_c    : t -> zn2z t)

    (div21       : t -> t -> t -> t*t)
    (div_gt      : t -> t -> t * t)
    (div         : t -> t -> t * t)

    (modulo_gt      : t -> t -> t)
    (modulo         : t -> t -> t)

    (gcd_gt      : t -> t -> t)
    (gcd         : t -> t -> t)
    (add_mul_div : t -> t -> t -> t)
    (pos_mod     : t -> t -> t)

    (is_even     : t -> bool)
    (sqrt2       : t -> t -> t * carry t)
    (sqrt        : t -> t)
    (lor         : t -> t -> t)
    (land         : t -> t -> t)
    (lxor         : t -> t -> t).

 Instance zmod_specs : ZnZ.Specs zmod_ops := ZnZ.MkSpecs
    spec_to_Z
    spec_of_pos
    spec_zdigits
    spec_more_than_1_digit

    spec_0
    spec_1
    spec_Bm1

    spec_compare
    spec_eq0

    spec_opp_c
    spec_opp
    spec_opp_carry

    spec_succ_c
    spec_add_c
    spec_add_carry_c
    spec_succ
    spec_add
    spec_add_carry

    spec_pred_c
    spec_sub_c
    spec_sub_carry_c
    spec_pred
    spec_sub
    spec_sub_carry

    spec_mul_c
    spec_mul
    spec_square_c

    spec_div21
    spec_div_gt
    spec_div

    spec_modulo_gt
    spec_modulo

    spec_gcd_gt
    spec_gcd

    spec_head00
    spec_head0
    spec_tail00
    spec_tail0

    spec_add_mul_div
    spec_pos_mod

    spec_is_even
    spec_sqrt2
    spec_sqrt
    spec_lor
    spec_land
    spec_lxor.

End ZModulo.

(** A modular version of the previous construction. *)

Module Type PositiveNotOne.
 Parameter p : positive.
 Axiom not_one : p <> 1%positive.
End PositiveNotOne.

Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType.
 Definition t := Z.
 Instance ops : ZnZ.Ops t := zmod_ops P.p.
 Instance specs : ZnZ.Specs ops := zmod_specs P.not_one.
End ZModuloCyclicType.


Require Export base_mods.
Require Import preds_in.

Definition Pred_in_SO (alpha : SecOrder) (P : predicate) : Prop :=
  In P (preds_in alpha).

Lemma Pred_in_SO_dec : forall alpha P,
    {Pred_in_SO alpha P} + {~ Pred_in_SO alpha P}.
Proof.
  intros; unfold Pred_in_SO. apply in_dec.
  intros P1 P2. apply predicate_dec.
Qed.

Lemma trying1 : forall alpha,
  (forall P, ~ Pred_in_SO alpha P) +
  (existsT P, Pred_in_SO alpha P).
Proof.
  intros alpha. unfold Pred_in_SO.
  destruct (preds_in alpha); simpl; firstorder.
  right. exists p. firstorder.
Defined.

Lemma Pred_in_SO_predSO: forall p x,
Pred_in_SO ($ p x) p.
Proof. intros p x. firstorder. Qed.

Lemma Pred_in_SO_relatSO : forall P x y,
    ~ Pred_in_SO (relatSO x y) P.
Proof. firstorder. Qed.

Lemma Pred_in_SO_eqFO : forall P x y,
    ~ Pred_in_SO (eqFO x y) P.
Proof. firstorder. Qed.

Lemma Pred_in_SO_allFO : forall (alpha : SecOrder) (x : FOvariable)
                                        (P : predicate),
  Pred_in_SO alpha P = Pred_in_SO (allFO x alpha) P.
Proof.
  intros alpha x P.
  unfold Pred_in_SO.
  reflexivity.
Qed.

Lemma Pred_in_SO_exFO : forall (alpha : SecOrder) (x : FOvariable)
                                        (P : predicate),
  Pred_in_SO alpha P = Pred_in_SO (exFO x alpha) P.
Proof.
  intros alpha x P; destruct x;
  unfold Pred_in_SO in *; reflexivity.
Qed.

Lemma Pred_in_SO_negSO : forall (alpha : SecOrder)
                                        (P : predicate),
  Pred_in_SO alpha P = Pred_in_SO (negSO alpha) P.
Proof.
  intros; unfold Pred_in_SO; reflexivity.
Qed.

Lemma Pred_in_SO_conjSO_comp : forall (alpha1 alpha2 : SecOrder)
                                        (P : predicate),
  (Pred_in_SO (conjSO alpha1 alpha2) P ->
    (Pred_in_SO alpha1 P ) + (Pred_in_SO alpha2 P)) *
  ((Pred_in_SO alpha1 P) + (Pred_in_SO alpha2 P) ->
    Pred_in_SO (conjSO alpha1 alpha2) P ).
Proof.
  intros until 0. apply pair; intros H;
                    unfold Pred_in_SO in *; simpl in *.
  apply in_app_or in H.
  destruct (in_dec (predicate_dec) P (preds_in alpha1)) as [H1 | H1].
  left. auto. right.
  destruct H.  contradiction. auto.
  apply in_or_app. firstorder.
Defined.

Lemma Pred_in_SO_conjSO : forall (alpha1 alpha2 : SecOrder)
                                        (P : predicate),
  (Pred_in_SO (conjSO alpha1 alpha2) P <->
    (Pred_in_SO alpha1 P) \/ (Pred_in_SO alpha2 P)).
Proof.
  intros until 0. split; intros H;
                    unfold Pred_in_SO in *; simpl in *.
    apply in_app_or. auto.
    apply in_or_app. auto.
Qed.

Lemma Pred_in_SO_disjSO_comp : forall (alpha1 alpha2 : SecOrder)
                                        (P : predicate),
  (Pred_in_SO (disjSO alpha1 alpha2) P ->
    (Pred_in_SO alpha1 P ) + (Pred_in_SO alpha2 P)) *
  ((Pred_in_SO alpha1 P) + (Pred_in_SO alpha2 P) ->
    Pred_in_SO (disjSO alpha1 alpha2) P ).
Proof.
  intros until 0. apply pair; intros H;
                    unfold Pred_in_SO in *; simpl in *.
  apply in_app_or in H.
  destruct (in_dec (predicate_dec) P (preds_in alpha1)) as [H1 | H1].
  left. auto. right.
  destruct H.  contradiction. auto.
  apply in_or_app. firstorder.
Defined.

Lemma Pred_in_SO_disjSO : forall (alpha1 alpha2 : SecOrder)
                                        (P : predicate),
  (Pred_in_SO (disjSO alpha1 alpha2) P <->
    (Pred_in_SO alpha1 P) \/ (Pred_in_SO alpha2 P)).
Proof.
  intros until 0. split; intros H;
                    unfold Pred_in_SO in *; simpl in *.
    apply in_app_or. auto.
    apply in_or_app. auto.
Qed.

Lemma Pred_in_SO_implSO_comp : forall (alpha1 alpha2 : SecOrder)
                                        (P : predicate),
  (Pred_in_SO (implSO alpha1 alpha2) P ->
    (Pred_in_SO alpha1 P ) + (Pred_in_SO alpha2 P)) *
  ((Pred_in_SO alpha1 P) + (Pred_in_SO alpha2 P) ->
    Pred_in_SO (implSO alpha1 alpha2) P ).
Proof.
  intros until 0. apply pair; intros H;
                    unfold Pred_in_SO in *; simpl in *.
  apply in_app_or in H.
  destruct (in_dec (predicate_dec) P (preds_in alpha1)) as [H1 | H1].
  left. auto. right.
  destruct H.  contradiction. auto.
  apply in_or_app. firstorder.
Defined.

Lemma Pred_in_SO_implSO : forall (alpha1 alpha2 : SecOrder)
                                        (P : predicate),
  (Pred_in_SO (implSO alpha1 alpha2) P <->
    (Pred_in_SO alpha1 P) \/ (Pred_in_SO alpha2 P)).
Proof.
  intros until 0. split; intros H;
                    unfold Pred_in_SO in *; simpl in *.
    apply in_app_or. auto.
    apply in_or_app. auto.
Qed.

Lemma Pred_in_SO_allSO : forall (alpha : SecOrder)
                                        (Q P: predicate),
  Pred_in_SO (allSO Q alpha) P <->
    P = Q   \/ Pred_in_SO alpha P.
Proof. firstorder. Qed.

Lemma Pred_in_SO_exSO : forall (alpha : SecOrder)
                                        (Q P: predicate),
  Pred_in_SO (exSO Q alpha) P <->
    P = Q   \/ Pred_in_SO alpha P.
Proof. firstorder. Qed.

Lemma  Pred_in_SO_allSO3 : forall alpha P Q,
  ~ Q = P ->
  Pred_in_SO alpha P <-> Pred_in_SO (allSO Q alpha) P.
Proof.
  intros alpha P Q Hneq.
  unfold Pred_in_SO. simpl. firstorder.
Qed.

Lemma  Pred_in_SO_exSO2 : forall alpha P Q,
  ~ Q = P ->
  Pred_in_SO alpha P <-> Pred_in_SO (exSO Q alpha) P.
Proof.
  intros alpha P Q Hneq.
  unfold Pred_in_SO. simpl. firstorder.
Qed.

Lemma Pred_in_SO_conjSO_f : forall (alpha1 alpha2 : SecOrder)
                                        (P : predicate),
  ~ Pred_in_SO (conjSO alpha1 alpha2) P <->
  ~ Pred_in_SO alpha1 P /\ ~ Pred_in_SO alpha2 P.
Proof.
  split; intros H;
    unfold Pred_in_SO in *;
    simpl in *. split; intros H2.
  contradiction (H (in_or_app _ _ _ (or_introl  _ H2))).
  contradiction (H (in_or_app _ _ _ (or_intror  _ H2))).
  intros H2. apply in_app_or in H2. firstorder.
Qed.

Lemma Pred_in_SO_allSO2 : forall (alpha : SecOrder)
                                        (Q P: predicate),
  Pred_in_SO alpha P ->
  Pred_in_SO (allSO Q alpha) P.
Proof.
  intros alpha Q P H.
  apply Pred_in_SO_allSO.
  destruct P as [Pn]; destruct Q as [Qm].
  right; assumption.
Qed.

Lemma Pred_in_SO_conjSO_all_f_l : forall alpha1 alpha2,
  (forall P, ~ Pred_in_SO (conjSO alpha1 alpha2) P) ->
  forall P, ~ Pred_in_SO alpha1 P.
Proof.
  intros alpha1 alpha2 H P. specialize (H P).
  apply Pred_in_SO_conjSO_f in H. apply H.
Qed.

Lemma Pred_in_SO_conjSO_all_f_r : forall alpha1 alpha2,
  (forall P, ~ Pred_in_SO (conjSO alpha1 alpha2) P) ->
  forall P, ~ Pred_in_SO alpha2 P.
Proof.
  intros alpha1 alpha2 H P. specialize (H P).
  apply Pred_in_SO_conjSO_f in H. apply H.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint.
From mathcomp Require Import fingroup finset.
From mathcomp Require Import cyclic zmodp.

Require Import Posrat Premeas Meas Aux Reaction finfun_fixed String SSRString SeqOps RLems.

Section RPS.
  Inductive play := rock | paper | scissors.
  Definition play_enc : play -> option bool :=
    fun p =>
      match p with
        | rock => None
        | paper => Some false
        | scissors => Some true end.
  Definition play_dec : option bool -> play :=
    fun p =>
      match p with
        | None => rock
        | Some false => paper
        | Some true => scissors end.
  Lemma play_cancel : cancel play_enc play_dec.
  by elim.
  Qed.
  Canonical play_eq := EqType play (CanEqMixin play_cancel).
  Canonical play_ch := ChoiceType play (CanChoiceMixin play_cancel).
  Canonical play_co := CountType play (CanCountMixin play_cancel).
  Canonical play_fin := FinType play (CanFinMixin play_cancel).

  Inductive ty :=
    | tyPlay
    | tyAns
    | tyUnit
    | tyPair : ty -> ty -> ty.

  Fixpoint ty_enc (t : ty) : GenTree.tree (option bool) :=
    match t with
      | tyPlay => GenTree.Leaf (Some false)
      | tyAns => GenTree.Leaf (Some true)
      | tyUnit => GenTree.Leaf None
      | tyPair t1 t2 => GenTree.Node 0 [:: ty_enc t1; ty_enc t2]
                                     end.
  Fixpoint ty_dec (t : GenTree.tree (option bool)) : ty :=
    match t with
      | GenTree.Leaf (Some false) => tyPlay
      | GenTree.Leaf (Some true) => tyAns
      | GenTree.Leaf None => tyUnit
      | GenTree.Node _ (x :: y :: _) => tyPair (ty_dec x) (ty_dec y)
      | _ => tyPlay
               end.

  Lemma ty_can : cancel ty_enc ty_dec.
    move => x.
    induction x; rewrite //=.
    rewrite IHx1 IHx2 //=.
  Qed.

  Canonical ty_eq := EqType ty (CanEqMixin ty_can).
  Canonical ty_ch := ChoiceType ty (CanChoiceMixin ty_can).

  Fixpoint denomTy (t : ty) : finType :=
    match t with
      | tyPlay => [finType of play]
      | tyAns => [finType of option bool]
      | tyUnit => [finType of unit]
      | tyPair t1 t2 => [finType of (denomTy t1) * (denomTy t2)]
                          end.

  Local Instance ty_type : type [eqType of ty].
   econstructor.
   instantiate (1 := denomTy).
   instantiate (1 := tyPair).
   done.
 Defined.

  Definition rps_comp (p q : play) : option bool :=
    match p with
    | rock =>
      match q with
        | rock => None
        | scissors => Some false
        | paper => Some true end
    | paper =>
      match q with
        | rock => Some false
        | scissors => Some true
        | paper => None end
    | scissors =>
      match q with
        | rock => Some true
        | scissors => None
        | paper => Some false
      end
        end.

  Definition rl := rlist [choiceType of string] [choiceType of ty].

  Open Scope string_scope.

  Definition ans_flip (o : option bool) :=
    match o with
    | None => None
    | Some b => Some (~~ b)
                     end.

  Definition rpsIdeal : rl :=
    [:: inr "inA";
      inr "inB";
      [:: ("inA", tyPlay); ("inB", tyPlay)] ~> ("comp", tyAns) dhid rps_comp;
      [:: ("comp", tyAns)] ~> ("outA", tyAns) dvis id;
      [:: ("comp", tyAns)] ~> ("outB", tyAns) dvis id
    ].

  Definition rpsRealP (p : bool) :rl :=
    let me := if p then "A" else "B" in
    let them := if p then "B" else "A" in
    [:: inr ("in" ++ me);
       inr ("committed" ++ them);
       inr ("val" ++ them);
       [:: ("in" ++ me, tyPlay)] ~> ("com" ++ me, tyPlay) dvis id;
       [:: ("com" ++ me, tyPlay); ("committed" ++ them, tyUnit)] ~> ("open" ++ me, tyUnit) dvis (fun _ _ => tt);
       [:: ("in"++me, tyPlay); ("val"++them, tyPlay)] ~> ("out"++me, tyAns) dvis (if p then rps_comp else (fun y x => rps_comp x y))
    ].

  Lemma wf_realP b : r_wf (rpsRealP b).
  rewrite /rpsRealP /r_wf; destruct b; done.
  Qed.

  Definition rps_simp : rl :=
    [::
      [:: ("inA", tyPlay); ("inB", tyPlay)] ~> ("outB", tyAns) vis (fun y x  => ret rps_comp y x);
      [:: ("inB", tyPlay); ("inA", tyPlay)] ~> ("outA", tyAns)
      vis (fun y x  => ret rps_comp x y); inr "inB"; inr "inA"].

  Definition rpsRealF (p : bool) : rl :=
    let me := if p then "A" else "B" in
    [:: inr ("com"++me);
        [:: ("com"++me, tyPlay)] ~> ("committed"++me, tyUnit) dvis (fun _ => tt);
        inr ("open"++me);
        [:: ("com"++me, tyPlay); ("open"++me, tyUnit)] ~> ("val"++me, tyPlay) dvis (fun x _ => x)
                                                       ].

  Lemma wf_realF b : r_wf (rpsRealF b).
  rewrite /rpsRealF /r_wf; destruct b; done.
  Qed.

  Definition rpsReal := (rpsRealF true ||| rpsRealF false ||| rpsRealP true ||| rpsRealP false).

  Close Scope posrat_scope.
  Open Scope nat_scope.

  Lemma eqVneq_xx {A : eqType} (x : A) : eqVneq x x = left erefl.
    destruct (eqVneq x x).
    have -> //=: e = erefl by apply eq_irrelevance.
    exfalso.
    rewrite eq_refl in i; done.
  Qed.

  (******* NOBODY CORRUPTED ********)

  Lemma ideal_rewr : r_rewr rps_simp rpsIdeal.
    rewrite /rpsIdeal /rps_simp.
    simpl.
    r_move "outA" 0.
    arg_focus "inA".
    r_prod "outA" "outB" "tmp".
    rewrite /eq_rect_r /=.
    r_ext "tmp" (fun x y => a <- ret (rps_comp x y); ret (a, a)).
    intros; destruct x; destruct x0; simpl; msimp; done.
    unfold_bind2 "tmp" "comp" tyAns.
    r_subst "tmp" "outB".
    r_str "outB" "tmp".
    r_subst "tmp" "outA".
    r_str "outA" "tmp".
    r_str_inp "outA" "inA".
    r_str_inp "outA" "inB".
    r_str_inp "outB" "inA".
    r_str_inp "outB" "inB".
    r_clean.
    r_align.
    reflexivity.
  Qed.

  Lemma real_rewr : r_rewr rpsReal rps_simp.
    rewrite /rpsReal /rpsRealF /rpsRealP.
    simpl.
    rewrite /rlist_comp_hide.
    vm_compute RChans; rewrite //=.

    simpl.
    r_weakstr "committedA" "comA".
    r_weakstr "committedB" "comB".
    r_str_inp "committedA" "inA".
    r_str_inp "committedB" "inB".
    r_move "openA" 0; arg_focus "committedB".
    r_str "openA" "committedB".
    r_move "openB" 0; arg_focus "committedA".
    r_str "openB" "committedA".
    repeat r_clean.
    r_subst "comA" "openA".
    r_str "openA" "comA".
    r_str_inp "openA" "inA".
    r_str "valA" "openA".

    r_subst "comB" "openB".
    r_str "openB" "comB".
    r_str_inp "openB" "inB".
    r_str "valB" "openB".
    repeat r_clean.

    r_subst "valB" "outA".
    r_str "outA" "valB".
    r_subst "valA" "outB".
    r_str "outB" "valA".
    repeat r_clean.

    r_subst "comA" "outB".
    r_str "outB" "comA".

    r_subst "comB" "outA".
    r_str "outA" "comB".
    repeat r_clean.
    rewrite /rps_simp.
    simpl.
    r_align.
    reflexivity.
  Qed.


Require Import Coq.Lists.List.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.DestructHead.

Lemma fold_right_impl_Proper {A} {P Q : A -> Prop} ls (concl1 concl2 : Prop)
      (Hconcl : concl1 -> concl2)
      (HPQ : forall a, In a ls -> Q a -> P a)
: fold_right (fun a (concl : Prop) => P a -> concl) concl1 ls
  -> fold_right (fun a (concl : Prop) => Q a -> concl) concl2 ls.
Proof. induction ls as [|x xs IHxs]; cbn [fold_right In] in *; intuition. Qed.

Lemma forall_In_existT {A P} {Q : forall a : A, P a -> Prop} ls
  : fold_right
      (fun xp (concl : Prop)
       => Q (projT1 xp) (projT2 xp) -> concl)
      (forall x p, In (@existT A P x p) ls -> Q x p)
      ls.
Proof.
  induction ls as [|x xs IHxs]; cbn [fold_right In]; intros;
    destruct_head' False; destruct_head'_or.
  eapply fold_right_impl_Proper; [ | | refine IHxs ]; intuition (subst; eauto).
Qed.

Lemma forall_In_pair_existT {A A' P P'} {Q : forall (a : A) (a' : A'), P a -> P' a' -> Prop} ls
  : fold_right
      (fun xp_x'p' (concl : Prop)
       => Q (projT1 (fst xp_x'p')) (projT1 (snd xp_x'p')) (projT2 (fst xp_x'p')) (projT2 (snd xp_x'p')) -> concl)
      (forall x p x' p', In (@existT A P x p, @existT A' P' x' p') ls -> Q x x' p p')
      ls.
Proof.
  induction ls as [|x xs IHxs]; cbn [fold_right In]; intros;
    destruct_head' False; destruct_head'_prod; destruct_head'_or; intros.
  eapply fold_right_impl_Proper; [ | | refine IHxs ]; intuition (inversion_prod; subst; eauto).
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export Classical_Prop.
Require Export per_props_equality.
(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(** printing mkc_axiom   $\mathtt{Ax}$ *)
(* begin hide *)

(* end hide*)

(* consistent spread sequence:
     - R is the spread
     - s a sequence
     - T its type
 *)
Definition mk_cons_spread_seq {o} (R : @NTerm o) s T x :=
  mk_all T
         x
         (mk_apply3 R (mk_var x) (mk_var s) (mk_apply (mk_var s) (mk_var x))).

Definition mk_spread_seq_ext {o} s n t m :=
  @mk_lam o m (mk_int_eq (mk_var m) n t (mk_apply s (mk_var m))).

(**

  Bar induction, where
    T is a type
    R is the spread law
    B is the bar
    con stands for consistent with the spread law
    ext(s,n,t) = \m. if m=n then t else s m
<<
   H |- f 0 c in X 0 c

     By strong_bar_induction T R B i a s con x m n t

     H |- T in Type(i)
     H, n:nat, s: nat_n -> T, t: T |- R n s t in Type(i)                                      // R is a well-formed spread law
     H, n:nat, s: nat_n -> T, con: (forall x: nat_n. R x s (s x)) |- (B n s) \/ not(B n s)    // B is decidable on consistent sequences in the spread
     H, a: nat -> T, con: (forall x: nat, R x a (a x)) |- squash(exists n:nat. B n a)         // B is a bar
     H, n:nat, s: nat_n -> T, con: (forall x: nat_n. R x s (s x)), m: B n s |- f n s in X n s // Base case: the conclusion is true at the bar
     H, n:nat, s: nat_n -> T, con: (forall x: nat_n. R x s (s x)),
        x: (forall t: {t:T | R n s t}.
              (f (n + 1) (ext(s,n,t))) in X (n + 1) (ext(s,n,t)))
        |- f n s in X n s
        // induction case
>>

*)

Definition rule_strong_bar_induction {o}
           (f X c T R B d : @NTerm o)
           (n s t con x a m : NVar)
           (i : nat)
           (H : barehypotheses) :=
  mk_rule
    (mk_bseq H (mk_conclax (mk_member (mk_apply2 f mk_zero c)
                                      (mk_apply2 X mk_zero c))))
    [ mk_bseq H (mk_conclax (mk_member T (mk_uni i))),
      mk_bseq (snoc (snoc (snoc H (mk_hyp n mk_tnat))
                          (mk_hyp s (mk_fun (mk_nat_sub (mk_var n)) T)))
                    (mk_hyp t T))
              (mk_conclax (mk_member (mk_apply3 R (mk_var n) (mk_var s) (mk_var t))
                                     (mk_uni i))),
      mk_bseq (snoc (snoc (snoc H (mk_hyp n mk_tnat))
                          (mk_hyp s (mk_fun (mk_nat_sub (mk_var n)) T)))
                    (mk_hyp con (mk_cons_spread_seq R s (mk_nat_sub (mk_var n)) x)))
              (mk_concl (mk_dec (mk_apply2 B (mk_var n) (mk_var s))) d),
      mk_bseq (snoc (snoc H (mk_hyp a (mk_fun mk_tnat T)))
                    (mk_hyp con (mk_cons_spread_seq R s mk_tnat x)))
              (mk_conclax (mk_squash
                             (mk_exists mk_tnat
                                        n
                                        (mk_apply2 B (mk_var n) (mk_var a))))),
      mk_bseq (snoc (snoc (snoc (snoc H (mk_hyp n mk_tnat))
                                (mk_hyp s (mk_fun (mk_nat_sub (mk_var n)) T)))
                          (mk_hyp t T))
                    (mk_hyp m (mk_apply2 B (mk_var n) (mk_var s))))
              (mk_conclax (mk_member (mk_apply2 f (mk_var n) (mk_var s))
                                     (mk_apply2 X (mk_var n) (mk_var s)))),
      mk_bseq (snoc (snoc (snoc (snoc H (mk_hyp n mk_tnat))
                                (mk_hyp s (mk_fun (mk_nat_sub (mk_var n)) T)))
                          (mk_hyp t T))
                    (mk_hyp x (mk_all (mk_set T t (mk_apply3 R (mk_var n) (mk_var s) (mk_var t)))
                                      t
                                      (mk_member (mk_apply2 f (mk_plus1 (mk_var n)) (mk_spread_seq_ext (mk_var s) (mk_var n) (mk_var t) m))
                                                 (mk_apply2 X (mk_plus1 (mk_var n)) (mk_spread_seq_ext (mk_var s) (mk_var n) (mk_var t) m))))))
              (mk_conclax (mk_member (mk_apply2 f (mk_var n) (mk_var s))
                                     (mk_apply2 X (mk_var n) (mk_var s))))
    ]
    [].

Lemma rule_strong_bar_induction_true {o} :
  forall lib (f X c T R B d : NTerm)
         (n s t con x a m : NVar)
         (i : nat)
         (H : @barehypotheses o),
    rule_true lib (rule_strong_bar_induction f X c T R B d n s t con x a m i H).
Proof.
  unfold rule_strong_bar_induction, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp  as [wf1 hyp1].
  destruct Hyp0 as [wf2 hyp2].
  destruct Hyp1 as [wf3 hyp3].
  destruct Hyp2 as [wf4 hyp4].
  destruct Hyp3 as [wf5 hyp5].
  destruct Hyp4 as [wf6 hyp6].
  destseq; allsimpl; proof_irr; GC.

  unfold closed_extract; simpl.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  vr_seq_true.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_member_iff.

(*
  generalize (teq_and_member_if_member
                (mk_apply2 X mk_zero c) (mk_apply2 f mk_zero c) s1 s2 H
                wT wt ct5 ct6 cT cT0 eqh sim); intro k.
  autodimp k hyp.

  admit.

  autodimp k hyp.

  clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.
*)

(*
  assert (forall (n1 n2 s1 s2 con1 con2 : CTerm),
            equal n1 n2 mk_tnat
            -> equal s1 s2 (mk_fun (mk_nat_sub (mk_var n)) T)
            -> equal con1 con2 (mk_cons_spread_seq R s mk_tnat x)
            -> !(tequality
                   (mkc_member
                      (mkc_apply2 (lsubstc f w1 s1 c1) mkc_zero (lsubstc c w3 s1 c3))
                      (mkc_apply2 (lsubstc X w0 s1 c0) mkc_zero (lsubstc c w3 s1 c3)))
                   (mkc_member
                      (mkc_apply2 (lsubstc f w1 s2 c4) mkc_zero (lsubstc c w3 s2 c6))
                      (mkc_apply2 (lsubstc X w0 s2 c7) mkc_zero (lsubstc c w3 s2 c6)))
                # member (mkc_apply2 (lsubstc f w1 s1 c1) mkc_zero (lsubstc c w3 s1 c3))
                        (mkc_apply2 (lsubstc X w0 s1 c0) mkc_zero (lsubstc c w3 s1 c3)))
            -> {t : CTerm
                , !(tequality
                      (mkc_member
                         (mk_apply2 f (mk_plus1 (mk_var n)) (mk_spread_seq_ext (mk_var s) (mk_var n) (mk_var t) m))
                         (mk_apply2 X (mk_plus1 (mk_var n)) (mk_spread_seq_ext (mk_var s) (mk_var n) (mk_var t) m)))
                      (mk_member
                         (mk_apply2 f (mk_plus1 (mk_var n)) (mk_spread_seq_ext (mk_var s) (mk_var n) (mk_var t) m))
                         (mk_apply2 X (mk_plus1 (mk_var n)) (mk_spread_seq_ext (mk_var s) (mk_var n) (mk_var t) m)))
                   # member (mkc_apply2 (lsubstc f w1 s1 c1) mkc_zero (lsubstc c w3 s1 c3))
                              (mkc_apply2 (lsubstc X w0 s1 c0) mkc_zero (lsubstc c w3 s1 c3)))})

  lsubst_tac; auto.
*)

Abort.


Require Import List.
Require Import ExtLib.Structures.Sets.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.List.
Require Import ExtLib.Structures.Reducible.

Set Implicit Arguments.
Set Strict Implicit.

Section ListSet.

  Definition lset (T : Type) : Type :=
    list T.

  Variable T : Type.
  Variable R_dec : T -> T -> bool.

  Fixpoint lset_contains (v : T) (ls : lset T) : bool :=
    match ls with
      | nil => false
      | l :: ls => if R_dec v l then true else lset_contains v ls
    end.

  Definition lset_empty : lset T := nil.

  Definition lset_add (v : T) (ls : lset T) : lset T :=
    if lset_contains v ls then ls else v :: ls.

  Definition lset_remove (v : T) : lset T -> lset T :=
    List.filter (fun x => negb (R_dec v x)).

  Definition lset_union (l r : lset T) : lset T :=
    fold_left (fun x y => lset_add y x) l r.

  Definition lset_difference (l r : lset T) : lset T :=
    List.filter (fun x => negb (lset_contains x r)) l.

  Definition lset_intersect (l r : lset T) : lset T :=
    List.filter (fun x => lset_contains x r) l.

  Definition lset_subset (l r : lset T) : bool :=
    allb (fun x => lset_contains x r) l.

End ListSet.

Global Instance DSet_weak_listset {T} (R : T -> T -> Prop)
  (R_dec : RelDec R) : DSet (@lset T) T :=
{ contains  := lset_contains rel_dec
; empty     := lset_empty T
; add       := lset_add rel_dec
; singleton := fun x => lset_add rel_dec x (lset_empty T)
; remove    := lset_remove rel_dec
; union     := lset_union rel_dec
; intersect := lset_intersect rel_dec
; difference := lset_difference rel_dec
; subset     := lset_subset rel_dec
; filter     := @List.filter _
}.

Global Instance Foldable_listset {T} (R : T -> T -> Prop)
  : Foldable (lset T) T :=
  fun _ f a t => List.fold_left (fun x y => f y x) t a.

Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Programming.Eqv.

Global Instance PFunctor_listset : PFunctor lset :=
{ FunP := fun t => { eqT : Eqv t & RelDec eqv }
; pfmap := fun _ B eqv_dec f s =>
  List.fold_left (fun acc x => lset_add (@rel_dec B (@eqv B (projT1 eqv_dec)) (projT2 eqv_dec)) (f x) acc) s (@lset_empty _)
}.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal10.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_2  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_3  := ( Cons (Succ Zero) Nil).
Definition lfind_example_4  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_5  := ( Nil).
Definition lfind_example_6  := ( Cons Zero Nil).
Definition lfind_example_7  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_8  := ( Nil).
Definition lfind_example_9  := ( Cons (Succ Zero)         (Cons Zero            (Cons Zero               (Cons (Succ (Succ Zero))                  (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)))))).
Definition lfind_example_10  := ( Cons Zero Nil).
Definition lfind_example_11  := ( Nil).
Definition lfind_example_12  := ( Nil).
Definition lfind_example_13  := ( Cons (Succ Zero) Nil).
Definition lfind_example_14  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal10_append_assoc_37_append_Nil/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 .