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

Require Export mediatrice.
Set Implicit Arguments.
Unset Strict Implicit.

Definition isocele (A B C : PO) : Prop := distance A B = distance A C.

Lemma isocele_permute : forall A B C : PO, isocele A B C -> isocele A C B.
unfold isocele in |- *; intros; auto.
Qed.
Hint Immediate isocele_permute: geo.

Lemma isocele_mediatrice :
 forall A B C : PO, isocele A B C -> mediatrice B C A.
unfold isocele, mediatrice in |- *; intros; auto.
Qed.

Lemma mediatrice_isocele :
 forall A B C : PO, mediatrice B C A -> isocele A B C.
unfold isocele, mediatrice in |- *; intros; auto.
Qed.

Lemma mediane_hauteur_isocele :
 forall A B C I : PO,
 I = milieu B C -> orthogonal (vec B C) (vec I A) -> isocele A B C.
intros.
apply mediatrice_isocele.
discrimine B C.
unfold mediatrice in |- *; auto with geo.
apply orthogonale_segment_milieu_mediatrice with I; auto.
Qed.

Lemma mediane_isocele_hauteur :
 forall A B C I : PO,
 I = milieu B C -> isocele A B C -> orthogonal (vec I A) (vec B C).
intros.
discrimine B C.
VReplace (vec C C) zero.
auto with geo.
apply mediatrice_orthogonale_segment; auto.
apply milieu_mediatrice; auto.
Qed.

Lemma hauteur_isocele_mediane :
 forall A B C I : PO,
 B <> C ->
 orthogonal (vec B C) (vec I A) ->
 isocele A B C -> alignes B C I -> I = milieu B C.
intros A B C I H0 H1 H2 H3; try assumption.
soit_projete B C A ipattern:(H).
apply mediatrice_projete_milieu with A; auto.
rewrite <- H4.
apply unicite_projete_orthogonal with (3 := H1); auto.
Qed.

Lemma isocele_mediane_bissectrice :
 forall A B C I : PO,
 A <> I ->
 B <> C ->
 I = milieu B C ->
 isocele A B C -> cons_AV (vec A B) (vec A I) = cons_AV (vec A I) (vec A C).
intros.
apply mediatrice_milieu_angles; auto.
Qed.

Lemma isocele_angles_base :
 forall A B C : PO,
 A <> B ->
 A <> C ->
 B <> C ->
 isocele A B C -> cons_AV (vec B C) (vec B A) = cons_AV (vec C A) (vec C B).
intros A B C H H0 H1; try assumption.
soit_milieu B C ipattern:(K).
elim (classic (A = K)); intros.
apply permute_angles; auto.
rewrite <- H6 in H5.
rewrite <- H6 in H2.
rewrite <- (angles_milieu (A:=C) (B:=B) (C:=C) (I:=A)); auto.
rewrite <- (angles_milieu2 (A:=B) (B:=B) (C:=C) (I:=A)); auto with geo.
cut (orthogonal (vec B C) (vec K A)); intros.
cut (cons_AV (vec K B) (vec K A) = cons_AV (vec K A) (vec K C)); intros.
cut (cons_AV (vec A B) (vec A K) = cons_AV (vec A K) (vec A C)); intros.
rewrite (angles_milieu (A:=A) (B:=B) (C:=C) (I:=K)); auto.
generalize (somme_triangle (A:=A) (B:=B) (C:=K)); auto; intros.
generalize (somme_triangle (A:=A) (B:=K) (C:=C)); auto; intros.
rewrite (angles_milieu2 (A:=A) (B:=B) (C:=C) (I:=K)); auto.
replace (cons_AV (vec B K) (vec B A)) with
 (plus (image_angle pi)
    (opp (plus (cons_AV (vec A B) (vec A K)) (cons_AV (vec K A) (vec K B))))).
replace (cons_AV (vec C A) (vec C K)) with
 (plus (image_angle pi)
    (opp (plus (cons_AV (vec A K) (vec A C)) (cons_AV (vec K C) (vec K A))))).
rewrite H9.
replace (cons_AV (vec K C) (vec K A)) with (cons_AV (vec K A) (vec K B));
 auto with geo.
rewrite <- H11; auto.
mesure A K A C.
mesure K C K A.
mesure C A C K.
replace (x + (x0 + x1) + - (x + x0)) with x1; auto.
ring.
rewrite <- H10; auto.
mesure K A K B.
mesure A B A K.
mesure B K B A.
replace (x0 + (x1 + x) + - (x0 + x)) with x1; auto.
ring.
generalize (isocele_mediane_bissectrice (A:=A) (B:=B) (C:=C) (I:=K)); auto;
 intros.
generalize (milieu_angles_orthogonaux (A:=B) (B:=C) (M:=K) (N:=A)); auto;
 intros.
generalize (mediane_isocele_hauteur (A:=A) (B:=B) (C:=C) (I:=K));
 auto with geo; intros.
Qed.

Lemma diametre_rectangle :
 forall A B C C' : PO,
 A <> B ->
 C' = milieu A B ->
 distance C' C = distance C' A -> orthogonal (vec C A) (vec C B).
intros.
discrimine C A.
apply ortho_sym.
replace (vec A A) with zero.
apply zero_ortho_tout.
Ringvec.
discrimine C B.
replace (vec B B) with zero.
apply zero_ortho_tout.
Ringvec.
cut (B <> C'); intros.
cut (A <> C'); intros.
cut (C <> C'); intros.
apply angles_orthogonal; auto.
cut (isocele C' C A); intros.
cut (isocele C' B C); intros.
generalize (isocele_angles_base (A:=C') (B:=C) (C:=A)); auto; intros.
generalize (isocele_angles_base (A:=C') (B:=B) (C:=C)); auto; intros.
generalize (somme_triangle (A:=C') (B:=C) (C:=A)); intros.
generalize (somme_triangle (A:=C') (B:=B) (C:=C)); intros.
replace (double_AV (cons_AV (vec C A) (vec C B))) with
 (plus (double_AV (cons_AV (vec C A) (vec C C')))
    (double_AV (cons_AV (vec C C') (vec C B)))).
replace (double_AV (cons_AV (vec C A) (vec C C'))) with
 (plus (cons_AV (vec C A) (vec C C')) (cons_AV (vec A C') (vec A C))).
replace (double_AV (cons_AV (vec C C') (vec C B))) with
 (plus (cons_AV (vec B C) (vec B C')) (cons_AV (vec C C') (vec C B))).
replace (plus (cons_AV (vec B C) (vec B C')) (cons_AV (vec C C') (vec C B)))
 with (plus (image_angle pi) (opp (cons_AV (vec C' B) (vec C' C)))).
replace (plus (cons_AV (vec C A) (vec C C')) (cons_AV (vec A C') (vec A C)))
 with (plus (image_angle pi) (opp (cons_AV (vec C' C) (vec C' A)))).
rewrite def_opp; auto.
rewrite def_opp; auto.
mesure C' A C' C.
mesure C' C C' B.
replace (pi + x + (pi + x0)) with (pi + pi + (x + x0)).
replace (pi + pi) with deuxpi; auto.
rewrite add_mes_compatible; rewrite pi_plus_pi; rewrite <- add_mes_compatible.
replace (0 + (x + x0)) with (x + x0); auto.
rewrite add_mes_compatible.
rewrite H14; rewrite H13.
replace
 (plus (cons_AV (vec C' A) (vec C' C)) (cons_AV (vec C' C) (vec C' B))) with
 (cons_AV (vec C' A) (vec C' B)).
rewrite <- (milieu_vecteur (A:=A) (B:=B) (M:=C')); auto.
rewrite <- angle_plat; auto.
rewrite Chasles; auto.
ring.
ring.
rewrite <- H11; auto.
rewrite <- H9; auto.
mesure C' C C' A.
mesure C A C C'.
replace (x + (x0 + x0) + - x) with (x0 + x0); auto.
ring.
rewrite <- H12; auto.
rewrite <- H10; auto.
mesure C' B C' C.
mesure B C B C'.
replace (x + (x0 + x0) + - x) with (x0 + x0); auto.
ring.
rewrite H10; auto.
rewrite H9; auto.
rewrite double_Chasles; auto.
unfold isocele in |- *.
rewrite H1.
apply carre_scalaire_egalite_distance.
rewrite <- (milieu_vecteur (A:=A) (B:=B) (M:=C')); auto.
replace (vec A C') with (mult_PP (-1) (vec C' A)); auto.
Simplscal.
Ringvec.
unfold isocele in |- *.
rewrite H1; auto.
apply isometrie_distinct with (1 := H5).
rewrite distance_sym.
rewrite <- H1; rewrite distance_sym; auto.
rewrite H0.
apply milieu_distinct; auto.
rewrite H0.
apply milieu_distinct2; auto.
Qed.


(* Check that the encoding of system U- fails *)

Require Hurkens.

Inductive prop : Prop := down : Prop -> prop.

(* Coq should reject the following access of a Prop buried inside
   a prop. *)

Fail Definition up (p:prop) : Prop := let (A) := p in A.

(* Otherwise, we would have a proof of False via Hurkens' paradox *)

Fail Definition paradox : False :=
 Hurkens.NoRetractFromSmallPropositionToProp.paradox
   prop
   down
   up
   (fun (A:Prop) (x:up (down A)) => (x:A))
   (fun (A:Prop) (x:A) => (x:up (down A)))
   False.


(** * Counts how many binders there are *)
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.CountLets.
Require Import Crypto.Compilers.Named.Syntax.
Require Import Crypto.Compilers.SmartMap.

Local Open Scope ctype_scope.
Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {Name : Type}.

  Local Notation flat_type := (flat_type base_type_code).
  Local Notation type := (type base_type_code).

  Local Notation count_pairs := (@count_pairs base_type_code).

  Local Notation exprf := (@Named.exprf base_type_code op Name).
  Local Notation expr := (@Named.expr base_type_code op Name).

  Section gen.
    Context (count_type_let : flat_type -> nat).
    Context (count_type_abs : flat_type -> nat).

    Fixpoint count_lets_genf {t} (e : exprf t) : nat
      := match e with
         | LetIn tx _ _ _ eC
           => count_type_let tx + @count_lets_genf _ eC
         | Op _ _ _ e => @count_lets_genf _ e
         | Pair _ ex _ ey => @count_lets_genf _ ex + @count_lets_genf _ ey
         | _ => 0
         end.
    Definition count_lets_gen {t} (e : expr t) : nat
      := match e with
         | Abs tx _ _ f => count_type_abs tx + @count_lets_genf _ f
         end.
  End gen.

  Definition count_let_bindersf {t} (e : exprf t) : nat
    := count_lets_genf count_pairs e.
  Definition count_letsf {t} (e : exprf t) : nat
    := count_lets_genf (fun _ => 1) e.
  Definition count_let_binders {t} (e : expr t) : nat
    := count_lets_gen count_pairs (fun _ => 0) e.
  Definition count_lets {t} (e : expr t) : nat
    := count_lets_gen (fun _ => 1) (fun _ => 0) e.
  Definition count_binders {t} (e : expr t) : nat
    := count_lets_gen count_pairs count_pairs e.
End language.


Require Import GHC.Base.
Import Notations.
Require Import GHC.Num.
Import Notations.
Require Import Proofs.GHC.Base.

From Coq Require Import ssrbool ssreflect.
Set Bullet Behavior "Strict Subproofs".

Require Import OrderedType.
Require Import OrdTactic.
Require Import CustomTactics.

Module OrdTheories(E: OrderedType).
  Instance Eq_t : GHC.Base.Eq_ E.t :=
    fun _ k => k {|
                op_zeze____ := fun x y => E.eq_dec x y;
                op_zsze____ := fun x y => negb (E.eq_dec x y);
              |}.

  Local Definition ot_compare (x y: E.t) : comparison :=
    match E.compare x y with
    | EQ _ => Eq
    | LT _ => Lt
    | GT _ => Gt
    end.

  Instance Ord_t : GHC.Base.Ord E.t := GHC.Base.ord_default ot_compare.

  Module OrdFacts := OrderedTypeFacts(E).

  Ltac rewrite_compare_e :=
    rewrite /compare /Ord_t /ord_default /= /ot_compare.

  Definition elt := E.t.

  Lemma elt_eqP { e1 e2 } : reflect (E.eq e1 e2) (e1 GHC.Base.== e2).
  Proof.
    rewrite /_GHC.Base.==_ /Eq_t /=.
    destruct (E.eq_dec e1 e2); constructor; auto.
  Qed.

  Lemma elt_ltP { e1 e2 } : reflect (E.lt e1 e2) (e1 GHC.Base.< e2).
  Proof.
    rewrite /_GHC.Base.<_ /Ord_t /ord_default /=.
    rewrite /_GHC.Base.==_ /Eq_comparison___ /= /eq_comparison /ot_compare.
    do 2 destruct_match=>//; constructor; auto.
  Qed.

  Lemma elt_leP { e1 e2 } : reflect (OrdFacts.TO.le e1 e2) (e1 GHC.Base.<= e2).
  Proof.
    rewrite /_GHC.Base.<=_ /Ord_t /ord_default /=.
    rewrite /_GHC.Base.==_ /Eq_comparison___ /= /eq_comparison /ot_compare.
    do 2 destruct_match=>//; constructor; auto;
      rewrite /OrdFacts.TO.le /OrdFacts.TO.eq /OrdFacts.TO.lt;
      intuition; OrdFacts.order.
  Qed.

  Lemma elt_gtP { e1 e2 } : reflect (E.lt e2 e1) (e1 GHC.Base.> e2).
  Proof.
    rewrite /_GHC.Base.>_ /Ord_t /ord_default /=.
    rewrite /_GHC.Base.==_ /Eq_comparison___ /= /eq_comparison /ot_compare.
    do 2 destruct_match=>//; constructor; auto.
  Qed.

  Lemma elt_geP { e1 e2 } : reflect (OrdFacts.TO.le e2 e1) (e1 GHC.Base.>= e2).
  Proof.
    rewrite /_GHC.Base.>=_ /Ord_t /ord_default /=.
    rewrite /_GHC.Base.==_ /Eq_comparison___ /= /eq_comparison /ot_compare.
    do 2 destruct_match=>//; constructor; auto;
      rewrite /OrdFacts.TO.le /OrdFacts.TO.eq /OrdFacts.TO.lt;
      intuition; OrdFacts.order.
  Qed.

  Lemma elt_compare_ltP {e1 e2} :
    reflect (E.lt e1 e2) (eq_comparison (compare e1 e2) Lt).
  Proof.
    rewrite_compare_e; destruct_match; constructor; auto.
  Qed.

  Lemma elt_compare_lt'P {e1 e2} :
    reflect (compare e1 e2 = Lt)
            (eq_comparison (compare e1 e2) Lt).
  Proof.
    rewrite_compare_e.
    destruct_match; constructor; auto;
      move=>Hcontra; inversion Hcontra.
  Qed.

  Lemma elt_compare_gtP {e1 e2} :
    reflect (E.lt e2 e1) (eq_comparison (compare e1 e2) Gt).
  Proof.
    rewrite_compare_e; destruct_match; constructor; auto.
  Qed.

  Lemma elt_compare_gt'P {e1 e2} :
    reflect (compare e1 e2 = Gt)
            (eq_comparison (compare e1 e2) Gt).
  Proof.
    rewrite_compare_e.
    destruct_match; constructor; auto;
      move=>Hcontra; inversion Hcontra.
  Qed.

  Lemma elt_compare_eqP {e1 e2} :
    reflect (E.eq e1 e2) (eq_comparison (compare e1 e2) Eq).
  Proof.
    rewrite_compare_e; destruct_match; constructor; auto.
  Qed.

  Lemma elt_compare_eq'P {e1 e2} :
    reflect (compare e1 e2 = Eq)
            (eq_comparison (compare e1 e2) Eq).
  Proof.
    rewrite_compare_e.
    destruct_match; constructor; auto;
      move=>Hcontra; inversion Hcontra.
  Qed.

  Hint Resolve elt_eqP.
  Hint Resolve elt_ltP.
  Hint Resolve elt_gtP.
  Hint Resolve elt_leP.
  Hint Resolve elt_geP.
  Hint Resolve elt_compare_ltP.
  Hint Resolve elt_compare_lt'P.
  Hint Resolve elt_compare_gtP.
  Hint Resolve elt_compare_gt'P.
  Hint Resolve elt_compare_eqP.
  Hint Resolve elt_compare_eq'P.

  Lemma elt_eq : forall e1 e2, E.eq e1 e2 <-> e1 GHC.Base.== e2.
  Proof. move=>e1 e2. apply rwP =>//. Qed.

  Lemma elt_lt : forall e1 e2, E.lt e1 e2 <-> e1 GHC.Base.< e2.
  Proof. move=>e1 e2. apply rwP =>//. Qed.

  Lemma elt_gt : forall e1 e2, E.lt e2 e1 <-> e1 GHC.Base.> e2.
  Proof. move=>e1 e2. apply rwP =>//. Qed.

  Lemma elt_le : forall e1 e2, OrdFacts.TO.le e1 e2 <-> e1 GHC.Base.<= e2.
  Proof. move=>e1 e2. apply rwP =>//. Qed.

  Lemma elt_ge : forall e1 e2, OrdFacts.TO.le e2 e1 <-> e1 GHC.Base.>= e2.
  Proof. move=>e1 e2. apply rwP =>//. Qed.

  Lemma elt_compare_lt: forall (e1 e2 : elt),
      E.lt e1 e2 <-> compare e1 e2 = Lt.
  Proof.
    move=>e1 e2.
    apply rwP2 with (b:=eq_comparison (compare e1 e2) Lt) =>//.
  Qed.

  Lemma elt_compare_gt: forall (e1 e2 : elt),
      E.lt e2 e1 <-> compare e1 e2 = Gt.
  Proof.
    move=>e1 e2.
    apply rwP2 with (b:=eq_comparison (compare e1 e2) Gt) =>//.
  Qed.

  Lemma elt_compare_eq: forall (e1 e2 : elt),
       E.eq e1 e2 <-> compare e1 e2 = Eq.
  Proof.
    move=>e1 e2.
    apply rwP2 with (b:=eq_comparison (compare e1 e2) Eq) =>//.
  Qed.

  Hint Rewrite <- elt_eq : elt_compare.
  Hint Rewrite <- elt_lt : elt_compare.
  Hint Rewrite <- elt_gt : elt_compare.
  Hint Rewrite <- elt_le : elt_compare.
  Hint Rewrite <- elt_ge : elt_compare.
  Hint Rewrite <- elt_compare_lt : elt_compare.
  Hint Rewrite <- elt_compare_gt : elt_compare.
  Hint Rewrite <- elt_compare_eq : elt_compare.

  Instance EqLaws_elt : EqLaws elt.
  Proof.
    constructor.
    - rewrite /ssrbool.reflexive. intros.
      apply /elt_eqP. auto.
    - rewrite /ssrbool.symmetric. intros x y.
      apply /elt_eqP. destruct_match; move: Heq; move /elt_eqP; auto.
    - rewrite /ssrbool.transitive. intros y x z.
      move /elt_eqP => H1 /elt_eqP H2. apply /elt_eqP; OrdFacts.order.
    - intros x y. rewrite /_GHC.Base./=_ /Eq_t /=.
      rewrite negb_involutive. apply /elt_eqP.
      destruct_match; move: Heq; move /elt_eqP; auto.
  Defined.

  (** [rewrite -/is_true] does not work, so we use this: *)
  Ltac rewrite_is_true :=
      match goal with
      | [ |- ?e = true -> _ ] => replace (e = true) with (is_true e) by reflexivity;
                              autorewrite with elt_compare; move=>?
      | [ |- ?e = true] => replace (e = true) with (is_true e) by reflexivity;
                         autorewrite with elt_compare
      end.

  Instance OrdLaws_elt : OrdLaws elt.
  Proof.
    constructor.
    all: repeat match goal with
                | [ |- _ -> _ ] => first [rewrite_is_true | intro]
                end; try rewrite_is_true;
      try OrdFacts.order.
    Local Ltac solve_iff lem:=
      autorewrite with elt_compare;
      split; [intro; apply /lem; OrdFacts.order |
              case /lem; OrdFacts.order].
    all: try solve [autorewrite with elt_compare; split;
                    [(intro; apply /elt_leP; OrdFacts.order) |
                     (move /elt_leP; OrdFacts.order)]].
    all: try solve [autorewrite with elt_compare; split;
                    [(intro; apply /elt_eqP; OrdFacts.order) |
                     (move /elt_eqP; OrdFacts.order)]].
    all: try solve [apply /elt_leP; destruct_match; move: Heq;
                    move /elt_leP; OrdFacts.order].
    - destruct (OrdFacts.lt_total a b) as [|[|]];
        (left + right); solve [rewrite_is_true; OrdFacts.order].
  Defined.
End OrdTheories.

Module CompareTactics.
Ltac destruct_compare :=
  match goal with
  | [ H :context[match (compare ?a ?b) with _ => _ end] |- _] =>
    let Heq := fresh "Heq" in
    destruct (compare a b) eqn:Heq=>//;
    autorewrite with elt_compare in Heq
  | [ |- context[match (compare ?a ?b) with _ => _ end]] =>
    let Heq := fresh "Heq" in
    destruct (compare a b) eqn:Heq=>//;
    autorewrite with elt_compare in Heq
  end.
End CompareTactics.


(*! Test various forms of switches !*)
Require Import Koika.Frontend.

Definition clocksz := 2.
Definition idxsz := 5.
Definition datasz := 64.

Inductive reg_t := clock | index | data (idx: Vect.index (pow2 idxsz)) | output.
Inductive rule_name_t := sequential_copy | tree_copy | comb_copy | function_switch | manual_switch | tick.

Definition R r :=
  match r with
  | clock => bits_t 2
  | index => bits_t idxsz
  | data _ => bits_t datasz
  | output => bits_t datasz
  end.

Definition r idx : R idx :=
  match idx with
  | clock => Bits.zero
  | index => Bits.zero
  | data idx => Bits.app (Bits.zeroes (datasz - idxsz)) (Bits.of_index idxsz idx)
  | output => Bits.zero
  end.

Definition rule clock_condition style : uaction reg_t empty_ext_fn_t :=
  {{
      if read0(clock) != `clock_condition` then fail else pass;
      let idx := read0(index) in
      write0(output, `UCompleteSwitch style idxsz "idx" (fun idx => {{ read0(data idx) }})`)
  }}.

Definition another_fn : UInternalFunction reg_t empty_ext_fn_t :=
  {{ fun another_fn (x: bits_t 1) : bits_t 1 => x }}.

(* Regression test *)
Definition simple_match_fn : UInternalFunction reg_t empty_ext_fn_t :=
  {{ fun simple_match_fn (x: bits_t 1) : bits_t 1 =>
       match x with
       | #Ob~0 =>
           if (another_fn(Ob~0))
           then Ob~0
           else Ob~1
       | #Ob~1 =>
           Ob~1
       return default: (Ob~0)
       end
   }}.

Definition urules rl : uaction reg_t empty_ext_fn_t :=
  match rl with
  | sequential_copy => rule {{ |clocksz`d0| }} (SequentialSwitch (bits_t datasz) "tmp")
  | tree_copy => rule {{ |clocksz`d1| }} TreeSwitch
  | comb_copy => rule {{ |clocksz`d2| }} NestedSwitch
  | function_switch => {{ ignore(simple_match_fn (Ob~0)) }}
  | manual_switch => {{ match read0(clock) with
                       | #Ob~0~0 => pass
                       | #Ob~0~1 => pass
                       | #Ob~1~0 => pass
                       | #Ob~1~1 => pass
                       return default: pass
                       end }}
  | tick => {{ write0(clock, read0(clock) + |clocksz`d1|);
              let idx := read0(index) in
              write0(index, idx << |idxsz`d2| + idx + |idxsz`d17|) }}
  end.

Definition rules :=
  tc_rules R empty_Sigma urules.

Definition sched : scheduler :=
  sequential_copy |> tree_copy |> comb_copy |> manual_switch |> function_switch |> tick |> done.

Definition package :=
  {| ip_koika := {| koika_reg_types := R;
                   koika_reg_init := r;
                   koika_ext_fn_types := empty_Sigma;
                   koika_rules := rules;
                   koika_rule_external _ := false;
                   koika_scheduler := sched;
                   koika_module_name := "switches" |};

     ip_sim := {| sp_ext_fn_specs := empty_ext_fn_props;
                 sp_prelude := None |};

     ip_verilog := {| vp_ext_fn_specs := empty_ext_fn_props |} |}.

Definition prog := Interop.Backends.register package.
Extraction "switches.ml" prog.


(* (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 finset.
Require Import paths.
Require Import connect.
Require Import hypermap.
Require Import geometry.
Require Import jordan.
Require Import color.
Require Import coloring.

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

Section Patch.

(* Patching two maps to cover a larger one. The relations established here *)
(* are used in both directions: with sew, to deduce the properties of the  *)
(* new map created by glueing, and in snip, to deduce the properties of    *)
(* the two maps created by cutting along an rlink cycle.                   *)
(* It is important to note that the relations between the two parts is     *)
(* not quite symmetrical: the border of the inside ("disk") map is an edge *)
(* cycle, while the border of the outer ("remainder") part is a node orbit *)
(* The disk border must be simple, but only in the "disk" map; the         *)
(* corresponding sequence in the main and remainder maps needs not be.     *)
(* At the end of this file is the first application of patching: we prove  *)
(* that a minimal counter example must be connected.                       *)

Variables (g gd gr : hypermap) (hd : gd -> g) (hr : gr -> g).
Variables (bgd : seq gd) (bgr : seq gr).

Record patch : Prop := Patch {
  patch_injd : injective hd;
  patch_injr : injective hr;
  patch_cycle_d : sfcycle edge bgd;
  patch_cycle_r : ufcycle node bgr;
  patch_maps_ring_r : maps hr bgr = rev (maps hd bgd);
  patch_codom_r : codom hr =1 setU (setC (codom hd)) (maps hd bgd);
  patch_edge_d : forall xd, setC bgd xd -> hd (edge xd) = edge (hd xd);
  patch_node_d : forall xd, hd (node xd) = node (hd xd);
  patch_edge_r : forall xr, hr (edge xr) = edge (hr xr);
  patch_node_r : forall xr, setC bgr xr -> hr (node xr) = node (hr xr)
}.

Hypothesis Hgh : patch.

Let Ihd := patch_injd Hgh.
Let Ihr := patch_injr Hgh.
Let Hbgd := patch_cycle_d Hgh.
Let Hbgr := patch_cycle_r Hgh.
Let bg := maps hd bgd.
Let Dbgr : maps hr bgr = rev bg := patch_maps_ring_r Hgh.
Let Ehr := patch_codom_r Hgh.
Remark Patch_Ebgr : maps hr bgr =1 bg. Proof. rewrite Dbgr; apply mem_rev. Qed.
Let Ebgr := Patch_Ebgr.
Remark Patch_Ehd : codom hd =1 setU (setC (codom hr)) bg.
Proof.
move=> x; rewrite /setU /setC Ehr /setU /setC negb_orb negb_elim andbC orbC -/bg.
by case Hx: (bg x); first by case/mapsP: Hx => [xd _ <-]; rewrite codom_f.
Qed.
Let Ehd := Patch_Ehd.
Let EdE := patch_edge_d Hgh.
Let EdN := patch_node_d Hgh.
Let ErE := patch_edge_r Hgh.
Let ErN := patch_node_r Hgh.

Remark Patch_Ubgd : uniq bgd. Proof. by case (andP (scycle_ucycle Hbgd)). Qed.
Let Ubgd := Patch_Ubgd.
Remark Patch_Ubgr : uniq bgr. Proof. by case (andP Hbgr). Qed.
Let Ubgr := Patch_Ubgr.
Remark Patch_Ubg : uniq bg. Proof. by rewrite /bg (uniq_maps Ihd) Ubgd. Qed.
Let Ubg := Patch_Ubg.

Remark Patch_Ebgdr : forall xd, codom hr (hd xd) = bgd xd.
Proof. by move=> *; rewrite Ehr /setU /setC codom_f /bg (mem_maps Ihd). Qed.
Let Ebgdr := Patch_Ebgdr.

Remark Patch_EbgdE : forall xd : gd, bgd xd -> cedge xd =1 bgd.
Proof. by apply: fconnect_cycle; case (andP Hbgd). Qed.
Let EbgdE := Patch_EbgdE.

Remark Patch_Ebgrd : forall xr : gr, codom hd (hr xr) = bgr xr.
Proof. by move=> *; rewrite Ehd /setU /setC codom_f -Ebgr (mem_maps Ihr). Qed.
Let Ebgrd := Patch_Ebgrd.

Remark Patch_EbgrN : forall xr : gr, bgr xr -> cnode xr =1 bgr.
Proof. by apply: fconnect_cycle; case (andP Hbgr). Qed.
Let EbgrN := Patch_EbgrN.

Remark Patch_EhdUr : setU (codom hd) (codom hr) =1 g.
Proof. by move=> x; rewrite /setU Ehr /setU /setC; case (codom hd x). Qed.
Let EhdUr := Patch_EhdUr.

Remark Patch_EhdIr : setI (codom hd) (codom hr) =1 bg.
Proof.
move=> x; rewrite /setI Ehr /setU /setC; case Hx: (codom hd x); auto.
by symmetry; apply/mapsP => [[xd _ Dx]]; rewrite -Dx codom_f in Hx.
Qed.
Let EhdIr := Patch_EhdIr.

Lemma card_patch : card gd + card gr = size bg + card g.
Proof.
rewrite -(card_codom Ihd) -(card_codom Ihr) -cardUI (eq_card EhdUr) addnC.
by rewrite (eq_card EhdIr) (card_uniqP Ubg).
Qed.

Remark Patch_HbgdE : fclosed edge bgd.
Proof.
apply: (intro_closed (Sedge _)) => [xd yd Dyd Hxd] /=.
move/andP: Hbgd => [H _]; rewrite -{H}(fconnect_cycle H Hxd); exact (connect1 Dyd).
Qed.
Let HbgdE := Patch_HbgdE.

Remark Patch_HbgrN : fclosed node bgr.
Proof.
apply: (intro_closed (Snode _)) => [xr yr Dyr Hxr] /=.
case/andP: Hbgr => [H _]; rewrite -{H}(fconnect_cycle H Hxr); exact (connect1 Dyr).
Qed.
Let HbgrN := Patch_HbgrN.

Remark Patch_EdErN : forall xd xr,
  (hd (edge xd) =d hr xr) = (hd xd =d hr (node xr)).
Proof.
move=> xd xr; case Hxd: (bgd xd).
  case/andP: Hbgd => [CdE _]; case/andP: Hbgr => [CrN _].
  rewrite (eqP (next_cycle CdE Hxd)) -(next_maps Ihd Ubgd) -/bg.
  rewrite (monic2F_eqd (prev_next Ubg)) -(next_rev Ubg) -Dbgr.
  rewrite (next_maps Ihr Ubgr).
  case Hxr: (bgr xr); first by rewrite -(eqP (next_cycle CrN Hxr)).
  have Hxdr: (maps hr bgr (hd xd)) by rewrite Ebgr /bg (mem_maps Ihd).
  apply/eqP/eqP => Exr.
    by rewrite Exr (mem_maps Ihr) mem_next Hxr in Hxdr.
  by rewrite Exr (mem_maps Ihr) -(HbgrN (x := xr) (set11 _)) Hxr in Hxdr.
apply/eqP/eqP => Exd.
move: (EhdIr (hr xr)); rewrite /setI codom_f -Exd codom_f.
  by rewrite /bg (mem_maps Ihd) -(HbgdE (x := xd) (set11 _)) Hxd.
  move: (EhdIr (hr (node xr))); rewrite /setI codom_f -Exd codom_f.
by rewrite /bg (mem_maps Ihd) Hxd.
Qed.
Let EdErN := Patch_EdErN.

Remark Patch_HbgdP : forall xd, bgd xd ->
  exists2 xr, hd (edge xd) = hr xr & hd xd = hr (node xr).
Proof.
move=> xd Hxd; have Hxr: (codom hr (hd xd)).
  by rewrite Ehr /setU /bg (mem_maps Ihd) Hxd orbT.
case/set0Pn: Hxr => [xr Dxr]; rewrite /preimage -(Eedge _ xr) in Dxr.
by exists (face (edge xr)); apply: eqP; first by rewrite EdErN.
Qed.
Let HbgdP := Patch_HbgdP.

Remark Patch_HbgrP : forall xr, bgr xr ->
  exists2 xd, hd (edge xd) = hr xr & hd xd = hr (node xr).
Proof.
move=> xr Hxr; have Hxd: (codom hd (hr xr)).
  by rewrite Ehd /setU -Ebgr (mem_maps Ihr) Hxr orbT.
case/set0Pn: Hxd => [xd Dxd]; rewrite /preimage -(Eface _ xd) in Dxd.
by exists (node (face xd)); apply: eqP; rewrite -?EdErN eqd_sym.
Qed.
Let HbgrP := Patch_HbgrP.

Remark Patch_EdF : forall xd, setC bgd xd -> hd (face xd) = face (hd xd).
Proof.
move=> xd Hxd; apply (monic_move (monicF_sym (Eface g))).
rewrite /setC -(Eface _ xd) -(fun yd => HbgdE (x := yd) (set11 _)) in Hxd.
by rewrite -EdN -EdE ?Eface.
Qed.
Let EdF := Patch_EdF.

Remark Patch_ErF : forall xr, setC bgr (face xr) -> face (hr xr) = hr (face xr).
Proof. by move=> xr Hxr; rewrite -{1}[xr]Eface ErE (ErN Hxr) Enode. Qed.
Let ErF := Patch_ErF.

Remark Patch_EdrF : forall xd xr,
  (hr (face xr) =d hd xd) = (hd (face xd) =d face (hr xr)).
Proof.
move=> xd xr; rewrite -{2}[xr]Eface -{1}[xd]Eface ErE.
by rewrite -(monic2F_eqd (Enode g)) -EdN eqd_sym EdErN.
Qed.
Let EdrF := Patch_EdrF.

Let bbd := fband bgd.

Lemma patch_fcard_face_d : fcard face gd = size bg + fcard face (setC bbd).
Proof. rewrite /bg size_maps -(scycle_fcard_fband Hbgd); apply: n_compC. Qed.

Definition outer := fclosure face (codom hr).

Lemma closed_gr : fclosed edge (codom hr).
Proof.
apply: (intro_closed (Sedge g))=> [x y Dy Hx].
by rewrite -(eqP Dy) -(f_iinv Hx) -ErE codom_f.
Qed.

Lemma closed_outer : fclosed face outer.
Proof. apply: (closure_closed (Sface g)). Qed.

Remark closed_outerC : fclosed face (setC outer).
Proof. exact (setC_closed closed_outer). Qed.

Lemma closed_gd : fclosed node (codom hd).
Proof.
apply: (intro_closed (Snode g)) => [x y Dy Hx].
by rewrite -(eqP Dy) -(f_iinv Hx) -EdN codom_f.
Qed.

Lemma plain_patch : plain g = plainb (setC bgd) && plainb gr.
Proof.
PropCongr; apply/idP/andP => [HgE|[HgdE HgrE]].
move: {HgE}(plain_eq HgE) (plain_neq HgE) => De2 He1.
  split; apply/plainP => [x Hx].
    split; last by rewrite -(inj_eqd Ihd) EdE // He1.
    by apply Ihd; rewrite !EdE -?(fclosed1 (setC_closed HbgdE)) // De2.
  by split; [ apply Ihr; rewrite !ErE De2 | rewrite -(inj_eqd Ihr) ErE He1 ].
  apply/plainP => [x _]; case Hxr: (codom hr x).
  case/set0Pn: Hxr => [xr]; move/eqP=> Dx.
  by rewrite Dx -!ErE (inj_eqd Ihr) plain_eq // plain_neq.
rewrite Ehr in Hxr; case/norP: Hxr; move/negbE2; move/set0Pn=> [xd].
move/eqP=> Dx; rewrite Dx /bg (mem_maps Ihd); move=> Hxd.
case: (plainP HgdE _ Hxd) => [De2 He1].
by rewrite -!EdE -?(fclosed1 (setC_closed HbgdE)) // (inj_eqd Ihd) De2 He1.
Qed.

Lemma cubic_patch : cubic g = cubicb gd && cubicb (setC bgr).
Proof.
PropCongr; apply/idP/andP => [HgN|[HgdN HgrN]].
move: {HgN}(cubic_eq HgN) (cubic_neq HgN) => De2 He1.
  split; apply/cubicP => [x Hx].
    by split; [ apply Ihd; rewrite !EdN De2 | rewrite -(inj_eqd Ihd) EdN He1 ].
  split; last by rewrite -(inj_eqd Ihr) ErN // He1.
  by apply Ihr; rewrite !ErN -?(fclosed1 (setC_closed HbgrN)) // De2.
  apply/cubicP => [x _]; case Hxd: (codom hd x).
  case/set0Pn: Hxd => [xd]; move/eqP=> Dx.
  by rewrite Dx -!EdN (inj_eqd Ihd) cubic_eq // cubic_neq.
rewrite Ehd in Hxd; case/norP: Hxd; move/negbE2; move/set0Pn=> [xd].
move/eqP=> Dx; rewrite Dx -Ebgr (mem_maps Ihr); move=> Hxr.
case: (cubicP HgrN _ Hxr) => [De2 He1].
by rewrite -!ErN -?(fclosed1 (setC_closed HbgrN)) // (inj_eqd Ihr) De2 He1.
Qed.

Lemma outer_hd : forall xd, outer (hd xd) = bbd xd.
Proof.
move=> xd; rewrite [outer]lock; apply/idP/idP; unlock.
  case/set0Pn=> [z]; case/andP; case/connectP=> [p Hp <-].
  elim: p xd Hp => [|y p Hrec] xd /=.
    by clear; rewrite Ebgdr; apply: (subsetP (ring_fband _)).
  move/andP=> [Dy].
  case Hxd: (bgd xd); first by do 2 clear; apply: (subsetP (ring_fband _)).
  rewrite -(eqP Dy) -(EdF (negbI Hxd)); move=> Hp Hz.
  by rewrite /bbd (fclosed1 (fbandF bgd)); auto.
move/hasP=> [zd Hzd Hxzd]; move/connectP: Hxzd Hzd => [p Hp <-] {zd}.
elim: p xd Hp => [|yd p Hrec] xd /=.
  by move=> _ Hxd; apply: (subsetP (subset_closure _ _)); rewrite Ebgdr.
move/andP=> [Dxd Hp] Hzd.
case Hxd: (bgd xd); first by apply: (subsetP (subset_closure _ _)); rewrite Ebgdr.
rewrite /outer (fun b => closure_closed (Sface g) b (x := hd xd) (set11 _)).
rewrite -(EdF (negbI Hxd)) (eqP Dxd); exact (Hrec _ Hp Hzd).
Qed.

Remark Patch_adj_hd : fun_adjunction hd face face (setC outer).
Proof.
apply: (strict_adjunction (Sface _) closed_outerC Ihd).
  apply/subsetP => [x Hxn]; rewrite Ehd; apply/orP; left; apply/idP => [Hx].
  by case/set0Pn: Hxn; exists x; rewrite /setI connect0.
move=> xd yd; move/negbE2=> Hxd; rewrite /eqdf -EdF ?(inj_eqd Ihd) //.
rewrite /setC outer_hd in Hxd.
by apply/idP => [Hxd']; case/idP: Hxd; apply: (subsetP (ring_fband _)).
Qed.
Let adj_hd := Patch_adj_hd.

Lemma patch_face_d : forall xd yd, setC outer (hd xd) ->
  cface xd yd = cface (hd xd) (hd yd).
Proof. exact (rel_functor adj_hd). Qed.

Remark Patch_IhdF : forall xd, cface (hd xd) (hd (face xd)).
Proof.
move=> xd; case Hxd: (bgd xd); last by rewrite (EdF (negbI Hxd)) fconnect1.
case/connectP: (etrans (Sface _ _ _) (fconnect1 _ xd)) => [p].
elim: p (face xd) => [|yd' p Hrec] yd /=; first by move=> _ <-; apply connect0.
move=> Hyp Ep; move: (andP Hyp) => [Dyd Hp].
case Hyd: (bgd yd).
  rewrite -(scycle_cface Hbgd (x := yd) (y := xd)) ?connect0 //.
  by apply/connectP; exists (Adds yd' p).
apply: (connect_trans (Hrec _ Hp Ep)).
by rewrite Sface -(eqP Dyd) (EdF (negbI Hyd)) fconnect1.
Qed.
Let IhdF := Patch_IhdF.

Lemma patch_face_d' : forall xd yd, cface xd yd -> cface (hd xd) (hd yd).
Proof.
move=> xd yd; move/connectP=> [p Hp <-] {yd}.
elim: p xd Hp => [|yd p Hrec] xd /=; first by clear; apply: connect0.
move/andP=> [Dxd Hp].
by apply: (connect_trans _ (Hrec _ Hp)); rewrite -(eqP Dxd) IhdF.
Qed.

Lemma patch_face_r : forall xr yr, cface xr yr = cface (hr xr) (hr yr).
Proof.
move=> xr yr; apply/idP/idP.
  move/connectP=> [p Hp <-] {yr}.
  elim: p xr Hp => [|yr p Hrec] xr /=; first by clear; apply: connect0.
  move/andP=> [Dxr Hp]; apply: {p Hp Hrec}(connect_trans _ (Hrec _ Hp)).
  rewrite -{yr Dxr}(eqP Dxr).
  case Hfxr: (bgr (face xr)).
    case/HbgrP: Hfxr => [xd Dfxr _]; rewrite -Dfxr.
    move/(introT eqP): Dfxr => Dfxr; rewrite eqd_sym EdrF in Dfxr.
    by rewrite cface1 -(eqP Dfxr) Sface IhdF.
  by rewrite -(ErF (negbI Hfxr)) fconnect1.
set x := hr xr; move/connectP=> [p Hp Ep].
have Hhp: if codom hr x then x = hr xr else
          exists2 xd, x = hd xd & exists2 yd, hd yd = hr xr & cface yd xd.
  by rewrite /x codom_f.
elim: p {xr}x (xr) Hp Ep Hhp => [|z p Hrec] x xr /=.
  move=> _ Dx; rewrite Dx codom_f; move=> Dxr.
  by rewrite (Ihr Dxr) connect0.
case/andP; move/eqP=> Dz Hp Ep.
case Ihrx: (codom hr x).
  move=> Dx; apply: (connect_trans (fconnect1 face _)).
  apply: {Hp Ep Hrec}(Hrec _ _ Hp Ep); rewrite -{z}Dz.
  case Ihrfx: (codom hr (face x)).
  case Hfxr: (bgr (face xr)); last by rewrite -(ErF (negbI Hfxr)) Dx.
    case/HbgrP: Hfxr => [xd Dxd _]; rewrite -Dxd.
    have Dfxd := introT eqP Dxd; rewrite eqd_sym EdrF in Dfxd.
    rewrite Dx -(eqP Dfxd); congr hd; apply: (scycle_cface Hbgd).
    - by rewrite Sface fconnect1.
    - by rewrite -Ebgdr (eqP Dfxd) -Dx.
    by rewrite -Ebgdr Dxd codom_f.
  rewrite Ehr in Ihrfx; case/norP: Ihrfx; move/negbE2; case/set0Pn=> [xd].
  move/eqP=> Dfx; exists xd; first done.
  exists (edge (node xd)); last by rewrite -{2}[xd]Enode fconnect1.
  by apply: eqP; rewrite EdErN EdN -Dfx Dx -{1}[xr]Eface ErE Eedge set11.
move=> [xd Dxd [yd Dyd Hxyd]]; apply: {Hp Ep Hrec}(Hrec _ _ Hp Ep).
rewrite Ehr Dxd /setU /setC codom_f /bg (mem_maps Ihd) /= in Ihrx.
have Efxd := EdF (negbI Ihrx); rewrite -{z}Dz.
case Ihrfx: (codom hr (face x)).
  rewrite Dxd -Efxd -Dyd; congr hd; apply: (scycle_cface Hbgd).
  - by rewrite -cface1 Sface.
  - by rewrite -Ebgdr Efxd -Dxd.
  by rewrite -Ebgdr Dyd codom_f.
exists (face xd); first by rewrite Dxd.
by exists yd; last by rewrite -cface1r.
Qed.

Lemma patch_face_dr : forall xd, outer (hd xd) ->
 {yd : gd & {yr : gr | hd yd = hr yr /\ cface xd yd
                     & cface (hd xd) =1 cface (hr yr)}}.
Proof.
move=> xd Hxd; case/pickP: (setI (cface xd) bgd) => [yd Hyd|Hnxd].
  exists yd; case/andP: Hyd => [Hxyd Hyd].
  have Hyr: codom hr (hd yd).
    by rewrite Ehr /setU /bg (mem_maps Ihd) Hyd orbT.
  exists (iinv Hyr); rewrite f_iinv; first by split.
  exact (same_cface (patch_face_d' Hxyd)).
rewrite outer_hd in Hxd; case/hasPn: Hxd => [yd Hyd]; apply/idP => [Hxyd].
by case/andP: (Hnxd yd); split.
Qed.

Lemma patch_bridgeless : bridgeless g -> bridgeless gd /\ bridgeless gr.
Proof.
move=> Hgl; split.
  apply/set0P => [xd]; rewrite cface1r; apply/idP => [Hfexd].
  case/set0Pn: Hgl; exists (hd xd).
  by rewrite cface1r -{2}[xd]Eedge EdN Enode; apply patch_face_d'.
by apply/set0P => xr; rewrite patch_face_r ErE (set0P Hgl).
Qed.

Lemma bridgeless_patch :
  bridgeless gd -> bridgeless gr -> chordless bgd -> bridgeless g.
Proof.
move=> Hgdl Hgrl Hgdc; apply/set0P => x; apply/idP => [Hnex].
case Hx: (codom hr x).
  move/set0Pn: Hx => [xr Dx]; rewrite (eqP Dx) -ErE in Hnex.
  by case/set0Pn: Hgrl; exists xr; rewrite patch_face_r.
rewrite Ehr in Hx; case/norP: Hx; move/negbE2.
case/set0Pn=> [xd]; move/eqP=> Dx Hbx.
rewrite /bg Dx (mem_maps Ihd) in Hbx; rewrite Dx -(EdE Hbx) in Hnex.
case Hxr: (outer (hd xd));
 last by case/idP: (set0P Hgdl xd); rewrite patch_face_d // /setC Hxr.
have Hexr: outer (hd (edge xd)).
  apply: etrans Hxr; symmetry; apply: (closed_connect _ Hnex).
  apply: closure_closed; apply: Sface.
rewrite !outer_hd in Hxr Hexr; move/hasP: Hxr => [yd Hyd Hxyd].
move/hasP: Hexr => [zd Hzd Hexzd].
case/set0Pn: (subsetP Hgdc _ Hyd); exists zd.
apply/andP; split; first by apply/adjP; exists xd; first by rewrite Sface.
case/HbgdP: (Hyd) => [yr Dyr Dnyr]; rewrite /setD1 Hzd andbT.
case/andP: Hbgd => [Dbgd _].
apply/andP; split; apply/eqP => Dzd; case/set0Pn: Hgrl.
  exists (node yr); rewrite cface1r Enode.
  rewrite patch_face_r -Dnyr -Dyr (eqP (next_cycle Dbgd Hyd)) Dzd.
  apply: (connect_trans (connect_trans _ Hnex)); last exact: patch_face_d'.
  rewrite Sface; exact: patch_face_d'.
exists (node (node yr)); rewrite cface1r Enode.
have Dnnyr := introT eqP Dnyr; rewrite -{1}[yd]Eface EdErN in Dnnyr.
rewrite patch_face_r -Dnyr -(eqP Dnnyr) -{1}(eqP (prev_cycle Dbgd Hyd)).
rewrite Eedge Dzd Sface; apply: (connect_trans (connect_trans _ Hnex)).
  rewrite Sface; exact: patch_face_d'.
exact: patch_face_d'.
Qed.

Let ag := closure glink (codom hr).

Remark Patch_Hag : closed glink ag.
Proof. apply: (closure_closed (Sglink _)). Qed.
Let Hag := Patch_Hag.

Remark Patch_Hagr : n_comp glink gr = n_comp glink ag.
Proof.
have Hgg := Sglink g; have Hggr := Sglink gr.
rewrite (adjunction_n_comp hr Hgg Hggr Hag).
  apply: eq_card => [xr]; rewrite /setI /preimage /ag.
  by rewrite (subsetP (subset_closure (d := g) glink _) _ (codom_f hr xr)).
split.
  move=> x Hx; case: (pickP (setI (gcomp x) (codom hr))).
    by move=> y; move/andP=> [Hxy Hy]; exists (iinv Hy); rewrite f_iinv.
  by move=> Hnx; case/set0P: Hx.
move=> xr zr _; apply/idP/idP; rewrite -clink_glink.
  move/connectP=> [p Hp <-] {zr}.
  elim: p xr Hp => [|yr p Hrec] xr /=; first by rewrite connect0.
  move/andP=> [Hxr Hp]; apply: {Hrec Hp}(connect_trans _ (Hrec _ Hp)).
  have Hfzr: forall zr, gcomp (hr zr) (hr (face zr)).
    move=> zr; move: (fconnect1 face zr); rewrite patch_face_r.
    apply: {zr}connect_sub => [x y]; move/eqP => <-; exact (connect1 (glinkF _)).
  case/clinkP: Hxr => [Dxr|Dfxr]; last by rewrite -Dfxr Hfzr.
  by apply: (connect_trans (connect1 (glinkE _))); rewrite -[yr]Enode -Dxr -ErE.
set x := hr xr; move/connectP=> [p Hp Ep].
have Hxr: if codom hr x then x = hr xr else bgr xr by rewrite /x codom_f.
elim: p {xr}x (xr) Hp Ep Hxr => [|y p Hrec] x xr /=.
  move=> _ Dx; rewrite Dx codom_f; move=> Dxr.
  by rewrite (Ihr Dxr) connect0.
move/andP=> [Hxy Hp] Ep.
case Hyd: (codom hd y).
  have Hbzr: forall yr, bgr yr -> gcomp yr zr.
    move{x xr Hxy} => xr Hxr.
    case Hyr: (codom hr y) {Hrec Hp Ep}(Hrec y _ Hp Ep); last by auto.
    rewrite Ehd /setU /setC {}Hyr -Ebgr in Hyd; move/mapsP: Hyd => [yr Hyr Dy].
    move=> Hrec; apply: connect_trans _ {Hrec Dy}(Hrec _ (esym Dy)).
    rewrite -{Hxr}(EbgrN Hxr) in Hyr; apply: connect_sub xr yr Hyr => xr yr.
    by move/eqP=> Dyr; apply connect1; rewrite -Dyr glinkN.
  case (codom hr x); [ move=> Dx | by auto ]; rewrite {x}Dx in Hxy.
  case/clinkP: Hxy => [Dxrn|Dfxr].
    by apply Hbzr; rewrite -Ebgrd Dxrn -(f_iinv Hyd) -EdN codom_f.
  apply: (connect_trans (connect1 (glinkF _))); apply: Hbzr.
  apply/idPn => [Hfxr]; rewrite (ErF Hfxr) in Dfxr.
  by rewrite -Ebgrd Dfxr Hyd in Hfxr.
rewrite Ehd in Hyd; case/norP: Hyd; move/negbE2; case/set0Pn=> [yr].
move/eqP=> Dy Hyr; rewrite Dy -Ebgr (mem_maps Ihr) in Hyr; move=> Hx.
apply: {Hp Ep Hrec}(connect_trans _ (Hrec _ yr Hp Ep _));
  last by rewrite Dy codom_f.
rewrite -clink_glink; apply connect1.
case/clinkP: Hxy => [Dny|Dfx].
  rewrite Dy -(ErN Hyr) in Dny; rewrite Dny codom_f in Hx.
  by rewrite -(Ihr Hx) clinkN.
rewrite -{1}[y]Enode Dy -(ErN Hyr) -ErE in Dfx.
rewrite (Iface _ Dfx) codom_f in Hx.
by rewrite -{1}[yr]Enode (Ihr Hx) clinkF.
Qed.
Let Hagr := Patch_Hagr.

Lemma patch_connected_r : connected g -> negb (set0b gr) -> connected gr.
Proof.
move=> Hcg Hgr; rewrite /connected Hagr -(eq_n_comp_r (a := g)) //.
case/set0Pn: Hgr => [xr _] y; symmetry; apply/set0Pn.
exists (hr xr); rewrite /setI codom_f andbT -clink_glink.
apply/connectP; apply: (connected_clink Hcg).
Qed.

Lemma patch_fcard_face_r : fcard face gr = fcard face outer.
Proof.
rewrite /= (adjunction_n_comp hr (Sface _) (Sface _) closed_outer).
  apply: eq_card => [xr]; rewrite /setI /preimage andbC /outer.
  by rewrite (subsetP (subset_closure (eqdf face) (codom hr))) ?codom_f ?andbT.
split; last by move=> *; apply: patch_face_r.
move=> x Hx; case: (pickP (setI (cface x) (codom hr))).
  by move=> y; move/andP=> [Hxy Hy]; exists (iinv Hy); rewrite f_iinv.
by move=> Hnxr; case/set0P: Hx.
Qed.

Lemma genus_patch : genus g = genus gd + genus gr.
Proof.
pose ebg := size bg =d 0.
have Hebgd: if ebg then bgd = seq0 else exists xd, bgd xd.
  by rewrite /ebg /bg; case: bgd => [|x p] //; exists x; rewrite /= setU11.
have Hebgr: if ebg then bgr = seq0 else exists xr, bgr xr.
  rewrite /ebg -size_rev -Dbgr; case: bgr => [|x p] //.
  by exists x; rewrite /= setU11.
have HcdE: fcard edge gd = negb ebg + fcard edge (setC (codom hr)).
  rewrite (n_compC bgd); congr addn.
    case: (ebg) Hebgd; [ move=>Dbgd | move=> [x Hx] ].
      by apply: eq_card0 => [x]; rewrite Dbgd /= /setI andbF.
    rewrite -(eq_n_comp_r (EbgdE Hx)); apply: (n_comp_connect (Sedge _)).
  have closed_grC := setC_closed closed_gr.
  rewrite (adjunction_n_comp hd (Sedge _) (Sedge _) closed_grC).
    apply: eq_n_comp_r => [x]; congr negb.
    by rewrite Ehr /setU /setC codom_f /= /bg (mem_maps Ihd).
  apply (strict_adjunction (Sedge _) closed_grC Ihd).
    apply/subsetP => [x Hx]; rewrite /setC Ehr in Hx.
    by case/norP: Hx; rewrite /setC negb_elim.
  move=> xd yd; rewrite /setC Ehr /setU /setC codom_f /= /bg (mem_maps Ihd).
  by move/negbE2=> Hxd; rewrite /eqdf /= -(EdE Hxd) (inj_eqd Ihd).
have HcdF: fcard face gd = size bg + fcard face (setC outer).
  rewrite patch_fcard_face_d; congr addn.
  rewrite (adjunction_n_comp _ (Sface _) (Sface _) closed_outerC adj_hd).
  by apply: eq_card => [xd]; rewrite /setI /setC -outer_hd.
have HcdN: fcard node gd = fcard node (codom hd).
  rewrite (adjunction_n_comp hd (Snode _) (Snode _) closed_gd).
    by apply: eq_card => [xd]; rewrite /setI /preimage codom_f.
  apply: (strict_adjunction (Snode _) closed_gd Ihd (subset_refl _)) => xd yd _.
  by rewrite /eqdf -EdN (inj_eqd Ihd).
have HcdG: n_comp glink gd = negb ebg + n_comp glink (setC ag).
  have Hgg := (Sglink g); have Hggd := (Sglink gd).
  have Eggd: forall x y, setC bgd x -> glink (hd x) (hd y) = glink x y.
    move=> x y Hx; rewrite {1}/glink /relU /setU /eqdf.
    by rewrite -(EdE Hx) -EdN -(EdF Hx) !(inj_eqd Ihd).
  have HagC := setC_closed Hag.
  have Hhdg: rel_adjunction hd glink glink (setC ag).
    apply (strict_adjunction Hggd HagC Ihd).
    apply/subsetP => [x Hxn]; case/orP: (EhdUr x) => // Hx.
      by case/idP: Hxn; apply: (subsetP (subset_closure _ _)).
    move=> xd yd; move/negbE2=> Hx; apply Eggd; apply/idP => Hxd; case/idP: Hx.
    by apply: (subsetP (subset_closure _ _)); rewrite Ebgdr.
  rewrite (adjunction_n_comp hd Hgg Hggd HagC Hhdg).
  rewrite (n_compC (preimage hd ag)); congr addn.
  case: (ebg) Hebgd; [ move=> Dbgd | move=> [x Hx] ].
    apply: eq_card0 => x; apply/nandP; right; apply/set0Pn; case=> y Hy.
    case/andP: Hy; rewrite -clink_glink; move/connectP=> [p Hp <-] {y}.
    elim: p x Hp => [|y p Hrec] xd; first by rewrite /= Ebgdr Dbgd.
    case/andP; move/clinkP=> [Dx|Dy].
      rewrite -{1}[xd]Eedge EdN in Dx; rewrite -(Inode g Dx); eauto.
    by rewrite -Dy -EdF ?Dbgd; eauto.
  apply: etrans (n_comp_connect Hggd x); apply: eq_n_comp_r => y.
  rewrite /preimage /ag; apply/set0Pn/idP.
    case=> z; case/andP; rewrite -clink_glink; move/connectP=> [p Hp <-] {z}.
    elim: p y Hp => [|z p Hrec] y /=.
      clear; rewrite Ebgdr -{Hx}(EbgdE Hx); apply: connect_sub x y => x y.
      by case/eqP=> <-; apply connect1; rewrite glinkE.
    case/andP; move/clinkP=> [Dy|Dz].
      rewrite -{1}[y]Eedge EdN in Dy; rewrite -(Inode g Dy).
      move=> Hq Eq; apply: {Hrec Hq Eq}(connect_trans (Hrec _ Hq Eq)).
      by apply connect1; rewrite -{2}[y]Eedge glinkN.
    case Hy: (bgd y).
      move=> _ _ {q z Hrec Dz}; rewrite -(EbgdE Hx) in Hy.
      apply: connect_sub x y Hy {Hx} => x y; case/eqP=> <-; apply connect1.
      by rewrite glinkE.
    rewrite -(EdF (negbI Hy)) in Dz; rewrite -Dz.
    move=> Hq Eq; apply: {Hrec Hq Eq}(connect_trans (Hrec _ Hq Eq)).
    by rewrite Hggd connect1 ?glinkF.
  rewrite Hggd; move/connectP=> [p Hp Dx]; move: Dx Hx => <- {x}.
  elim: p y Hp => [|y p Hrec] x /=.
    by move=> _ Hx; exists (hd x); rewrite /setI connect0 Ebgdr.
  case Hx: (bgd x).
    by do 2 clear; exists (hd x); rewrite /setI connect0 Ebgdr.
  move/andP=> [Hxy Hp] Ep.
  case: {p Hrec Hp Ep}(Hrec _ Hp Ep) => [z Hz]; exists z.
  rewrite -(Eggd x y (negbI Hx)) in Hxy.
  by rewrite /setI (same_connect Hgg (connect1 Hxy)).
have HcrE: fcard edge gr = fcard edge (codom hr).
  rewrite (adjunction_n_comp hr (Sedge _) (Sedge _) closed_gr).
    by apply: eq_card => [z]; rewrite /setI /preimage codom_f.
  apply (strict_adjunction (Sedge _) closed_gr Ihr (subset_refl _)).
  by move=> xr yr _; rewrite {1}/eqdf -ErE (inj_eqd Ihr).
have HcrN: fcard node gr = negb ebg + fcard node (setC (codom hd)).
  have HafC := setC_closed closed_gd.
  rewrite (adjunction_n_comp hr (Snode _) (Snode _) HafC).
    rewrite (n_compC (fun x => codom hd (hr x))); congr addn.
    case: (ebg) Hebgr; [ move=> Dbgr0 | move=> [x Hx] ].
      by apply: eq_card0 => [x]; rewrite /setI Ebgrd Dbgr0 andbF.
      apply: etrans (n_comp_connect (Snode _) x); apply: eq_n_comp_r => y.
    by rewrite Ebgrd (EbgrN Hx).
  apply (strict_adjunction (Snode _) HafC Ihr).
    apply/subsetP => [x]; rewrite /setC Ehd /setC.
    by case/norP; rewrite negb_elim.
  move=> xr yr; rewrite /setC Ebgrd /eqdf; move/negbE2=> Hxr.
  by rewrite -(ErN Hxr) (inj_eqd Ihr).
rewrite {1}/genus -(subn_add2l (genus_lhs gd + genus_lhs gr)).
rewrite addnC {1 4 5}/genus_lhs !even_genusP /genus_rhs.
rewrite (n_compC ag) (n_compC (codom hr)) (n_compC (codom hd)) (n_compC outer).
rewrite HcdE HcdF -HcdN HcdG -HcrE -patch_fcard_face_r HcrN -Hagr !double_add.
rewrite -!addnA (double_addnn (negb ebg)) (addnCA (card gd)).
rewrite (addnA (card gd)) card_patch -!addnA -!(addnCA (negb ebg)).
rewrite !subn_add2l addnCA !subn_add2l -(addnCA (card g)) subn_add2l addnC.
rewrite -!addnA !(addnCA (double (genus gr))) -double_add.
do 2 rewrite addnA addnCA subn_add2l; rewrite -!addnA !subn_add2l.
by do 2 rewrite addnCA subn_add2l; rewrite subn_addr half_double addnC.
Qed.

Lemma planar_patch : planar g = planarb gd && planarb gr.
Proof. by PropCongr; rewrite genus_patch eqn_add0. Qed.

Lemma colorable_patch :
  four_colorable g <->
    (exists2 et, ring_trace bgd et & ring_trace bgr (rot 1 (rev et))).
Proof.
split.
  move=> [k [HkE HkF]]; exists (trace (maps k bg)).
    exists (comp k hd); last by rewrite (maps_comp k hd).
    have Hk'F: (invariant face (comp k hd) =1 gd).
      move=> x; apply/eqcP; apply: (fconnect_invariant HkF); apply patch_face_d'.
      by rewrite Sface fconnect1.
    split; last done; move=> xd; rewrite /invariant -{2}[xd]Eedge.
    rewrite -(eqcP (Hk'F (edge xd))) /comp EdN; set y := hd (face (edge xd)).
    rewrite -{1}[y]Enode (eqcP (HkF (edge (node y)))); apply: HkE.
  exists (comp k hr); last by rewrite -trace_rev -maps_rev -Dbgr -maps_comp.
  split; first by move=> x; rewrite /invariant /comp ErE; apply: HkE.
  move=> x; apply/eqcP; apply: (fconnect_invariant HkF).
  by rewrite -patch_face_r Sface fconnect1.
move=> [et [kd [HkdE HkdF] Ekd] [kr [HkrE HkrF] Ekr]]; simpl in Ekd, Ekr.
pose c0 := head_color (maps kd (rev bgd)) +c head_color (maps kr bgr).
pose kd' := comp (addc c0) kd.
have Ic0 := monic_inj (addc_inv c0 : monic _ (addc c0)).
have Hkd'E: invariant edge kd' =1 set0.
  by move=> x; rewrite -(HkdE x); apply: invariant_inj.
have Hkd'F: invariant face kd' =1 gd.
  by move=> x; rewrite -(HkdF x); apply: invariant_inj.
have Ebkd'r: rev (maps kd' bgd) = maps kr bgr.
  move: Ekr; rewrite Ekd -trace_rev -!maps_rev /kd' (maps_comp (addc c0) kd) /c0.
  case: (rev bgd) => [|xd bgd']; first by case: bgr; move=> // xr; case.
  case: bgr => [|xr bgr'] Ekdr; first by case: bgd' Ekdr.
  rewrite /= -untrace_trace -maps_adds trace_addc addcC addc_inv.
  by rewrite -maps_adds Ekdr maps_adds untrace_trace.
move: {kd c0}kd' Hkd'E Hkd'F Ebkd'r {Ic0 HkdE HkdF Ekd Ekr} => kd HkdE HkdF Ebkdr.
have Ekdr: forall xd xr, hd xd = hr xr -> kd xd = kr xr.
  move=> xd xr Dx; have Hxd: bgd xd by rewrite -Ebgdr Dx codom_f.
  have Hxr: rev bgr xr by rewrite mem_rev -Ebgrd -Dx codom_f.
  rewrite -(sub_index xd Hxd) -(sub_index xr Hxr).
  rewrite -index_mem in Hxd; rewrite -index_mem in Hxr.
  rewrite -(sub_maps xr Color0) // maps_rev -Ebkdr rev_rev.
  rewrite -(sub_maps xd Color0) //; congr (sub Color0).
  by rewrite -(index_maps Ihd) -(index_maps Ihr) maps_rev Dbgr rev_rev Dx.
pose dhd := _ =d hd _; pose dhr := _ =d hr _.
pose k x := if pick (dhr x) is Some xr then kr xr else
            if pick (dhd x) is Some xd then kd xd else Color0.
have Hkk := introT set0P.
have HkF: invariant face k =1 g.
  move=> x; rewrite /invariant /k /setA; apply/eqP.
  case: (pickP (dhr x)) => [xr Dx|Hxr].
    case: (pickP (dhr (face x))) => [yr Dy|Hyr].
      apply: (fconnect_invariant HkrF).
      by rewrite patch_face_r -(eqP Dx) -(eqP Dy) Sface fconnect1.
    case: (pickP (dhd (face x))) => [yd Dy|Hyd].
      rewrite (eqP Dx) /dhd -{1}[yd]Enode eqd_sym -EdrF in Dy.
      rewrite -(eqcP (HkrF xr)) -{1}[yd]Enode (eqcP (HkdF _)).
      by apply: Ekdr; rewrite -(eqP Dy).
    by move: (EhdUr (face x)); rewrite /setU /codom !Hkk.
  case: (pickP (dhd x)) => [xd Dx|Hxd].
    have Hxd: negb (bgd xd) by rewrite -Ebgdr /codom Hkk -?(eqP Dx).
    rewrite -(eqcP (HkdF xd)) (eqP Dx) -(EdF Hxd).
    case: (pickP (dhr (hd (face xd)))) => [yr Dy|Hyr].
      by symmetry; apply: Ekdr; move/eqP: Dy => <-.
    case: (pickP (dhd (hd (face xd)))) => [yd Dy|Hyd].
      by rewrite (Ihd (eqP Dy)).
    by case/eqP: (Hyd (face xd)).
  by move: (EhdUr x); rewrite /setU /codom !Hkk.
exists k; split; last done; move=> x; rewrite /invariant /k.
 case: (pickP (dhr x)) => [xr Dx|Hxr].
  rewrite (eqP Dx) -ErE.
  case: (pickP (dhr (hr (edge xr)))) => [yr Dy|Hyr].
    rewrite -(Ihr (eqP Dy)); exact: HkrE.
  by case/eqP: (Hyr (edge xr)).
case: (pickP (dhd x)) => [xd Dx|Hxd].
  have Hxd: negb (bgd xd) by rewrite -Ebgdr /codom Hkk -?(eqP Dx).
  have HxdE := HkdE xd; rewrite (eqP Dx) -(EdE Hxd).
  case: (pickP (dhr (hd (edge xd)))) => [yr Dy|Hyr].
    by rewrite -(Ekdr _ _ (eqP Dy)).
  case: (pickP (dhd (hd (edge xd)))) => [yd Dy|Hyd].
    by rewrite -(Ihd (eqP Dy)).
  by case/eqP: (Hyd (edge xd)).
by move: (EhdUr x); rewrite /setU /codom !Hkk.
Qed.

End Patch.

(* Patching disjoint components of the map along empty borders. Used to *)
(* show that the minimal counter example is connected.                  *)

Section PatchGcomp.

Variables (g : hypermap) (z : g).

Definition gcompd_dart : finSet := subFin (gcomp z).

Remark Hgcompd_edge : forall u : gcompd_dart, gcomp z (edge (subdE u)).
Proof. by move=> [x Hx]; exact (connect_trans Hx (connect1 (glinkE _))). Qed.

Remark Hgcompd_node : forall u : gcompd_dart, gcomp z (node (subdE u)).
Proof. by move=> [x Hx]; exact (connect_trans Hx (connect1 (glinkN _))). Qed.

Remark Hgcompd_face : forall u : gcompd_dart, gcomp z (face (subdE u)).
Proof. by move=> [x Hx]; exact (connect_trans Hx (connect1 (glinkF _))). Qed.

Definition gcompd_edge u : gcompd_dart := subdI (Hgcompd_edge u).
Definition gcompd_node u : gcompd_dart := subdI (Hgcompd_node u).
Definition gcompd_face u : gcompd_dart := subdI (Hgcompd_face u).

Remark gcompd_monic : monic3 gcompd_edge gcompd_node gcompd_face.
Proof. move=> [x Hx]; apply: subdE_inj; apply: Eedge. Qed.

Definition gcomp_disk := Hypermap gcompd_monic.
Definition gcompd (u : gcomp_disk) := subdE u.

Lemma inj_gcompd : injective gcompd. Proof. apply: subdE_inj. Qed.
Lemma codom_gcompd : codom gcompd =1 gcomp z.
Proof.
move=> x; apply/set0Pn/idP => [[[y Hy] Dy]|Hx]; first by rewrite (eqP Dy).
exists (subdI Hx : gcomp_disk); apply: set11.
Qed.

Definition gcompr_dart : finSet := subFin (setC (gcomp z)).

Remark gcompr_edgeP : forall u : gcompr_dart, setC (gcomp z) (edge (subdE u)).
Proof.
move=> [x Hx]; apply/idP => /= [Hx']; case/idP: Hx.
apply: (connect_trans Hx'); rewrite Sglink /=; apply connect1; exact: glinkE.
Qed.

Remark gcompr_nodeP : forall u : gcompr_dart, setC (gcomp z) (node (subdE u)).
Proof.
move=> [x Hx]; apply/idP => /= [Hx']; case/idP: Hx.
apply: (connect_trans Hx'); rewrite Sglink /=; apply connect1; exact: glinkN.
Qed.

Remark gcompr_faceP : forall u : gcompr_dart, setC (gcomp z) (face (subdE u)).
Proof.
move=> [x Hx]; apply/idP => /= [Hx']; case/idP: Hx.
apply: (connect_trans Hx'); rewrite Sglink /=; apply connect1; exact: glinkF.
Qed.

Definition gcompr_edge u : gcompr_dart := subdI (gcompr_edgeP u).
Definition gcompr_node u : gcompr_dart := subdI (gcompr_nodeP u).
Definition gcompr_face u : gcompr_dart := subdI (gcompr_faceP u).

Remark gcompr_monic : monic3 gcompr_edge gcompr_node gcompr_face.
Proof. move=> [x Hx]; apply: subdE_inj; exact: Eedge. Qed.

Definition gcomp_rem := Hypermap gcompr_monic.
Definition gcompr (u : gcomp_rem) := subdE u.
Lemma inj_gcompr : injective gcompr. Proof. apply: subdE_inj. Qed.
Lemma codom_gcompr : codom gcompr =1 setC (gcomp z).
Proof.
move=> x; apply/set0Pn/idP => [[[y Hy] Dy]|Hx]; first by rewrite (eqP Dy).
exists (subdI Hx : gcomp_rem); exact: set11.
Qed.

Lemma patch_gcomp : patch gcompd gcompr seq0 seq0.
Proof.
repeat split; try done; try apply inj_gcompd; try apply inj_gcompr.
by move=> x; rewrite /setU /setC /= orbF codom_gcompd codom_gcompr.
Qed.

End PatchGcomp.

Lemma minimal_counter_example_is_connected : forall g,
  minimal_counter_example g -> connected g.
Proof.
move=> g Hg; apply/idPn => Hcg; case (minimal_counter_example_is_noncolorable Hg).
case: (pickP g) => [z _|Hg0];
  last by exists (fun _ : g => Color0); split; move=> x; move: (Hg0 x).
have Hpgdr := patch_gcomp z; have Hpg := Hg : planar g.
rewrite (planar_patch Hpgdr) in Hpg; move/andP: Hpg => [Hpgd Hpgr].
case: (patch_bridgeless Hpgdr Hg) => [Hgbd Hgbr].
have HgE := Hg : plain g; have HgN := Hg : cubic g.
rewrite (plain_patch Hpgdr) in HgE; move/andP: HgE => [HgdE HgrE].
rewrite (cubic_patch Hpgdr) in HgN; case/andP: HgN.
move/cubic_precubic=> HgdN; move/cubic_precubic=> HgrN.
have Hng := card_patch Hpgdr; rewrite /= add0n in Hng.
have Hmg := minimal_counter_example_is_minimal Hg.
case: (colorable_patch Hpgdr) => _; apply; exists (seq0 : colseq).
  case: (Hmg (gcomp_disk z)); try solve [repeat split; auto];
    last by move=> kd Hkd; exists kd.
  rewrite -addn1 -Hng /= leq_add2l ltnNge leqn0.
  apply/eqP => Hgr; case/eqnP: Hcg; rewrite -(n_comp_connect (Sglink _) z).
  apply: eq_n_comp_r => x; symmetry.
  exact (negbEf (set0P (introT eqP (etrans (esym (card_sub_dom _)) Hgr)) x)).
case: (Hmg (gcomp_rem z)); try solve [repeat split; auto];
  last by move=> kr Hkr; exists kr.
rewrite -add1n -Hng leq_add2r ltnNge leqn0; apply/eqP => [Hgd].
case/idP: (card0_eq (etrans (esym (card_sub_dom _)) Hgd) z); apply: connect0.
Qed.

Coercion minimal_counter_example_is_connected :
  minimal_counter_example >-> connected.

Definition minimal_counter_example_is_planar_bridgeless_plain_connected :
  forall g, minimal_counter_example g -> planar_bridgeless_plain_connected g.
move=> g Hg; split; exact Hg.
Defined.

Coercion minimal_counter_example_is_planar_bridgeless_plain_connected :
 minimal_counter_example >-> planar_bridgeless_plain_connected.

Definition minimal_counter_example_is_planar_plain_cubic_connected :
 forall g, minimal_counter_example g -> planar_plain_cubic_connected g.
repeat move=> g Hg; repeat split; exact Hg.
Defined.

Coercion minimal_counter_example_is_planar_plain_cubic_connected :
  minimal_counter_example >-> planar_plain_cubic_connected.

Unset Implicit Arguments.


Import IfNotations.

Class EqDec {v : Set} := {
  eq_decide (x y : v) : {x = y} + {x <> y}
}.

Class Lambda {t : Set} := {
  app : t -> t -> t ;
  lam : (t -> t) -> t
}.

Declare Custom Entry lam.
Notation "_{ e }" := e (e custom lam at level 99).
Notation "x" := x (in custom lam at level 0, x constr at level 0).
Notation "f x" := (app f x) (in custom lam at level 1, left associativity).
Notation "'fun' x => y" :=
  (lam (fun x => y)) (in custom lam at level 90,
                     x ident,
                     y custom lam at level 99,
                     left associativity).
Notation "( x )" := x (in custom lam, x at level 99).
Notation "${ x }" := x (in custom lam, x constr at level 0).

Section model.

Variable v : Set.

Inductive term :=
| var (_ : v)
| pass (_ : term) (_ : term)
| lam_ (_ : v -> term)
.

Coercion var : v >-> term.
Instance term_lambda : @Lambda term := {
  app := pass ;
  lam f := lam_ (fun x => f x)
}.

(* My intuition is that a stack is kind of like a one hole context/evaluation context.
   An alternate representation might be:
 *)
Definition term' := term -> term.

Record ck := { control : term ; kont : term' }.
Notation " 'E' [ h | e ]" := (h (e : term)) (e custom lam).

(* We use a very simple model of the heap as a function. *)
Definition store := v -> term.

Record model := { model_store : store ; expr : term }.
(*
I used the turnstile before while figuring things out but really this is a store not an environment.
I need to think up better notation/denotation.

fun store => E[kont|control] ?
*)
Notation "s |- ck" := {| model_store := s ; expr := ck |} (at level 70).

Definition put `{EqDec v} old x e : store :=
fun x' => if eq_decide x x' then e else old x'.

Reserved Notation "s0 ~> s1 " (at level 80).

Variant step: model -> model -> Prop :=
| step_var s (x: v) k :
   s |- E[k| x] ~> s |- E[k| ${s x}]

| step_pass s k e0 e1 :
   s |- E[k| e0 e1] ~> s |- E[fun x => _{ ${k x} e1 }| e0]

| step_lam `{EqDec v} s k f x e:
   s |- E[fun x => _{ ${k x} e } | ${lam_ f}] ~> put s x e |- E[k|${f x}]
where "st ~> st'" := (step st st').

(* FIXME I need to think of a less misleading name, the spec is very weak currently *)
(*
  If an interpreter takes a step (and succeeds!) then that implies that must have been a valid state transition.
*)
Definition valid state to (tick : state -> option state) :=
forall a,
exists b,
tick a = Some b ->
to a ~> to b.

Inductive ast :=
| ast_var (_ : v)
| ast_app (_ : ast) (_ : ast)
| ast_lam (_ : v -> ast)
.

Coercion ast_var : v >-> ast.
Instance ast_lambda : @Lambda ast := {
  app := ast_app ;
  lam f := ast_lam (fun x => f x)
}.

(* We use an old trick of lazily threading through new variables *)
CoInductive font : Set := { head : v ; left : font ; right : font }.

Inductive stack : Set :=
| hole
| lpass (_ : stack) (_ : ast).

(* We currently leak memory *)
Definition heap := list (v * ast).

Definition arbitrary : ast := _{ fun x => x }.

Section lookup.
Context `{EqDec v}.
Fixpoint lookup (hp : heap) : v -> ast :=
match hp with
| cons (x', h) t =>
   let t' := lookup t in
   fun x => if eq_decide x x' then h else t' x
| nil => fun _ => arbitrary
end.
End lookup.

Definition state := (heap * stack * ast) %type.

Definition go `{EqDec v} (fnt : font) s k e : option state :=
match e with
| ast_var x => Some (s, k, lookup s x)

| ast_app e0 e1 => Some (s, lpass k e1, e0)
| ast_lam f =>
   if k is lpass k' e0
   then
     let x := head fnt in
     Some (cons (x, e0) s, k', f x)
   else None
end.

Definition go' `{EqDec v} fnt st :=
match st with
| (s, k, e) => go fnt s k e
end.
Fixpoint to_term e :=
match e with
| ast_var x => var x
| ast_app e0 e1 => app (to_term e0) (to_term e1)
| ast_lam f => lam_ (fun x => to_term (f x))
end.

Section applyk.
Variable h : term.
Fixpoint applyk k :=
match k with
| hole => h
| lpass k e => pass (applyk k) (to_term e)
end.
End applyk.

Definition to_term' k : term' := fun x => applyk x k.

Fixpoint to_store `{EqDec v} (s : heap) : store :=
match s with
| cons (x, h) t =>
  let t' := to_store t in
  let h' := to_term h in
  put t' x h'
| nil => fun _ => _{ fun x => x }
end.

Definition models_put `{EqDec v} (h : heap) x (e : ast):
put (to_store h) x (to_term e) = to_store (cons (x, e) h).
induction h.
- cbn.
  trivial.
- cbn.
  trivial.
Qed.

Definition tautological `{EqDec v} x : if eq_decide x x then True else False.
case (eq_decide x x).
trivial.
intro.
contradiction.
Qed.

(* really messy *)
Definition models_store `{EqDec v} h : forall x, to_store h x = to_term (lookup h x).
induction h.
- cbn.
  trivial.
- destruct a.
  intro.
  cbv.
  rewrite -> IHh.
  rewrite <- IHh.
  rewrite -> IHh.
  destruct H.
  case (eq_decide0 v0 x).
  +
    intro.
    rewrite -> e.
    cbv.
    case (eq_decide0 x x).
    * intro.
      trivial.
    * intro.
      contradiction.
  + intro.
    case (eq_decide0 x v0).
    * intro.
      symmetry in e.
      contradiction.
    * intro.
      trivial.
      Qed.

Definition go_to_model `{EqDec v} (st : state) : model :=
match st with
| (s, k , e) => to_store s |- E[to_term' k| ${to_term e} ]
end.

Definition go_valid `{EqDec v} fnt : valid _ go_to_model (go' fnt).
intro a.
destruct a, p.
cbn.
(* Perform induction over all possible cases of control, then all cases of the stack *)
induction a.
+ cbn.
  eexists (h, s, lookup h v0).
  intro.
  cbn.
  rewrite <- (models_store _ _).
  eapply (step_var (to_store h) v0 (to_term' s)).
+ cbn.
  eexists (h, lpass s a2, a1).
  intro.
  apply (step_pass (to_store h) (to_term' s) (to_term a1) (to_term a2)).
+ cbn.
  induction s.
  - eexists (h, hole, arbitrary).
    intros.
    discriminate.
  - pose (x := head fnt).
    pose (h' := cons (x, a0) h).
    eexists (h', s, a x).
    intros.
    pose (str := to_store h).
    pose (str' := to_store h').
    cbn.
    eapply (step_lam str (to_term' s) (fun y => to_term (a y)) x (to_term a0)).
Qed.

End model.

(* My language of choice is Haskell but a runtime of Ocaml or Scheme might be preferable. Not sure. *)
Require Extraction.

Extraction Language Haskell.
Extract Inductive bool => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Inductive sumbool => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Inductive sumor => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].
Extract Inductive option => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].
Extract Inductive prod => "(,)" ["(,)"].
Extract Inductive unit => "()" ["()"].
Extract Inductive list => "[]" ["[]" "(:)"].
Extraction "./Step.hs" go.


Require Import List.
Require Import Coq.Sets.Constructive_sets.
Require Import Coq.Arith.EqNat.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Strings.String.

(*=================================Basic Definitions*)
Parameter SessID : Set.
Parameter OperName : Set.
Parameter Value : Set.
Definition SeqNo := nat.
Inductive ConsCls:Type := ec: ConsCls |cc: ConsCls |sc: ConsCls.
Inductive op_cls :Type := mkop_cls: OperName -> ConsCls -> op_cls.
Notation " OP '__' t " := (mkop_cls OP t) (at level 0).

(*================================ Effects and Soups and Sessions*)

Record  Effect : Set := mkEffect {name:string; sess : SessID; seq : SeqNo; oper : OperName; val:Value}.
Definition Exec_A := (Ensemble Effect).
Parameter Compute: Exec_A -> OperName -> Value.
Definition session := list op_cls.
Inductive Soup_Ing : Type := |mkSoup_Ing : SessID -> SeqNo -> session -> Soup_Ing.
Definition SessSoup := (Ensemble Soup_Ing).
Inductive op_key : Type:= op_key_cons: SessID->SeqNo->OperName -> op_key.

Notation " '<' s , i , op '>' " := (op_key_cons s i op) (at level 0, op at level 20).
Notation " '<<' A ',' B ',' C  '>>'  " := (mkSoup_Ing A B C)(at level 10).
Notation " S  '|||'  I " :=  ( Union Soup_Ing S  (Singleton Soup_Ing I) ) (at level 80).
(*================================ Stores and Replicas *)
Inductive ReplID:Type := Rid_cons: nat -> ReplID.
Definition Store := ReplID -> Exec_A.
Parameter dom : Store -> (Ensemble ReplID).
Parameter St_Dom_Error : Exec_A.
Notation " A '∈' B " := (dom B A) (at level 80).

Definition Rid_to_nat (r:ReplID): nat :=
  match r with
    |Rid_cons n => n
  end.

Definition F_Union (θ:Store)(r:ReplID)(η:Effect) (rcheck:ReplID) :  Exec_A :=
  if (beq_nat (Rid_to_nat r)(Rid_to_nat rcheck))
  then  (Union Effect (θ r) (Singleton Effect η)) else St_Dom_Error.

Definition Store_Union (Θ:Store) (r:ReplID) (η:Effect) :=
  Union (ReplID -> Exec_A) (Singleton (ReplID -> Exec_A) Θ) (Singleton (ReplID -> Exec_A)(F_Union Θ r η)).

Definition WF_union (S:SessSoup) (I:Soup_Ing): Prop := ~In Soup_Ing S I.

(*================================ Relations of Effects *)
Definition Relation := relation Effect.
Parameter  Rel_dom : Relation -> (Ensemble Effect).
Axiom WF_Relation : forall (r:Relation)(a b:Effect), r a b -> Rel_dom r a /\ Rel_dom r b.

(*Inverse of a relation*)
Inductive rtrn_invs (rel:Relation) (n:Effect) : Ensemble Effect  :=
  first: forall m:Effect, (rel m n) -> (rtrn_invs rel n) m.

Definition Rel_Closure (r:Relation):= clos_trans Effect r.
Definition Rel_Union (r1 r2 :Relation) (a b :Effect):Prop  :=  r1 a b \/ r2 a b.
Definition Rel_Intersect (r1 r2 :Relation) (a b :Effect):Prop  :=  r1 a b /\ r2 a b.

Infix "∩" := Rel_Intersect (at level 40).
Infix "∪" := Rel_Union (at level 50).
(*================================ Executions *)
Inductive Exec : Type :=
|E : Exec_A->  Relation -> Relation -> Relation -> Exec.
Definition return_vis (Ex:Exec): Relation :=
  match Ex with
    |(E AA rr1 rr2 rr3) => rr1
  end.
Definition return_so (Ex:Exec): Relation :=
  match Ex with
    |(E AA rr1 rr2 rr3) => rr2
  end.
Definition return_samobj (Ex:Exec): Relation :=
  match Ex with
    |(E AA rr1 rr2 rr3) => rr3
  end.
Definition return_A (Ex:Exec) :=
  match Ex with
    |(E A vis so sameobj) => A
  end.

Definition hb (Ex:Exec) : Relation := Rel_Closure (Rel_Union (return_vis Ex) (return_so Ex)).
Definition soo (Ex:Exec) : Relation := (Rel_Intersect (return_so Ex) (return_samobj Ex)).
Definition hbo (Ex: Exec) : Relation := (Rel_Closure (Rel_Union (soo Ex) (return_vis Ex))).

Notation "Ex -vis" := (return_vis Ex) (at level 0).
Notation "Ex -so" := (return_so Ex) (at level 0).
Notation "Ex -sameobj" := (return_samobj Ex) (at level 0).
Notation "Ex -A" := (return_A Ex) ( at level 0).
Notation "Ex -soo" := (soo Ex) (at level 0).
Notation "Ex -hb" := (hb Ex) (at level 0).
Notation "Ex -hbo" := (hbo Ex) (at level 0).

(*Causally Consistent Store under an Execution*)
Definition CausCons (Θ:Store)(Ex:Exec):= forall(r: ReplID)(a η:Effect),
                                           (Ex-A a)->((dom Θ) r)->((Θ r) η) -> ((Ex-hbo) a η) -> ((Θ r) a).

(*================================ Well-Formedness of Executions *)
(*!!! This should be changed to a clean inductive definition*)

Parameter WF : Exec -> Prop.

Definition WF1 (Ex:Exec) := forall (a:Effect),     (Ex-A a) -> ~(Ex-hb a a).
Definition WF2 (Ex:Exec) := forall (a b:Effect),   (Ex-A a) -> (Ex-A b) -> (Ex-vis a b)-> (Ex-sameobj a b).
Definition WF3 (Ex:Exec) := forall (a b c:Effect), (Ex-so a b)/\(Ex-so b c) -> (Ex-so a c).
Definition WF4 (Ex:Exec) := forall (a:Effect),     (Ex-A a) -> (Ex-sameobj a a).
Definition WF5 (Ex:Exec) := forall (a b:Effect),   (Ex-A a) -> (Ex-A b) ->(Ex-sameobj a b)-> (Ex-sameobj b a).
Definition WF6 (Ex:Exec) := forall (a b c:Effect), (Ex-A a) -> (Ex-A b) ->(Ex-A c) -> (Ex-sameobj a b)/\(Ex-sameobj b c) -> (Ex-sameobj a c).
Definition WF7 (Ex:Exec) := forall (a b : Effect), (~(Ex-A a))\/(~(Ex-A b)) -> ~(Ex-so a b) /\ ~(Ex-vis a b) /\  ~(Ex-sameobj a b).

(*================================General Definitions *)
(*Equality between two Ensemble*)
Definition Set_Equi (A:Type) (E1 E2: Ensemble A) : Prop :=
  (Included A E1 E2)/\(Included A E2 E1).


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

Require Import Bool.
Require Export ZArith.
Require Import Peano_dec.

Require Import PrettyPrint.
Require Import SimplDecl.

Set Implicit Arguments.
Unset Strict Implicit.

(**************************************************************************)
(* This file contains the domain of interpretation for MiniC expressions  *)
(**************************************************************************)

(**************************************************************************)
(*             Basic types directly borrowed from Coq's library           *)
(**************************************************************************)

Definition c_boolVal := bool.
Definition c_boolEq : c_boolVal -> c_boolVal -> c_boolVal := eqb.
Definition c_boolDiseq (b1 b2 : c_boolVal) : c_boolVal := negb (eqb b1 b2).
Definition c_boolOr : c_boolVal -> c_boolVal -> c_boolVal := orb.
Definition c_boolAnd : c_boolVal -> c_boolVal -> c_boolVal := andb.
Definition c_boolXor : c_boolVal -> c_boolVal -> c_boolVal := xorb.
Definition c_boolNot : c_boolVal -> c_boolVal := negb.
Definition c_true : c_boolVal := true.
Definition c_false : c_boolVal := false.

(**************************************************************************)

(* Positive integers: necessary for the for(i=n;i>0;i--) instruction *)

Definition c_natVal := nat.
Definition c_natPlus : c_natVal -> c_natVal -> c_natVal := plus.
Definition c_natMinus : c_natVal -> c_natVal -> c_natVal := minus.
Definition c_natMult : c_natVal -> c_natVal -> c_natVal := mult.
Definition c_natEq : forall x y : c_natVal, {x = y} + {x <> y} := eq_nat_dec.
Definition c_natLt (n1 n2 : c_natVal) : c_boolVal :=
  If (le_lt_dec n1 n2) then c_false else c_true.
Definition c_natGt (n1 n2 : c_natVal) : c_boolVal :=
  If (le_gt_dec n1 n2) then c_false else c_true.
Definition c_natLe (n1 n2 : c_natVal) : c_boolVal :=
  If (le_gt_dec n1 n2) then c_true else c_false.
Definition c_natGe (n1 n2 : c_natVal) : c_boolVal :=
  If (le_ge_dec n1 n2) then c_true else c_false.

(**************************************************************************)

(*
Definition  c_intVal   := Z.
Definition  c_intPlus  : c_intVal -> c_intVal -> c_intVal := Zplus.
Definition  c_intMinus : c_intVal -> c_intVal -> c_intVal := Zminus.
Definition  c_intInv   : c_intVal -> c_intVal             := Zopp.
Definition  c_intMult  : c_intVal -> c_intVal -> c_intVal := Zmult.
Parameter c_intDiv   : c_intVal -> c_intVal -> c_intVal.
Parameter c_intMod   : c_intVal -> c_intVal -> c_intVal.
Parameter c_intPow   : c_intVal -> c_intVal -> c_intVal.
Definition  c_intEq    : (x,y:c_intVal){x=y}+{~x=y}        := Z_eq_dec.
Definition  c_intLt    : c_intVal -> c_intVal -> c_boolVal := Zlt_bool.
Definition  c_intGt    : c_intVal -> c_intVal -> c_boolVal := Zgt_bool.
Definition  c_intLe    : c_intVal -> c_intVal -> c_boolVal := Zle_bool.
Definition  c_intGe    : c_intVal -> c_intVal -> c_boolVal := Zge_bool.
*)

(**************************************************************************)
(*   Basic types axiomatized for the efficiency fo the MiniC interpreter  *)
(**************************************************************************)

(* Integers *)

Parameter c_intVal : Set.
Parameter c_intZero : c_intVal.
Parameter c_intSucc : c_intVal -> c_intVal.

Parameter c_intPlus : c_intVal -> c_intVal -> c_intVal.
Parameter c_intMinus : c_intVal -> c_intVal -> c_intVal.
Parameter c_intMns : c_intVal -> c_intVal.
Parameter c_intMult : c_intVal -> c_intVal -> c_intVal.

Parameter c_intDiv : c_intVal -> c_intVal -> c_intVal.
Parameter c_intMod : c_intVal -> c_intVal -> c_intVal.
Parameter c_intPow : c_intVal -> c_intVal -> c_intVal.

Parameter c_intEq : c_intVal -> c_intVal -> c_boolVal.
Parameter c_intDiseq : c_intVal -> c_intVal -> c_boolVal.
Parameter c_intLt : c_intVal -> c_intVal -> c_boolVal.
Parameter c_intGt : c_intVal -> c_intVal -> c_boolVal.
Parameter c_intLe : c_intVal -> c_intVal -> c_boolVal.
Parameter c_intGe : c_intVal -> c_intVal -> c_boolVal.

(**************************************************************************)

(* Reals *)

Parameter c_realVal : Set.
Parameter c_realPlus : c_realVal -> c_realVal -> c_realVal.
Parameter c_realMinus : c_realVal -> c_realVal -> c_realVal.
Parameter c_realMns : c_realVal -> c_realVal.
Parameter c_realMult : c_realVal -> c_realVal -> c_realVal.
Parameter c_realDiv : c_realVal -> c_realVal -> c_realVal.
Parameter c_realPow : c_realVal -> c_intVal -> c_realVal.
Parameter c_realEq : c_realVal -> c_realVal -> c_boolVal.
Parameter c_realDiseq : c_realVal -> c_realVal -> c_boolVal.
Parameter c_realLt : c_realVal -> c_realVal -> c_boolVal.
Parameter c_realGt : c_realVal -> c_realVal -> c_boolVal.
Parameter c_realLe : c_realVal -> c_realVal -> c_boolVal.
Parameter c_realGe : c_realVal -> c_realVal -> c_boolVal.
Parameter c_realOfInt : c_intVal -> c_realVal.
Parameter c_intOfReal : c_realVal -> c_intVal.

(**************************************************************************)

(* Characters *)

Parameter c_charVal : Set.
Parameter c_charEq : c_charVal -> c_charVal -> c_boolVal.
Parameter c_charDiseq : c_charVal -> c_charVal -> c_boolVal.
Parameter c_charLt : c_charVal -> c_charVal -> c_boolVal.
Parameter c_charGt : c_charVal -> c_charVal -> c_boolVal.
Parameter c_charLe : c_charVal -> c_charVal -> c_boolVal.
Parameter c_charGe : c_charVal -> c_charVal -> c_boolVal.

Parameter atoi : c_charVal -> c_intVal.
Parameter itoa : c_intVal -> c_charVal.

(**************************************************************************)

(* Memory addresses *)

Parameter address : Set.
Parameter baseAddress : address.
Parameter newAddress : address -> address.

(* jumps n positions from the address adrs *)
Fixpoint shiftToAddress (adrs : address) (n : nat) {struct n} : address :=
  match n with
  | O => adrs
  | S m => shiftToAddress (newAddress adrs) m
  end.

(**************************************************************************)
(**************************************************************************)

Parameter c_ident : Set.
Parameter c_identEq : forall x y : c_ident, {x = y} + {x <> y}.

Parameter c_typeIdent : Set.
Parameter c_typeIdentEq : forall x y : c_typeIdent, {x = y} + {x <> y}.

(**************************************************************************)
(*       The universe of values that a MiniC expression may denote        *)
(**************************************************************************)

Inductive c_basicValue : Set :=
  | C_InjBool : c_boolVal -> c_basicValue
  | C_InjNat : c_natVal -> c_basicValue
  | C_InjInt : c_intVal -> c_basicValue
  | C_InjReal : c_realVal -> c_basicValue
  | C_InjChar : c_charVal -> c_basicValue
  | C_InjAddress : address -> c_basicValue
                   (* stands for garbage in memory *)
  | C_NoVal : c_basicValue.

Parameter c_basicValueEq : forall x y : c_basicValue, {x = y} + {x <> y}.

(* The structure of arrays and record types is preserved, so that
   the translation of Lustre values into MiniC values is a injective
   function *)
Inductive c_value : Set :=
  | C_ValBasic : c_basicValue -> c_value
  | C_ValTuple : list c_value -> c_value
  | C_ValStruct : sdecl c_ident c_value -> c_value.

(* Coercions and functions on the universe of values *)
Coercion C_InjBool : c_boolVal >-> c_basicValue.
Coercion C_InjInt : c_intVal >-> c_basicValue.
Coercion C_InjNat : c_natVal >-> c_basicValue.
Coercion C_InjReal : c_realVal >-> c_basicValue.
Coercion C_InjChar : c_charVal >-> c_basicValue.
Coercion C_InjAddress : address >-> c_basicValue.
Coercion C_ValBasic : c_basicValue >-> c_value.

Parameter c_valueEq : forall x y : c_value, {x = y} + {x <> y}.

(**************************************************************************)
(**************************************************************************)


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  If a relation R is MMA_mon_computable then it is TM_computable.

  Monotonicity of the first counter is needed because a TM cannot erase (only replace) type symbols.
*)

From Undecidability.TM Require Import TM.
From Undecidability.TM Require Util.TM_facts Util.TM_computable.

From Undecidability.MinskyMachines Require Import
  MM MMA.mma_defs Reductions.MMA_computable_to_MMA_mon_computable.

From Undecidability.Shared.Libs.DLW
  Require Import Vec.pos Vec.vec Code.sss Code.subcode.

Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypesDef.
From Undecidability.Shared.Libs.PSL Require Import CompoundFinTypes.
Require Import Undecidability.Shared.Libs.PSL.EqDec.

From Undecidability Require Shared.deterministic_simulation.
Module Sim := deterministic_simulation.

Require Import List Lia PeanoNat Compare_dec Relations.
Import ListNotations.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

#[local] Unset Implicit Arguments.

#[local] Notation enc := (encNatTM true false).

(* generic auxiliary facts *)
Module Facts.

(* transforms a goal (A -> B) -> C into goals A and B -> C *)
Lemma unnest : forall (A B C : Type), A -> (B -> C) -> (A -> B) -> C.
Proof. auto. Qed.

Lemma vec_Forall2_append {X Y : Type} {P : X -> Y -> Prop} {n m : nat} {v : Vector.t X n} {w : Vector.t X m} {v' w'} :
  Vector.Forall2 P v v' -> Vector.Forall2 P w w' ->
  Vector.Forall2 P (Vector.append v w) (Vector.append v' w').
Proof.
  elim. { done. }
  move=> > ? _ /[apply] ?. by constructor.
Qed.

Lemma vec_Forall2_forall {X Y : Type} {P : X -> Y -> Prop} {n : nat} {v : Vector.t X n} {w : Vector.t Y n} :
  (forall i, P (Vector.nth v i) (Vector.nth w i)) <->
  Vector.Forall2 P v w.
Proof.
  split.
  - elim: v w.
    + move=> w ?. rewrite (vec_0_nil w). by constructor.
    + move=> > IH w. rewrite (Vector.eta w) => IH'. constructor.
      * by apply: (IH' pos0).
      * apply: IH => i.
        by apply: (IH' (pos_nxt i)).
  - elim. { by apply: Fin.case0. }
    move=> > ? _ IH i.
    have [->|[j ->]] := pos_S_inv i.
    + done.
    + by apply: IH.
Qed.

Lemma split_nth_error {X : Type} {l : list X} {ls x rs} :
  l = ls ++ x :: rs ->
  nth_error l (length ls) = Some x.
Proof.
  move=> ->. by elim: ls.
Qed.

Lemma vec_pos_nth_eq {X : Type} {n} {v : Vector.t X n} {i} : vec_pos v i = Vector.nth v i.
Proof.
  elim: v i. { by apply: Fin.case0. }
  move=> > IH i.
  have [->|[? ->]] := pos_S_inv i.
  - done.
  - apply: IH.
Qed.

End Facts.
Import Facts.

Module Argument.
Section HaltTM_MMA_HALTING.

Context {n : nat} (M : list (mm_instr (Fin.t (S n)))).
Context (M_mon : forall l x q r, M = l ++ DEC x q :: r -> x <> pos0).

#[local] Notation maxState := (S (length M)).

Definition Σ : finType := finType_CS bool.

Definition state' : finType := finType_CS (bool * Fin.t maxState).

Definition toAddress (p : nat) : Fin.t maxState :=
  if le_lt_dec maxState p is right H then Fin.of_nat_lt H else Fin.F1.

Definition toState (d : bool) (p : nat) : state' := (d, toAddress p).

(*
  INC : write true, move left; write false
  DEC : move right ; write false
*)
Definition trans' : state' * Vector.t (option Σ) (S n) -> state' * Vector.t (option Σ * move) (S n) :=
  fun '((d, p), bs) =>
    match sval (Fin.to_nat p) with
    | 0 =>
        match d with
        | false => ((d, p), TM_facts.nop_action)
        | true => (toState false 1, Vector.const (Some false, Nmove) (S n))
        end
    | S m' =>
      match nth_error M m' with
      | None => ((d, p), TM_facts.nop_action)
      | Some (mm_inc i) =>
          match d with
          | false => ((true, p), vec_change TM_facts.nop_action i (Some true, Lmove))
          | true => (toState false (S (S m')), vec_change TM_facts.nop_action i (Some false, Nmove))
          end
      | Some (mm_dec i q) =>
          match d with
          | false => ((true, p), vec_change TM_facts.nop_action i (None, Rmove))
          | true =>
              match Vector.nth bs i with
              | Some true => (toState false q, vec_change TM_facts.nop_action i (Some false, Nmove))
              | _ => (toState false (S (S m')), vec_change TM_facts.nop_action i (Some false, Nmove))
              end
          end
      end
    end.

#[local] Opaque le_lt_dec Fin.of_nat_lt.

Definition halt' (q : bool * Fin.t maxState) := (negb (fst q)) && Fin.eqb (@Fin.F1 (length M)) (snd q).

Definition P : TM Σ (S n) :=
  {| state := state'; trans := trans'; start := (true, pos0); halt := halt' |}.

Inductive encodes_counter (c : nat) : tape Σ -> Prop :=
  | encodes_counter_intro m : encodes_counter c (midtape (repeat false m) false (repeat true c)).

#[local] Notation encodes_counters cs ts := (Vector.Forall2 encodes_counter cs ts).

#[local] Notation step1 := (sss_step (@mma_sss (S n)) (1, M)).
#[local] Notation step2 := (fun x y => halt' (TM_facts.cstate x) = false /\ y = @TM_facts.step _ _ P x).

#[local] Notation "P // s ->> t" := (sss_compute (@mma_sss _) P s t).

Inductive sync : nat * Vector.t nat (S n) -> TM_facts.mconfig Σ (state P) (S n) -> Prop :=
  | sync_intro i v bs :
    encodes_counters v bs ->
    Vector.nth bs pos0 = enc (Vector.nth v pos0) ->
    sync (i, v) (TM_facts.mk_mconfig (toState false i) bs).

Lemma syncE i v p bs : sync (i, v) (TM_facts.mk_mconfig p bs) ->
  encodes_counters v bs /\ Vector.nth bs pos0 = enc (Vector.nth v pos0) /\ p = toState false i.
Proof.
  intros H. now inversion H.
Qed.

Definition inc_bs {n} x (ts : Vector.t (tape Σ) (S n)) :=
  TM_facts.doAct_multi
    (TM_facts.doAct_multi ts (vec_change TM_facts.nop_action x (Some true, Lmove)))
    (vec_change TM_facts.nop_action x (Some false, Nmove)).

Definition dec_bs {n} x (ts : Vector.t (tape Σ) (S n)) :=
  TM_facts.doAct_multi
    (TM_facts.doAct_multi ts (vec_change TM_facts.nop_action x (None, Rmove)))
    (vec_change TM_facts.nop_action x (Some false, Nmove)).

Lemma to_nat_toAddress {l instr r} :
  M = l ++ instr :: r ->
  sval (Fin.to_nat (toAddress (S (length l)))) = S (length l).
Proof.
  move=> HM. rewrite /toAddress /=.
  case: (le_lt_dec maxState (S (length l))).
  - move: HM => /(f_equal (@length _)).
    rewrite app_length /=. lia.
  - move=> ?. by rewrite Fin.to_nat_of_nat.
Qed.

Lemma sync_inc p v i ts :
  Vector.nth ts pos0 = enc (Vector.nth v pos0) ->
  encodes_counters v ts ->
  sync (p, vec_change v i (S (Vector.nth v i))) (TM_facts.mk_mconfig (toState false p) (inc_bs i ts)).
Proof.
  move=> H0vts /vec_Forall2_forall Hvts. apply: sync_intro.
  - rewrite /inc_bs. apply /vec_Forall2_forall => j.
    have [<-|Hij] := pos_eq_dec i j.
    + rewrite /TM_facts.doAct_multi.
      rewrite !TM_facts.nth_map2'.
      rewrite -!vec_pos_nth_eq.
      rewrite !(vec_change_eq _ _ erefl).
      rewrite !vec_pos_nth_eq.
      move: (Vector.nth v i) (Vector.nth ts i) (Hvts i).
      move=> ? ? [] [|?].
      * by apply: (encodes_counter_intro _ 0).
      * by apply: encodes_counter_intro.
    + rewrite /TM_facts.doAct_multi.
      rewrite !TM_facts.nth_map2'.
      rewrite -!vec_pos_nth_eq.
      rewrite !(vec_change_neq _ _ Hij).
      rewrite !vec_pos_nth_eq !TM_facts.nth_nop_action.
      by apply: Hvts.
  - rewrite /inc_bs.
    move: H0vts. rewrite (Vector.eta v) (Vector.eta ts).
    have [->|[j ->]] := pos_S_inv i.
    + move=> /= ->. by case: (VectorDef.hd v) => /=.
    + by move=> /= ->.
Qed.

Lemma sync_dec_0 p v i ts :
  Vector.nth ts pos0 = enc (Vector.nth v pos0) ->
  encodes_counters v ts ->
  Vector.nth v i = 0 ->
  i <> pos0 ->
  sync (p, v) (TM_facts.mk_mconfig (toState false p) (dec_bs i ts)).
Proof.
  move=> H0vts /vec_Forall2_forall Hvts Hvi Hi. apply: sync_intro.
  - rewrite /dec_bs. apply /vec_Forall2_forall => j.
    have [<-|Hij] := pos_eq_dec i j.
    + rewrite /TM_facts.doAct_multi.
      rewrite !TM_facts.nth_map2'.
      rewrite -!vec_pos_nth_eq.
      rewrite !(vec_change_eq _ _ erefl).
      rewrite !vec_pos_nth_eq.
      move: (Vector.nth v i) (Vector.nth ts i) Hvi (Hvts i).
      move=> > -> [] m.
      by apply: (encodes_counter_intro _ (S m)).
    + rewrite /TM_facts.doAct_multi.
      rewrite !TM_facts.nth_map2'.
      rewrite -!vec_pos_nth_eq.
      rewrite !(vec_change_neq _ _ Hij).
      rewrite !vec_pos_nth_eq !TM_facts.nth_nop_action.
      by apply: Hvts.
  - rewrite /dec_bs.
    move: H0vts Hi. rewrite (Vector.eta v) (Vector.eta ts).
    have [->|[j ->]] := pos_S_inv i.
    + done.
    + by move=> /= ->.
Qed.

Lemma sync_dec_S p v i ts k :
  Vector.nth ts pos0 = enc (Vector.nth v pos0) ->
  encodes_counters v ts ->
  Vector.nth v i = S k ->
  i <> pos0 ->
  sync (p, vec_change v i k) (TM_facts.mk_mconfig (toState false p) (dec_bs i ts)).
Proof.
  move=> H0vts /vec_Forall2_forall Hvts Hvi Hi. apply: sync_intro.
  - rewrite /dec_bs. apply /vec_Forall2_forall => j.
    have [<-|Hij] := pos_eq_dec i j.
    + rewrite /TM_facts.doAct_multi.
      rewrite !TM_facts.nth_map2'.
      rewrite -!vec_pos_nth_eq.
      rewrite !(vec_change_eq _ _ erefl).
      rewrite !vec_pos_nth_eq.
      move: (Vector.nth v i) (Vector.nth ts i) Hvi (Hvts i).
      move=> > -> [] m.
      by apply: (encodes_counter_intro _ (S m)).
    + rewrite /TM_facts.doAct_multi.
      rewrite !TM_facts.nth_map2'.
      rewrite -!vec_pos_nth_eq.
      rewrite !(vec_change_neq _ _ Hij).
      rewrite !vec_pos_nth_eq !TM_facts.nth_nop_action.
      by apply: Hvts.
  - rewrite /dec_bs.
    move: H0vts Hi. rewrite (Vector.eta v) (Vector.eta ts).
    have [->|[j ->]] := pos_S_inv i.
    + done.
    + by move=> /= ->.
Qed.

Lemma current_chars_act k (ts : Vector.t (tape Σ) k) i actions action :
  Vector.nth (TM_facts.current_chars (TM_facts.doAct_multi ts
    (vec_change actions i action))) i = current (TM_facts.doAct (Vector.nth ts i) action).
Proof.
  elim: ts i actions. { by apply: Fin.case0. }
  move=> t ? ts IH i actions.
  rewrite (Vector.eta actions).
  have [->|[j ->]] := pos_S_inv i.
  - done.
  - by apply: IH.
Qed.

Lemma Vector_nth_tapes {k v ts} (i : Fin.t k) :
  encodes_counters v ts ->
  exists m, Vector.nth ts i = midtape (repeat false m) false (repeat true (Vector.nth v i)).
Proof.
  move=> H. elim: H i. { by apply: Fin.case0. }
  move=> > [] > ? IH i.
  have [->|[j ->]] := pos_S_inv i.
  - by eexists.
  - by apply: (IH j).
Qed.

#[local] Opaque toAddress.
#[local] Opaque vec_change TM_facts.nop_action.

Lemma fstep (s t : nat * vec nat (S n)) (s' : TM_facts.mconfig Σ (state P) (S n)) :
  sss_step (@mma_sss _) (1, M) s t ->
  sync s s' ->
  exists t', clos_trans _ step2 s' t' /\ sync t t'.
Proof using M_mon.
  move=> [?] [l] [instr] [r] [{}v] [[<- HM]] [->].
  move E: ((1 + (length l), v)) => st H.
  case: H HM E.
  - (* inc *)
    move=> ? x ? HM [<- <-].
    move: s' => [p ts] /syncE [Hvts [E0 ->]].
    exists (TM_facts.mk_mconfig (toState false (1 + (1 + (length l)))) (inc_bs x ts)).
    split; [apply: t_trans; (apply: t_step; split)|].
    + cbn.
      have := to_nat_toAddress HM.
      by case: (toAddress (S (length l))).
    + by rewrite /TM_facts.step /= (to_nat_toAddress HM) (split_nth_error HM).
    + done.
    + by rewrite /TM_facts.step /= (to_nat_toAddress HM) (split_nth_error HM).
    + rewrite vec_pos_nth_eq. by apply: sync_inc.
  - (* dec_0 *)
    move=> ? x q v' Hx HM [<- ?]. subst v'.
    rewrite vec_pos_nth_eq in Hx.
    move: s' => [p ts] /syncE [Hvts [E0 ->]].
    exists (TM_facts.mk_mconfig (toState false (1 + (1 + (length l)))) (dec_bs x ts)).
    move: (HM) => /M_mon ?.
    split; [apply: t_trans; (apply: t_step; split)|].
    + cbn.
      have := to_nat_toAddress HM.
      by case: (toAddress (S (length l))).
    + by rewrite /TM_facts.step /= (to_nat_toAddress HM) (split_nth_error HM).
    + done.
    + rewrite /TM_facts.step /= (to_nat_toAddress HM) (split_nth_error HM).
      rewrite current_chars_act.
      have [? ->] := Vector_nth_tapes x Hvts.
      by rewrite Hx /=.
    + by apply: sync_dec_0.
  - (* dec_1 *)
    move=> ? x q v' ? Hx HM [<- ?]. subst v'.
    rewrite vec_pos_nth_eq in Hx.
    move: s' => [p ts] /syncE [Hvts [E0 ->]].
    exists (TM_facts.mk_mconfig (toState false q) (dec_bs x ts)).
    move: (HM) => /M_mon ?.
    split; [apply: t_trans; (apply: t_step; split)|].
    + cbn.
      have := to_nat_toAddress HM.
      by case: (toAddress (S (length l))).
    + by rewrite /TM_facts.step /= (to_nat_toAddress HM) (split_nth_error HM).
    + done.
    + rewrite /TM_facts.step /= (to_nat_toAddress HM) (split_nth_error HM).
      rewrite current_chars_act.
      have [? ->] := Vector_nth_tapes x Hvts.
      by rewrite Hx /=.
    + by apply: sync_dec_S.
Qed.

Lemma simulation i v i' v' st : (1, M) // (i, v) ->> (i', v') ->
  sync (i, v) st ->
  exists st', sync (i', v') st' /\ clos_refl_trans _ step2 st st'.
Proof using M_mon.
  move=> /sss_compute_iff H1 H2. by apply: (Sim.clos_refl_trans_transport fstep H2 H1).
Qed.

Lemma step2_det s t1 t2 : step2 s t1 -> step2 s t2 -> t1 = t2.
Proof.
  by move=> /= [_ ->] [_ ->].
Qed.

Lemma step1_intro s : (exists t, step1 s t) \/ (Sim.stuck step1 s).
Proof.
  have [|] := subcode.in_out_code_dec (fst s) (1, M).
  - move=> /in_code_step ?. by left.
  - move=> /out_code_iff ?. by right.
Qed.

Lemma halt'_terminates s' : halt' (TM_facts.cstate s') = true -> Sim.terminates step2 s'.
Proof.
  move:s' => [[[] p] ts] /=; [done|].
  rewrite /halt' /=.
  have [->|[q ->]] := pos_S_inv p; [|done].
  rewrite Nat.eqb_refl /= => _. eexists.
  split; [apply: rt_refl|].
  move=> {}t' /=. rewrite Nat.eqb_refl. by case.
Qed.

Lemma terminates2I k {s' t' : TM_facts.mconfig Σ (state P) (S n)} :
  TM_facts.loopM s' k = Some t' ->
  Sim.terminates step2 s'.
Proof.
  elim: k s'.
  { move=> s' /= Hs'. apply: halt'_terminates.
    by case: (halt' (TM_facts.cstate s')) Hs'. }
  move=> k IH s' /=.
  case E: (halt' (TM_facts.cstate s')) => [].
  - move=> ?. by apply: halt'_terminates.
  - move=> /IH [u'] [? ?]. exists u'. split; [|done].
    by apply: rt_trans; [apply: rt_step|eassumption].
Qed.

Lemma stuck_step2E s' :
  Sim.stuck step2 s' -> halt' (TM_facts.cstate s') = true.
Proof.
  move=> Hs'.
  case E: (halt' (TM_facts.cstate s')); [done|].
  exfalso.
  by apply: (Hs' (@TM_facts.step _ _ P s')).
Qed.

Lemma terminates2E {s' t' : TM_facts.mconfig Σ (state P) (S n)} :
  clos_refl_trans _ step2 s' t' -> Sim.stuck step2 t' ->
  exists k, TM_facts.loopM s' k = Some t'.
Proof.
  move=> /clos_rt_rt1n_iff. elim.
  - move=> {}s' /stuck_step2E Hs'.
    exists 0. by rewrite /= Hs'.
  - move=> > [E ->] _ /[apply] - [k] ?.
    exists (S k). by rewrite /= E.
Qed.

#[local] Transparent toAddress.

Lemma stuck_step2I {s s'} :
  sync s s' ->
  out_code (fst s) (1, M) ->
  Sim.stuck step2 s'.
Proof.
  case => i v bs _ _ /= Hi t' /=.
  rewrite /halt' /= /toAddress.
  case: (le_lt_dec maxState i) => /=.
  { rewrite Nat.eqb_refl => ?. by case. }
  move=> H'i. have ? : i = 0 by lia. subst i.
  suff -> : Fin.of_nat_lt H'i = pos0.
  { rewrite Nat.eqb_refl. by case. }
  rewrite [RHS](esym (Fin.of_nat_to_nat_inv pos0)).
  by apply: Fin.of_nat_ext.
Qed.

End HaltTM_MMA_HALTING.
End Argument.

Import Argument.

Lemma P_init {k k'} {M : list (mm_instr (pos (1+k+k')))} {v : Vector.t nat k} :
  @TM_facts.step _ _ (P M) (TM_facts.mk_mconfig (true, pos0) (niltape ## Vector.append (Vector.map enc v) (Vector.const niltape k'))) =
  TM_facts.mk_mconfig (toState M false 1) (enc 0 ## Vector.append (Vector.map enc v) (Vector.const (enc 0) k')).
Proof.
  cbn. congr TM_facts.mk_mconfig. congr Vector.cons.
  elim: v.
  - cbn. elim: (k'). { done. }
    by move=> > /= ->.
  - by move=> > /= ->.
Qed.

Lemma sync_init {k k'} {M : list (mm_instr (pos (1+k+k')))} {v : Vector.t nat k} : @sync _ M
  (1, Vector.append (0 ## v) (Vector.const 0 k'))
  (TM_facts.mk_mconfig (toState M false 1) (Vector.append ((enc 0) ## Vector.map enc v) (Vector.const (enc 0) k'))).
Proof.
  apply: sync_intro; [|done] => /=.
  constructor. { by apply: (encodes_counter_intro _ 0). }
  apply: vec_Forall2_append.
  - elim: v. { by constructor. }
    move=> *. constructor; [|done].
    by apply: (encodes_counter_intro _ 0).
  - clear. elim: k'. { by constructor. }
    move=> *. constructor; [|done].
    by apply: (encodes_counter_intro _ 0).
Qed.

Theorem MMA_mon_computable_to_TM_computable k (R : Vector.t nat k -> nat -> Prop) :
  MMA_mon_computable R -> TM_computable R.
Proof.
  move=> /MMA_mon_computable_iff [k'] [M] [H1M [H2M H3M]].
  have : forall l x q r, M = l ++ DEC x q :: r -> x <> pos0.
  { move=> > HM Hi. by move: HM Hi H1M => -> -> /Forall_app [_] /Forall_cons_iff []. }
  move=> {}H1M. apply /TM_computable.TM_computable_iff.
  exists k', Argument.Σ, true, false.
  split; [done|]. exists (Argument.P M). split.
  - move=> v m /H2M [c] [v'] [] /(simulation M H1M) => /(_ _ sync_init).
    move=> [[p' b's]] [Hst'] /terminates2E + ?.
    apply: unnest. { by apply: stuck_step2I; eassumption. }
    move=> [n] Hn. exists p', b's. split.
    + apply /TM_facts.TM_eval_iff.
      exists (S n) => /=. by rewrite P_init.
    + move: Hst' => /syncE. rewrite (Vector.eta b's) /=.
      by move=> [_ []].
  - move=> v q ts /TM_facts.TM_eval_iff [n HPn].
    apply: H3M. apply /sss_terminates_iff.
    apply /(Sim.terminates_reflection (step2_det M) (fstep M H1M) (step1_intro M) sync_init).
    move: n HPn => [|n]. { done. }
    rewrite /= P_init. by apply: terminates2I.
Qed.