(* This file contains lemmas used by other pieces of the automation,
 * e.g. ChargeCore.Tactics.Tauto. It is a separate file so that
 * it does not pollute the global namespace when those modules are imported.
 *)
Require Export ChargeCore.Logics.ILogic.

Section logic.
  Context {L : Type}.
  Context {ILO : ILogicOps L}.
  Context {IL : ILogic L}.

  Theorem lcut : forall P Q R : L,
      P |-- R ->
      P |-- R -->> Q ->
      P |-- Q.
  Proof.
    intros.
    eapply landAdj in H0.
    etransitivity; [ | eassumption ].
    eapply landR. reflexivity. assumption.
  Qed.

  Theorem limplAdj_true : forall P Q,
      P |-- Q ->
      ltrue |-- P -->> Q.
  Proof.
    intros. apply limplAdj. apply landL2. assumption.
  Qed.

  Theorem landAdj_true : forall P Q,
      ltrue |-- P -->> Q ->
      P |-- Q.
  Proof.
    intros. apply landAdj in H. rewrite <- H.
    apply landR. apply ltrueR. reflexivity.
  Qed.

  Lemma lapply : forall P Q R,
      P |-- Q -->> R ->
      P |-- Q ->
      P |-- R.
  Proof. intros; eapply lcut; eauto. Qed.

  Lemma lapply2 : forall P Q R S,
      P |-- Q -->> R -->> S ->
      P |-- Q ->
      P |-- R ->
      P |-- S.
  Proof. intros; eapply lcut; eauto using lapply. Qed.

  Lemma lapply3 : forall P Q R S T,
      P |-- Q -->> R -->> S -->> T ->
      P |-- Q ->
      P |-- R ->
      P |-- S ->
      P |-- T.
  Proof. intros; eapply lcut; eauto using lapply2. Qed.

  Lemma lapply4 : forall P Q R S T U,
      P |-- Q -->> R -->> S -->> T -->> U ->
      P |-- Q ->
      P |-- R ->
      P |-- S ->
      P |-- T ->
      P |-- U.
  Proof. intros; eapply lcut; eauto using lapply3. Qed.

  Lemma lapply5 : forall P Q R S T U V,
      P |-- Q -->> R -->> S -->> T -->> U -->> V ->
      P |-- Q ->
      P |-- R ->
      P |-- S ->
      P |-- T ->
      P |-- U ->
      P |-- V.
  Proof. intros; eapply lcut; eauto using lapply4. Qed.

  Lemma land_lor_distr_L : forall P Q R,
      P //\\ (Q \\// R) -|- (P //\\ Q) \\// (P //\\ R).
  Proof.
    intros. split.
    { rewrite landC. apply landAdj.
      apply lorL; apply limplAdj.
      { apply lorR1. rewrite landC. reflexivity. }
      { apply lorR2. rewrite landC. reflexivity. } }
    { apply lorL; apply landR; try solve [ apply landL1 ; reflexivity ].
      { apply lorR1. apply landL2. reflexivity. }
      { apply lorR2. apply landL2. reflexivity. } }
  Qed.

  Lemma land_lor_distr_R : forall P Q R,
      (Q \\// R) //\\ P -|- (P //\\ Q) \\// (P //\\ R).
  Proof.
    intros. split.
    { apply landAdj.
      apply lorL; apply limplAdj.
      { apply lorR1. rewrite landC. reflexivity. }
      { apply lorR2. rewrite landC. reflexivity. } }
    { apply lorL; apply landR; try solve [ apply landL1 ; reflexivity ].
      { apply lorR1. apply landL2. reflexivity. }
      { apply lorR2. apply landL2. reflexivity. } }
  Qed.

End logic.

(* Local definitions, for proving subsequent lemmas. *)
Local Ltac charge_split := apply landR.

Local Ltac charge_search_prems found :=
  match goal with
  | |- ?X |-- ?Y =>
    solve [ found
          | apply landL1 ; charge_search_prems found
          | apply landL2 ; charge_search_prems found ]
  end.

Local Ltac charge_assumption :=
  charge_search_prems reflexivity.

Local Ltac charge_intro :=
  first [ apply lforallR; intro
        | apply limplAdj_true
        | apply limplAdj ].

Local Ltac charge_intros :=
  repeat match goal with
         | |- _ |-- _ -->> _ =>
           charge_intro
         | |- _ |-- @lforall _ _ _ _ =>
           charge_intro
         end.

Local Ltac charge_trivial := apply ltrueR.

Local Ltac charge_use :=
  first [ eapply lapply; [ charge_assumption | ]
        | eapply lapply2; [ charge_assumption | | ]
        | eapply lapply3; [ charge_assumption | | | ]
        | eapply lapply4; [ charge_assumption | | | | ]
        | eapply lapply5; [ charge_assumption | | | | | ] ].

Local Ltac ends_with H ABC C :=
  let rec go k ABC :=
      match ABC with
      | C => k
      | _ -->> ?BC =>
        let k' := (k; first [ apply landAdj_true in H | apply landAdj in H ]) in
        go k' BC
      end
  in
  go ltac:(idtac) ABC.

Local Ltac charge_apply H :=
  match type of H with
  | _ |-- ?X =>
    match goal with
    | |- _ |-- ?Y =>
      ends_with H X Y ; etransitivity ; [ | eapply H ]
    end
  end.

Local Ltac charge_tauto :=
  repeat charge_split ;
  solve [ charge_assumption
        | charge_trivial
        | charge_intro; repeat charge_intro; charge_tauto
        | charge_split; solve [ charge_tauto ]
        | match goal with
          | H : _ |-- _ |- _ =>
            charge_apply H ; charge_tauto
          end
        | charge_use ; charge_tauto ].

Section logic2.
  Context {L : Type}.
  Context {ILO : ILogicOps L}.
  Context {IL : ILogic L}.

  Definition liff (A B : L) : L :=
    (A -->> B) //\\ (B -->> A).

  Local Notation "x <<-->> y" := (liff x y) (at level 78).

  Lemma ltrue_liff : forall A B,
      |-- A <<-->> B <-> A -|- B.
  Proof.
    unfold liff. split.
    { intros. split.
      { apply landAdj_true.
        rewrite H. apply landL1. reflexivity. }
      { apply landAdj_true.
        rewrite H. apply landL2. reflexivity. } }
    { intro. rewrite H.
      apply landR; apply limplAdj_true; reflexivity. }
  Qed.

  Lemma land_cancel : forall A B C,
      A |-- B <<-->> C ->
      A //\\ B -|- A //\\ C.
  Proof.
    intros. split.
    { charge_split; try charge_tauto.
      rewrite H. charge_tauto. }
    { charge_split; try charge_tauto.
      rewrite H. charge_tauto. }
  Qed.

  Lemma uncurry : forall P Q R,
      (P //\\ Q -->> R) -|- (P -->> Q -->> R).
  Proof.
    intros. split.
    { charge_tauto. }
    { charge_intro.
      eapply lapply. eapply lapply. charge_assumption.
      charge_tauto. charge_tauto. }
  Qed.

  Lemma forget_prem : forall P Q,
      |-- P -> Q |-- P.
  Proof. intros; charge_tauto. Qed.

  Lemma lrevert : forall P Q,
      |-- P -->> Q ->
      P |-- Q.
  Proof. intros; charge_tauto. Qed.

  Lemma charge_and_use : forall P Q C,
      C |-- P ->
      C //\\ P |-- Q ->
      C |-- P //\\ Q.
  Proof.
    intros. charge_tauto.
  Qed.

  Lemma land_limpl_specialize_ap : forall P Q L R G,
      L //\\ R |-- P ->
      L //\\ Q //\\ R |-- G ->
      L //\\ (P -->> Q) //\\ R |-- G.
  Proof.
    intros. charge_tauto.
  Qed.

  Lemma land_limpl_specializeR_ap : forall P Q R G,
      R |-- P ->
      Q //\\ R |-- G ->
      (P -->> Q) //\\ R |-- G.
  Proof.
    intros; charge_tauto.
  Qed.

  Lemma land_limpl_specializeL_ap : forall P Q R G,
      R |-- P ->
      Q //\\ R |-- G ->
      R //\\ (P -->> Q) |-- G.
  Proof.
    intros; charge_tauto.
  Qed.

  Lemma landA_ap : forall P Q R G,
      (P //\\ Q) //\\ R |-- G ->
      P //\\ Q //\\ R |-- G.
  Proof.
    intros. charge_tauto.
  Qed.

  Lemma land_lexists_ap : forall T (P : T -> L) Q R S,
      (forall x, S //\\ P x //\\ Q |-- R) ->
      S //\\ (lexists P) //\\ Q |-- R.
  Proof.
    intros. rewrite landC. rewrite landA.
    eapply landAdj.
    apply lexistsL.
    intro. specialize (H x).
    charge_tauto.
  Qed.

  Lemma land_lexistsL_ap : forall T (P : T -> L) R S,
      (forall x, S //\\ P x |-- R) ->
      S //\\ (lexists P) |-- R.
  Proof.
    intros. rewrite landC.
    eapply landAdj.
    apply lexistsL.
    intro. specialize (H x).
    charge_tauto.
  Qed.

  Lemma land_lexistsR_ap : forall T (P : T -> L) R S,
      (forall x, P x //\\ S |-- R) ->
      lexists P //\\ S |-- R.
  Proof.
    intros.
    eapply landAdj.
    apply lexistsL.
    intro. specialize (H x).
    charge_tauto.
  Qed.

End logic2.

Notation "x <<-->> y" := (liff x y) (at level 78).


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.

Section Arrow.
  Local Open Scope morphism_scope.

  (** The type accomodating all arrows of a category C. *)
  Record Arrow (C : Category) :=
    {
      Orig : Obj;
      Targ : Obj;
      Arr : Orig –≻ Targ
    }.

  Arguments Orig {_} _.
  Arguments Targ {_} _.
  Arguments Arr {_} _.

  Coercion Arr : Arrow >-> Hom.

  (** An arrow (in the appropriate category, e.g., comma)
    from arrow f : a -> b to arrow g : c -> d is a pair of arrows h1 : a -> c
    and h2 : b -> d that makes the following diagram commute:
#

          f
   a ———————————> b
   |              |
h1 |              | h2
   |              |
   ↓              ↓
   c ———————————> d
          g

#
 *)
  Record Arrow_Hom {C : Category} (a b : Arrow C) :=
    {
      Arr_H : (Orig a) –≻ (Orig b);
      Arr_H' : (Targ a) –≻ (Targ b);
      Arr_Hom_com : Arr_H' ∘ (Arr a) = (Arr b) ∘ Arr_H
    }.
  Arguments Arr_H {_ _ _} _.
  Arguments Arr_H' {_ _ _} _.
  Arguments Arr_Hom_com {_ _ _} _.

  Context (C : Category).

  Section Arrow_Hom_eq_simplify.
    Context {a b : Arrow C} (f g : Arrow_Hom a b).

    (** Two arrow homomorphisms are equal if the arrows between theor domains
        and codomain are respectively equal. In other words, we don't care about
        the proof of the diagram commuting. *)
    Lemma Arrow_Hom_eq_simplify : Arr_H f = Arr_H g → Arr_H' f = Arr_H' g → f = g.
    Proof.
      destruct f; destruct g.
      basic_simpl.
      ElimEq.
      PIR.
      reflexivity.
    Qed.

  End Arrow_Hom_eq_simplify.

  Section Compose_id.
    Context {x y z} (h : Arrow_Hom x y) (h' : Arrow_Hom y z).

    (** Composition of arrow homomorphisms. We basicall need to show that in the
        following diagram, the bigger diagram commutes if the smaller ones do.
#

           f
    a ———————————> b
    |              |
 h1 |              | h2
    |              |
    ↓              ↓
    c ———————————> d
    |      g       |
h1' |              | h2'
    |              |
    ↓              ↓
    c ———————————> d
           h

#
*)
    Program Definition Arrow_Hom_compose : Arrow_Hom x z :=
      {|
        Arr_H := (Arr_H h') ∘ (Arr_H h);
        Arr_H' := (Arr_H' h') ∘ (Arr_H' h)
      |}.

    Next Obligation. (* Arr_Hom_com *)
    Proof.
      destruct h as [hh hh' hc]; destruct h' as [h'h h'h' h'c]; cbn.
      rewrite assoc.
      rewrite hc.
      repeat rewrite assoc_sym.
      rewrite h'c.
      auto.
    Qed.

    (** The identity arrow morphism. We simply need to show that the following
        diagram commutes:
#

          f
   a ———————————> b
   |              |
id |              | id
   |              |
   ↓              ↓
   a ———————————> b
          f

#
which is trivial.
 *)
    Program Definition Arrow_id : Arrow_Hom x x :=
      {|
        Arr_H := id;
        Arr_H' := id
      |}.

  End Compose_id.

End Arrow.

Hint Extern 1 (?A = ?B :> Arrow_Hom _ _) => apply Arrow_Hom_eq_simplify; simpl.

Arguments Orig {_} _.
Arguments Targ {_} _.
Arguments Arr {_} _.

Arguments Arr_H {_ _ _} _.
Arguments Arr_H' {_ _ _} _.
Arguments Arr_Hom_com {_ _ _} _.

(** an arrow in a category is also an arrow in the opposite category.
    The domain and codomain are simply swapped. *)
Program Definition Arrow_to_Arrow_OP (C : Category) (ar : Arrow C) :
  Arrow (C ^op) :=
  {|
    Arr := ar
  |}.

(** The type of arrows of a category and the type of arrows of its opposite are
     isomorphic. *)
Program Definition Arrow_OP_Iso (C : Category) :
  ((Arrow C) ≃≃ (Arrow (C ^op)) ::> Type_Cat)%isomorphism :=
  {|
    iso_morphism := Arrow_to_Arrow_OP C;
    inverse_morphism := Arrow_to_Arrow_OP (C ^op)
  |}.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.

Generalizable All Variables.

Section Monad.

Context `{M : C ⟶ C}.

Class Monad := {
  ret {x}  : x ~> M x;          (* Id    ⟹ M *)
  join {x} : M (M x) ~> M x;    (* M ○ M ⟹ M *)

  fmap_ret {x y} (f : x ~> y) : ret ∘ f ≈ fmap f ∘ ret;

  join_fmap_join {x} : join ∘ fmap (@join x) ≈ join ∘ join;
  join_fmap_ret  {x} : join ∘ fmap (@ret x) ≈ id;
  join_ret       {x} : join ∘ @ret (M x) ≈ id;

  (* This law states that join is a natural transformation. *)
  join_fmap_fmap {x y} (f : x ~> y) :
    join ∘ fmap (fmap f) ≈ fmap f ∘ join
}.

End Monad.

Arguments Monad {C} M.

Notation "ret[ M ]" := (@ret _ M _ _)
  (at level 9, format "ret[ M ]") : category_scope.
Notation "join[ M ]" := (@join _ M _ _)
  (at level 9, format "join[ M ]") : category_scope.

Section MonadLib.

Context `{@Monad C M}.

Definition bind {x y : C} (f : x ~> M y) : M x ~> M y :=
  join ∘ fmap[M] f.

End MonadLib.

Notation "m >>= f" := (bind f m) (at level 42, right associativity) : morphism_scope.
Notation "f >> g" := (f >>= fun _ => g)%morphism
  (at level 81, right associativity) : morphism_scope.

Require Import Category.Construction.Opposite.
Require Import Category.Functor.Opposite.

Definition Comonad `{M : C ⟶ C} := @Monad (C^op) (M^op).


Require Import Reals.
Require Import Rintegral Riemann_integrable.
Require Import Rfunction_classes Nth_derivative_def.
Require Import Lra Ring.
Require Import Ranalysis.
Require Import Rextensionality.

(* Trivial version of linear Cauchy-Lipschitz*)

Section Trivial.

Lemma C_Sn_derivable : forall f n, C (S n) f -> derivable f.
Proof.
 intros.
 inversion H. subst. apply pr.
Qed.

Lemma C_Sm_derive_C_m : forall f n pr, C (S n) f -> C n (derive f pr).
Proof.
 intros.
 inversion H.
 eapply C_ext. 2: apply H1. intro. apply pr_nu.
Qed.

Lemma C_continuity : forall f n, C n f -> continuity f.
Proof.
intros.
inversion H. apply H0.
apply derivable_continuous. assumption.
Qed.

Lemma CL_tr : forall a t0 V0, C 0 a ->
  {y : R -> R & {pr : (D 1 y) | forall (t : R), (nth_derive y pr) t = (a t) * (y t) /\ y t0 = V0}}.
Proof.
 intros a t0 V0 H ; assert (Hcont : continuity a) by (inversion H ; assumption).
 assert (forall t0 t, Riemann_integrable a t0 t).
  intros ; apply continuity_RiemannInt_1.
  intros ; inversion H ; auto.
 assert (pr : C 1 (fun t => V0 * exp (@RiemannInt a t0 t (X t0 t)))).
  apply C_scal; apply (C_comp 1 exp); [apply C_infty_exp |
  apply derivable_pt_continuity_Riemann_implies_C1] ; reg.

 exists (fun t => V0 * exp (@RiemannInt a t0 t (X t0 t))) ; exists (C_implies_D _ _ pr).

 intro t ; split.
  rewrite <- (derive_pt_RiemannInt a t0 t X (Hcont t)), <-(derive_pt_exp ),
  <- derive_pt_scal, Rmult_comm, <- (derive_pt_comp (fun t1 => RiemannInt (X t0 t1))
  (mult_real_fct V0 exp)) ; apply pr_nu_var ; reflexivity.
  rewrite RiemannInt_singleton, exp_0 ; apply Rmult_1_r.
Qed.

Lemma RiemannInt_continuity : forall a t0 (Hconta : continuity a) (Ha : forall t0 t,
   Riemann_integrable a t0 t), continuity (fun t => RiemannInt (Ha t0 t)).
Proof.
 intros ; apply derivable_continuous ; intro ; apply RiemannInt_derivable_pt ; apply Hconta.
Qed.

Lemma CL_tr_second_member : forall a b t0 V0, C 0 a -> C 0 b ->
  {y : R -> R & { pr : (D 1 y) |
    forall (t : R), (nth_derive y pr) t - (a t) * (y t) = b t /\ y t0 = V0}}.
Proof.
 intros a b t0 V0 Ha0 Hb0 ;
 assert (Ha: forall t0 t, Riemann_integrable a t0 t)
    by (intros ; apply continuity_RiemannInt_1 ; inversion Ha0 ; intuition) ;
 assert (Hconta : continuity a)
    by (inversion Ha0 ; assumption) ;
 assert (Hcontb : continuity b)
    by (inversion Hb0 ; assumption).

 assert (Hcontsol : forall t1 t, continuity_pt
   (b * (comp exp (- (fun t => RiemannInt (Ha t1 t)))))%F t).
  intros ; reg ; apply (C_continuity _ 1) ;
  apply derivable_pt_continuity_Riemann_implies_C1 ; assumption.

 assert (Hsol : forall t1 t0 t, Riemann_integrable
  (b * (comp exp (- (fun t => RiemannInt (Ha t1 t)))))%F t0 t)
    by (intros ; apply continuity_RiemannInt_1 ; intuition).

 assert (pr : C 1 (((fct_cte V0) + (fun t => RiemannInt (Hsol t0 t0 t))) *
  (comp exp (fun t => RiemannInt (Ha t0 t))))%F).
  apply C_mult ; [apply C_plus ; [apply C_infty_const |] | apply C_comp ;
  [apply C_infty_exp |]] ; apply derivable_pt_continuity_Riemann_implies_C1 ; reg ;
  apply RiemannInt_continuity ; assumption.

 exists (((fct_cte V0) + (fun t => RiemannInt (Hsol t0 t0 t))) *
  (comp exp (fun t => RiemannInt (Ha t0 t))))%F ; exists (C_implies_D _ _ pr).

 intros t ; simpl ; split.
 assert (Hpr1 : derivable_pt (fun t => RiemannInt (Hsol t0 t0 t)) t)
   by (apply RiemannInt_derivable_pt ; reg ; apply RiemannInt_continuity ;
   assumption).
 assert (Hpr2 : derivable_pt (fun t => RiemannInt (Ha t0 t)) t)
   by (apply RiemannInt_derivable_pt ; auto).

 unfold derive ; rewrite (pr_nu_var _ (((fct_cte V0) +
  (fun t => RiemannInt (Hsol t0 t0 t))) * (comp exp (fun t => RiemannInt (Ha t0 t))))%F _ _
  (derivable_pt_mult _ _ _ (derivable_pt_plus _ _ _ (derivable_pt_const V0 t) Hpr1)
  (derivable_pt_comp _ _ _ Hpr2 (derivable_pt_exp _)))).

 rewrite derive_pt_mult, derive_pt_comp, derive_pt_exp, derive_pt_RiemannInt_1,
 derive_pt_plus, derive_pt_const ; unfold plus_fct, comp, fct_cte, mult_fct ; simpl.
 rewrite derive_pt_RiemannInt_1.
 ring_simplify ; unfold opp_fct ; rewrite exp_Ropp ; field.
 apply Rgt_not_eq ; apply exp_pos.
 apply Hcontsol.
 apply Hconta.
 reflexivity.
 unfold comp, plus_fct, mult_fct, fct_cte ; do 2 rewrite RiemannInt_singleton ;
 rewrite exp_0 ; ring.
Qed.

End Trivial.


Require Import ZArith Bool.
From Equations Require Import Equations.
Set Equations With UIP.

Variant wsize :=
  | U8
  | U16
  | U32
  | U64
  | U128
  | U256.

Definition wsize_size (s : wsize) : nat :=
  match s with
  | U8 => 8
  | U16 => 16
  | U32 => 32
  | U64 => 64
  | U128 => 128
  | U256 => 256
  end.

Definition modulus nbits := two_power_nat nbits.

Section test.

Variable (nbits : wsize).

Record word := mkWord {
  w : Z;
  _ : (0 <=? w)%Z && (w <? modulus (wsize_size nbits))%Z = true
}.

Equations Derive NoConfusion EqDec for positive.
Equations Derive NoConfusion EqDec for Z.
Equations Derive NoConfusion EqDec for word.

Check word_eqdec.

End test.

Check word_eqdec.

Variant value : Type :=
| Vbool : bool -> value
| Vint : Z -> value
| Vword : forall s, word s -> value.

(* Derive NoConfusionHom seems much slower, so we use Derive NoConfusion *)
(* Time Equations Derive NoConfusionHom for t. *)

Equations Derive NoConfusion EqDec for bool.
Succeed Equations Derive NoConfusion EqDec for value.
(* 1 obligation remaining *)


Definition plus_assoc := forall n m o : nat, n + m + o = n + (m + o).


From Coq Require Import List.
From Coq Require HexString.
From Coq Require Import String.
From Coq Require Import NArith ZArith Lia.
From Coq Require Import Int63.

From EVM Require UInt64 Tuplevector Vec8 Vec16.
From EVM Require Import Nibble.

(** This is a clean room implementation of the F function of BLAKE2b.
     https://github.com/ethereum/EIPs/blob/master/EIPS/eip-152.md
     https://tools.ietf.org/html/rfc7693 *)

Local Open Scope string_scope.

Definition iv_hex: Vec8.t string
:= Vec8.Vec8 "0x6a09e667f3bcc908"
             "0xbb67ae8584caa73b"
             "0x3c6ef372fe94f82b"
             "0xa54ff53a5f1d36f1"
             "0x510e527fade682d1"
             "0x9b05688c2b3e6c1f"
             "0x1f83d9abfb41bd6b"
             "0x5be0cd19137e2179".
Definition iv := Vec8.map UInt64.uint64_of_Z_mod (Vec8.map HexString.to_Z iv_hex).
Lemma iv_ok:
  Vec8.map UInt64.Z_of_uint64 iv = Vec8.map HexString.to_Z iv_hex.
Proof. trivial. Qed.

(* 3.1.  Mixing Function G *)
Local Notation "x ^ y"  := (UInt64.bitwise_xor x y).
Section MixingFunctionG.

Local Notation "x << y" := (UInt64.shl_uint63 x y).
Local Notation "x >> y" := (UInt64.shr_uint63 x y).
Local Notation "x | y"  := (UInt64.bitwise_or x y)  (at level 30). (* dangerous! messes up match! *)
Local Notation "x & y"  := (UInt64.bitwise_and x y) (at level 30).
Local Notation "x + y"  := (UInt64.add x y).
Local Notation "~ x"  := (UInt64.bitwise_not x).
Definition rot x k := ((x >> k) | (x << (64 - k)%int63)).
Local Notation "x >>> y" := (rot x y) (at level 30).

(** 2.1 Parameters. *)

(** G rotation *)
Definition R1 := 32%int63.
Definition R2 := 24%int63.
Definition R3 := 16%int63.
Definition R4 := 63%int63.

Definition G (v: Vec16.t UInt64.t) (a b c d: Int63.int) (x y: UInt64.t)
: Vec16.t UInt64.t
:= let ua := (Vec16.get_by_int v a) + (Vec16.get_by_int v b) + x in
   let ud := ((Vec16.get_by_int v d) ^ ua) >>> R1 in
   let uc := (Vec16.get_by_int v c) + ud in
   let ub := ((Vec16.get_by_int v b) ^ uc) >>> R2 in
   let wa := ua + ub + y in
   let wd := (ud ^ wa) >>> R3 in
   let wc := uc + wd in
   let wb := (ub ^ wc) >>> R4 in
   let va := Vec16.set_by_int v a wa in
   let vb := Vec16.set_by_int va b wb in
   let vc := Vec16.set_by_int vb c wc in
             Vec16.set_by_int vc d wd.

End MixingFunctionG.

Definition f_round (v m: Vec16.t UInt64.t) (s: Vec16.t Int63.int)
: Vec16.t UInt64.t
:= let ms i := Vec16.get_by_int m (Vec16.get_by_int s i) in
   (let v1 := G v  0 4  8 12 (ms  0) (ms  1) in
    let v2 := G v1 1 5  9 13 (ms  2) (ms  3) in
    let v3 := G v2 2 6 10 14 (ms  4) (ms  5) in
    let v4 := G v3 3 7 11 15 (ms  6) (ms  7) in
    let v5 := G v4 0 5 10 15 (ms  8) (ms  9) in
    let v6 := G v5 1 6 11 12 (ms 10) (ms 11) in
    let v7 := G v6 2 7  8 13 (ms 12) (ms 13) in
              G v7 3 4  9 14 (ms 14) (ms 15))%int63.

Definition sigma
: Vec16.t (Vec16.t Int63.int)
:= (let z := Vec16.fill 0 in
    Vec16.Vec16 (Vec16.Vec16  0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15)
                (Vec16.Vec16 14 10  4  8  9 15 13  6  1 12  0  2 11  7  5  3)
                (Vec16.Vec16 11  8 12  0  5  2 15 13 10 14  3  6  7  1  9  4)
                (Vec16.Vec16  7  9  3  1 13 12 11 14  2  6  5 10  4  0 15  8)
                (Vec16.Vec16  9  0  5  7  2  4 10 15 14  1 11 12  6  8  3 13)
                (Vec16.Vec16  2 12  6 10  0 11  8  3  4 13  7  5 15 14  1  9)
                (Vec16.Vec16 12  5  1 15 14 13  4 10  0  7  6  3  9  2  8 11)
                (Vec16.Vec16 13 11  7 14 12  1  3  9  5  0 15  4  8  6  2 10)
                (Vec16.Vec16  6 15 14  9 11  3  0  8 12  2 13  7  1  4 10  5)
                (Vec16.Vec16 10  2  8  4  7  6  1  5 15 11  9 14  3 12 13  0)
                z z z z z z)%int63.

Fixpoint do_f_rounds_rec (v m: Vec16.t UInt64.t) (rounds_left: nat) (round_digit: Int63.int)
{struct rounds_left}
: Vec16.t UInt64.t
:= match rounds_left with
   | O => v
   | S k => do_f_rounds_rec (f_round v m (Vec16.get_by_int sigma round_digit))
                            m
                            k
                            (if round_digit < 9
                               then round_digit + 1
                               else 0)%int63
   end.

Definition do_f_rounds (v m: Vec16.t UInt64.t) (rounds: Z)
:= do_f_rounds_rec v m (Z.to_nat rounds) 0%int63.

Definition F (h: Vec8.t UInt64.t) (m: Vec16.t UInt64.t)
              (c0 c1: UInt64.t) (final: bool) (rounds: UInt64.t)
: Vec8.t UInt64.t
:= let 'Vec8.Vec8 v0 v1 v2 v3 v4 v5 v6 v7 := h in
   let 'Vec8.Vec8 v8 v9 va vb Xc Xd Xe vf := iv in
   let vc := UInt64.bitwise_xor Xc c0 in
   let vd := UInt64.bitwise_xor Xd c1 in
   let ve := if final then UInt64.bitwise_not Xe else Xe in
   let v := Vec16.Vec16 v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 va vb vc vd ve vf in
   let u := do_f_rounds v m (UInt64.Z_of_uint64 rounds) in
   let 'Vec16.Vec16 u0 u1 u2 u3 u4 u5 u6 u7 u8 u9 ua ub uc ud ue uf := u in
   Vec8.Vec8 (v0 ^ u0 ^ u8)
             (v1 ^ u1 ^ u9)
             (v2 ^ u2 ^ ua)
             (v3 ^ u3 ^ ub)
             (v4 ^ u4 ^ uc)
             (v5 ^ u5 ^ ud)
             (v6 ^ u6 ^ ue)
             (v7 ^ u7 ^ uf).


(**************************************************************************
* TLC: A library for Coq                                                  *
* Proof of the axioms of choice                                           *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibEpsilon LibRelation.
Generalizable Variables A B.

(** This files includes several versions of the axiom of choice.
    This "axiom" is actually proved in terms of indefinite description.
    Remark: the choice results contained in this file are not very
    useful in practice since it is usually more convenient to use
    the epsilon operator directly. *)

(* ********************************************************************** *)
(** * Functional choice *)

(* ---------------------------------------------------------------------- *)
(** ** Functional choice *)

(** This result can be used to build a function from a relation that maps
    every input to at least one output. *)

Lemma functional_choice : forall A B (R:A->B->Prop),
  (forall x, exists y, R x y) ->
  (exists f, forall x, R x (f x)).
Proof using.
  intros. exists (fun x => sig_val (indefinite_description (H x))).
  intro x. apply (sig_proof (indefinite_description (H x))).
Qed.
(* --LATER: the premise is called [defined] in LibRelation *)
(* --LATER: functionality -> definedness? *)

(* ---------------------------------------------------------------------- *)
(** ** Dependent functional choice *)

(** It is a generalization of functional choice to dependent functions. *)

Scheme and_indd := Induction for and Sort Prop.
Scheme eq_indd := Induction for eq Sort Prop.

Lemma dependent_functional_choice :
  forall A (B:A->Type) (R:forall x, B x -> Prop),
  (forall x, exists y, R x y) ->
  (exists f, forall x, R x (f x)).
Proof using.
  introv H.
  pose (B' := { x:A & B x }).
  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
  destruct (functional_choice R') as (f,Hf).
    intros x. destruct (H x) as (y,Hy).
     exists (existT (fun x => B x) x y). split~.
  sets proj1_transparent: (fun P Q (p:P/\Q) => let (a,b) := p in a).
  exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_transparent _ _ (Hf x))).
  intros x. destruct (Hf x) as (Heq,HR) using and_indd.
  destruct (f x). simpls. destruct Heq using eq_indd. apply HR.
Qed.

Arguments dependent_functional_choice [A] [B].

(* ---------------------------------------------------------------------- *)
(** ** Guarded functional choice *)

(** Similar to functional choice, except that it targets partial functions *)

Lemma guarded_functional_choice : forall A `{Inhab B} (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists y, R x y) ->
  (exists f, forall x, P x -> R x (f x)).
Proof using.
  intros. apply (functional_choice (fun x y => P x -> R x y)).
  intros. applys* indep_general_premises.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Omniscient functional choice *)

(** Similar to functional choice except that the proof of functionality
    of the relation is given after the fact, for each argument. *)

Lemma omniscient_functional_choice : forall A `{Inhab B} (R : A->B->Prop),
  exists f, forall x, (exists y, R x y) -> R x (f x).
Proof using. intros. apply~ guarded_functional_choice. Qed.

(* ********************************************************************** *)
(** * Functional unique choice *)

(** This section provides a similar set of results excepts that it is
    specialized for the case where each argument has a unique image. *)

(* ---------------------------------------------------------------------- *)
(** ** Functional unique choice *)

Lemma functional_unique_choice : forall A B (R:A->B->Prop),
  (forall x , exists! y, R x y) ->
  (exists! f, forall x, R x (f x)).
Proof using.
  intros. destruct (functional_choice R) as [f Hf].
  intros. apply (ex_of_ex_unique (H x)).
  exists f. split. auto.
   intros g Hg. apply fun_ext_1. intros y.
   apply~ (at_most_one_of_ex_unique (H y)).
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Dependent functional unique choice *)

Theorem dependent_functional_unique_choice :
  forall (A:Type) (B:A->Type) (R:forall (x:A), B x -> Prop),
  (forall (x:A), exists! y : B x, R x y) ->
  (exists! f : (forall (x:A), B x), forall (x:A), R x (f x)).
Proof using.
  intros. destruct (dependent_functional_choice R) as [f Hf].
  intros. apply (ex_of_ex_unique (H x)).
  exists f. split. auto.
   intros g Hg. extens. intros y.
   apply~ (at_most_one_of_ex_unique (H y)).
 Qed.

Arguments dependent_functional_unique_choice [A] [B].

(* ---------------------------------------------------------------------- *)
(** ** Guarded functional unique choice *)

Lemma guarded_functional_unique_choice :
  forall A `{Inhab B} (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists! y, R x y) ->
  (exists f, forall x, P x -> R x (f x)).
Proof using.
  introv I M. apply (functional_choice (fun x y => P x -> R x y)).
  intros. apply* indep_general_premises.
  introv H. destruct* (M _ H) as (y&Hy&_).
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Omniscient functional unique choice *)

Lemma omniscient_functional_unique_choice :
  forall A `{Inhab B} (R : A->B->Prop),
  exists f, forall x, (exists! y, R x y) -> R x (f x).
Proof using.
  intros. destruct (omniscient_functional_choice R) as [f F].
  exists f. introv (y&Hy&Uy). autos*.
Qed.

(* ********************************************************************** *)
(** * Relational choice *)

(** Relational choice can be used to extract from a relation a subrelation
    that describes a function, by mapping every argument to a unique image. *)

(* ---------------------------------------------------------------------- *)
(** ** Relational choice *)

Lemma rel_choice : forall A B (R:A->B->Prop),
  (forall x, exists y, R x y) ->
  (exists R', rel_incl R' R
           /\ forall x, exists! y, R' x y).
Proof using.
  introv H. destruct~ (functional_choice R) as [f Hf].
  exists (fun x y => f x = y). split.
    introv E. simpls. subst~.
    intros x. exists~ (f x).
Qed.

(* --TODO: Dependent relational choice, is it meaningful?, useful? *)

(* ---------------------------------------------------------------------- *)
(** ** Guarded relational choice *)

Lemma guarded_rel_choice : forall A B (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists y, R x y) ->
  (exists R', rel_incl R' R
           /\ forall x, P x -> exists! y, R' x y).
Proof using.
  intros. destruct (rel_choice (fun (x:sig P) (y:B) => R (sig_val x) y))
   as (R',(HR'R,M)).
    intros (x,HPx). destruct (H _ HPx) as (y,HRxy). exists~ y.
  set (R'' := fun (x:A) (y:B) => exists (H : P x), R' (exist P x H) y).
  exists R''. split.
    intros x y (HPx,HR'xy). apply (HR'R _ _ HR'xy).
    intros x HPx. destruct (M (exist P x HPx)) as (y,(HR'xy,Uniq)).
     exists y. split.
       exists~ HPx.
       intros y' (H'Px,HR'xy'). apply Uniq.
        rewrite~ (proof_irrelevance HPx H'Px).
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Omniscient relation choice *)

Lemma omniscient_rel_choice : forall A B (R : A->B->Prop),
  exists R', rel_incl R' R
          /\ forall x, (exists y, R x y) -> (exists! y, R' x y).
Proof using. intros. apply~ guarded_rel_choice. Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrnat.

Goal forall m n p, n <= p -> m <= n -> m <= p.
by move=> m n p le_n_p /leq_trans; apply.
Undo 1.
by move=> m n p le_n_p /leq_trans /(_ le_n_p) le_m_p; exact: le_m_p.
Undo 1.
by move=> m n p le_n_p /leq_trans ->.
Qed.

Goal forall P Q X : Prop, Q -> (True -> X -> Q = P) -> X -> P.
by move=> P Q X q V /V <-.
Qed.

Lemma test0: forall a b, a && a && b -> b.
by move=> a b; repeat move=> /andP []; move=> *.
Qed.

Lemma test1 : forall a b, a && b -> b.
by move=> a b /andP /andP /andP [] //.
Qed.

Lemma test2 : forall a b, a && b -> b.
by move=> a b /andP /andP /(@andP a) [] //.
Qed.

Lemma test3 : forall a b, a && (b && b) -> b.
by move=> a b /andP [_ /andP [_ //]].
Qed.

Lemma test4:  forall a b, a && b = b && a.
by move=> a b; apply/andP/andP=> ?; apply/andP/andP/andP; rewrite andbC; apply/andP.
Qed.

Lemma test5:  forall C I A O, (True -> O) -> (O -> A) -> (True -> A -> I) -> (I -> C) -> C.
by move=> c i a o O A I C; apply/C/I/A/O.
Qed.

Lemma test6:  forall A B, (A -> B) -> A -> B.
move=> A B A_to_B a; move/A_to_B in a; exact: a.
Qed.

Lemma test7:  forall A B, (A -> B) -> A -> B.
move=> A B A_to_B a; apply A_to_B in a; exact: a.
Qed.


From mathcomp Require Import all_ssreflect.
From GraphTheory Require Import edone preliminaries digraph sgraph.
From GraphTheory Require Import connectivity minor treewidth arc set_tac.

(* TOTHINK : arc is only included for the [path0] definition *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Canonical edge_app_pred (G : diGraph) (x : G) := ApplicativePred (edge_rel x).
Canonical sedge_app_pred (G : sgraph) (x : G) := ApplicativePred (sedge x).

(** If [S] is a smallest separator, then every (maximal) component of G-S
    can be seen as one part of a proper separation *)
Lemma component_separation (G : sgraph) (A S : {set G}) x :
  smallest vseparator S ->
  x \in A -> [disjoint A & S] -> connected A -> {in A & ~: A, forall x y, x--y -> y \in S} ->
  proper_separation (A :|: S) (~: A :|: S).
Proof.
move=> [sepS minS] x_A dis_A_S conA compA.
case: sepS => [u[v sep_uv]].
have Huv : (u \notin A) || (v \notin A).
{ apply: contraTT (dis_A_S); rewrite negb_or !negbK => /andP [u_A v_A].
  have uDv := separatesNeq sep_uv.
  have/(connect_irredRP uDv) [p Ip /subsetP subA] := conA _ _ u_A v_A.
  case: sep_uv => uNS vNS /(_ p) [z /subA ? ?]. by apply/pred0Pn; exists z. }
wlog uNA : u v sep_uv {Huv} / u \notin A => [W|].
{ case/orP: Huv; apply: W;[|rewrite separates_sym]; exact: sep_uv. }
case: (sep_uv) => uNS vNS sepS.
split; first split.
- by move => z; rewrite !inE; case: (z \in A).
- move => x1 x2. rewrite !inE !negb_or !negbK => /andP [x1_A x1NS] /andP [x2_A].
  by apply: contraNF => /compA; apply; rewrite ?inE.
- by exists x,u; rewrite !inE x_A (disjointFr dis_A_S) //= negb_or uNA uNS.
Qed.

(** * Merging Vertices  *)

(** The definition of [smerge2 G x y] is simply to remove [y] and
attach all edges of [y] to [x], regardless of whether [x -- y] holds
or not. We use both variants. Edge-constraction drives the main
argument for the 3-connected case of Wagner's theorem. On the other
hand, vertex merging is used extensively when extending the result
from 3-connected graphs to general graphs *)

Section SMerge2.
Variables (G : sgraph) (x y : G).

Definition smerge2_vertex := { z : G | z != y }.
Definition smerge2_rel :=
  [rel u v : smerge2_vertex |
   if (val u == x) && (val v != x) then val v -- x || val v -- y else
   if (val v == x) && (val u != x) then val u -- x || val u -- y else
   val u -- val v].

Lemma smerge2_irrefl : irreflexive smerge2_rel.
Proof. by move => u /=; case: (sval u == x); rewrite /= ?andbF ?sgP. Qed.

Lemma smerge2_sym : symmetric smerge2_rel.
Proof.
move => u v /=; (case: (altP (sval u =P x)); case: (altP (sval v =P x)) => //=) => [-> -> //|].
by rewrite sgP.
Qed.

Definition smerge2 := SGraph smerge2_sym smerge2_irrefl.

Lemma smerge2_edge (u v : smerge2) : val u -- val v -> u -- v.
Proof.
move=> val_uv; rewrite /edge_rel/=.
case: (boolP (_ && _)) => [/andP[/eqP<- _]|_]; first by rewrite sgP val_uv.
case: (boolP (_ && _)) => [/andP[/eqP<- _]|_]; by rewrite val_uv.
Qed.

Lemma smerge2_minor : x -- y -> minor G smerge2.
Proof.
move => xy.
pose phi (z : smerge2) : {set G} := if val z == x then [set x;y] else [set val z].
suff: minor_rmap phi by apply: minor_of_rmap.
split.
- move => z; rewrite /phi; case: ifP => _; solve [exact: set10|exact: setU1_neq].
- move => z; rewrite /phi; case: ifP => _; solve [exact: connected1|exact: connected2].
- move => z1 z2 z1Dz2; rewrite /phi.
  case: (eqVneq x (val z1)) => [->|xDz1].
  + rewrite eq_sym val_eqE (negbTE z1Dz2) disjoint_sym disjoints1 !inE negb_or.
    by rewrite eq_sym val_eqE (negbTE z1Dz2) (valP z2).
  + case: (eqVneq x (val z2)) => [->|xDz2]; rewrite disjoints1 !inE ?negb_or ?val_eqE //.
    by rewrite z1Dz2 (valP z1).
- have H z u v : sval u = x -> sval v != x -> sval v -- z -> z \in [set x; y] -> neighbor (phi u) (phi v).
  { move => eq_u eq_v v_z Hz. apply/neighborP; exists z; exists (sval v).
    by rewrite /phi [val u]eq_u eqxx (negbTE eq_v) sgP v_z Hz inE eqxx. }
  move => u v. rewrite /edge_rel/=.
  case: (altP (sval u =P x)); case: (altP (sval v =P x)) => //=.
  + move => -> ->. by rewrite sgP.
  + move => eq_v eq_u. by case/orP => ?; [apply: (H x)|apply: (H y)]; rewrite //= !inE !eqxx.
  + move => eq_v eq_u. rewrite neighborC.
    by case/orP => ?; [apply: (H x)|apply: (H y)]; rewrite //= !inE !eqxx.
  + move => eq_v eq_u u_v. apply/neighborP; exists (val u); exists (val v).
    by rewrite /phi /= (negbTE eq_v) (negbTE eq_u) 2!sgP !inE !eqxx u_v.
Qed.

End SMerge2.
Arguments smerge2 : clear implicits.

Lemma card_smerge2 (G : sgraph) (x y : G) :
  #|smerge2 G x y|.+1 = #|G|.
Proof.
rewrite card_sig [RHS](cardD1 y) add1n; congr (_.+1).
by apply: eq_card => z; rewrite !inE.
Qed.

Lemma smerge2_val_edge (G : sgraph) (x y : G) (u v : smerge2 G x y) :
  val u != x -> val v != x -> val u -- val v = u -- v.
Proof.
move: u v => [u uDy] [v vDy] /= uDx vDx.
by rewrite [RHS]/edge_rel/= (negbTE uDx) (negbTE vDx).
Qed.

(* not used, but it probably should by *)
Lemma smerge2_neighbor (G : sgraph) (x y : G) (xDy : x != y) :
  val @: N(Sub x xDy : smerge2 G x y) = (N(x) :|: N(y)) :\: [set x;y].
Proof.
apply/setP => z; rewrite !inE; apply/imsetP/andP => [[z0 Hz0 ->]|[]].
  move: Hz0. rewrite !inE negb_or (valP z0) /edge_rel/= eqxx andbF /=.
  case: (eqVneq (sval z0) x) => /= [<-|]; by rewrite ?sg_irrefl ?[sval _ -- _]sg_sym.
rewrite negb_or => /andP [zDx zDy]; exists (Sub z zDy) => //.
by rewrite inE /edge_rel/= eqxx andbF /= ![z -- _]sg_sym zDx.
Qed.

Lemma smerge2_path0 (G : sgraph) (x y : G) (s : seq (smerge2 G x y)) :
  let s0 := [seq val x | x <- s] in path0 (--) s -> x \notin s0 -> path0 (--) s0.
Proof.
hnf; case: s => // u s; elim: s u => // v s /= IHs u /= /andP[uv pth_s].
rewrite !inE !negb_or => /and3P[xDu xDv xNs].
by rewrite smerge2_val_edge ?[_ == x]eq_sym // uv /= IHs // inE (negPf xDv).
Qed.

Lemma smerge2_ucycle (G : sgraph) (x y : G) (s : seq (smerge2 G x y)) :
  let s0 := [seq val x | x <- s] in
  ucycle (--) s -> x \notin s0 -> ucycle (--) s0.
Proof.
hnf; case: s => // z s; rewrite /ucycle/cycle/= => /and3P[pth_s zNs uniq_s xNs].
rewrite map_inj_uniq ?uniq_s ?andbT; last exact: val_inj.
rewrite mem_map // zNs andbT -map_rcons.
apply: (@smerge2_path0 G x y (z::rcons s z)) => //=.
by move: xNs; rewrite !inE map_rcons mem_rcons inE !negb_or andbA andbb.
Qed.

Lemma smerge2edgeD (G : sgraph) (x y : G) (u v : smerge2 G x y) :
  ~~ x -- y ->
  u -- v = [|| val u -- val v, (val u == x) && val v -- y | (val v == x) && val u -- y].
Proof.
move => n_xy; rewrite [LHS]/edge_rel/= -![sval _]/(val _).
case: (eqVneq (val u) x) => [->|uDx]; case: (eqVneq (val v) x) => [->|vDx] //=.
- by rewrite sg_irrefl (negbTE n_xy).
- by rewrite orbF ![_ -- val _]sgP.
Qed.

Lemma smerge2edgeL (G : sgraph) (x y : G) (u v : smerge2 G x y) :
  ~~ x -- y -> val u == x -> val v -- y -> u -- v.
Proof.
move=> xNy uEx vy. rewrite /edge_rel/= -![sval _]/(val _) uEx andbF /= vy orbT.
case: (eqVneq (val v) x) => // E. by rewrite -E vy in xNy.
Qed.

(** wlog reasoning for edges of [smerge2 G x y] when the conclusion is symmetric *)
Lemma smerge2Ecase (G : sgraph) (x y : G) (G' := smerge2 G x y) (P : G' -> G' -> Prop) :
  ~~ x -- y -> (forall u v, P u v <-> P v u) ->
  (forall u v, val u -- val v -> P u v) -> (forall u v, (val u == x) && val v -- y -> P u v) ->
  forall u v, u -- v -> P u v.
Proof.
move=> xNy Psym P1 P2 u v. rewrite smerge2edgeD //; case/or3P => //. exact: P1. exact: P2.
rewrite Psym. exact: P2.
Qed.

Lemma smerge2_separator (G : sgraph) (x y : G) (S : {set smerge2 G x y}) :
  vseparator S -> vseparator (y |: val @: S).
Proof.
move => [u[v [uNS vNS sep_uv]]].
exists (val u),(val v); split => [||p].
- rewrite !inE (negbTE (valP u)) /= mem_imset //; exact: val_inj.
- rewrite !inE (negbTE (valP v)) /= mem_imset //; exact: val_inj.
- have [|yNp] := boolP (y \in p); first by exists y => //; rewrite !inE eqxx.
  have [|//||q eq_q _] := lift_Path (p' := p).
  + exact: smerge2_edge.
  + move => z z_p. have zDy : z != y by apply: contraTneq z_p => ->.
    by apply/mapP; exists (Sub z zDy) => //; rewrite mem_enum.
  + have [z z_q z_S] := sep_uv q; exists (val z); last by rewrite !inE mem_imset ?z_S.
    by rewrite mem_path -eq_q mem_map.
Qed.

Lemma smerge_konnected k (G : sgraph) (x y : G) :
  x -- y -> k.+1.-connected G -> k.-connected (smerge2 G x y).
Proof.
move=> xy [lG vsG]; split => [|S sepS]; first by rewrite -ltnS card_smerge2.
have/vsG := smerge2_separator sepS.
rewrite cardsU1 card_imset // [_ \notin _](_ : _ = true) //.
by apply: contraTN isT => /imsetP -[[z zDy _ /= E]]; rewrite -E eqxx in zDy.
Qed.

(** ** Edge Contraction in 3-connected graphs *)

(** Any separator of [smerge2 G x y] that does not contain [x] can be
lifted to a separator in of [G] *)
Lemma separator_from_smerge2 (G : sgraph) (x y : G) (xDy : x != y)
  (x' := Sub x xDy) (S : {set smerge2 G x y}) :
  vseparator S -> x' \notin S -> vseparator (val @: S).
Proof.
move=> /vseparator_separation [V1 [V2 [psepV def_S]]] xNS.
wlog x_V1 : V1 V2 psepV def_S / x' \notin V2 => [W|].
{ case: (boolP (x' \in V2)) => [x_V2|]; last exact: (W V1 V2).
  apply: (W V2 V1); rewrite 1?proper_separation_symmetry 1?setIC //.
  case: psepV => sepV _. apply: contraNN xNS => x_V1. by rewrite def_S inE x_V1 x_V2. }
suff: proper_separation (y |: val @: V1) (val @: V2).
{ move/proper_vseparator.
  suff -> : (y |: val @: V1) :&: (val @: V2) = val @: S by [].
  apply/setP => u; rewrite def_S inE imsetI ?inE; last exact: (in2W val_inj).
  rewrite (@andb_id2r _ _ (u \in val @: V1)) // => /imsetP [u0 _ ->].
  by rewrite (negbTE (valP u0)). }
split; first split.
- move => u. case: (eqVneq u y) => [->|uDy]; rewrite !inE ?eqxx ?(negbTE uDy) //=.
  case: psepV => sepV _. have := sepV.1 (Sub u uDy).
  by rewrite Sub_imset imsetU inE.
- move => u v; rewrite !inE negb_or => u_V1 /andP [vDy v_V2].
  case: psepV => sepV _.
  have v'_V2 : (Sub v vDy) \notin V1.
  { by apply: contraNN v_V2 => H; apply/imsetP; exists (Sub v vDy). }
  have vDx : v != x.
  { apply: contraNneq x_V1 => ?; subst v. apply: sep_inR sepV _.
    by rewrite /x' (bool_irrelevance xDy vDy). }
  case: (eqVneq u y) => [?|uDy]; first subst u.
  + apply: contraFF (sepV.2 _ _ x_V1 v'_V2) => yv.
    by rewrite /edge_rel/= eqxx vDx [v -- y]sgP yv orbT.
  + have u'_V1 : (Sub u uDy) \notin V2.
  { by apply: contraNN u_V1 => H; apply/imsetP; exists (Sub u uDy). }
    apply: contraFF (sepV.2 _ _ u'_V1 v'_V2) => uv.
  rewrite /edge_rel/=. rewrite (negbTE vDx) /= andbT.
  by case: (eqVneq u x) => [<-|//]; rewrite [v -- u]sgP uv.
- case: psepV => _ [u [v [u_V1 v_V2]]].
  exists (val u),(val v). by rewrite !(inE,mem_imset) // negb_or (valP v).
Qed.

Lemma edge_separator (G : sgraph) (x y : G) :
  4 < #|G| -> 3.-connected G -> x -- y -> ~ 3.-connected (smerge2 G x y) ->
  exists z, vseparatorb [set x;y;z].
Proof.
move => largeG conn3G xy nconn3Gxy.
have conn2Gxy : 2.-connected (smerge2 G x y) by apply: smerge_konnected.
have [|S /cards2P [z[w [zDw ->] [sep_zw small_zw]]]] :=
  kconnected_bounds _ conn2Gxy nconn3Gxy; first by rewrite -ltnS card_smerge2.
have xDy : x != y by rewrite sg_edgeNeq.
pose x' : smerge2 G x y := Sub x xDy.
have x_in : x' \in [set z; w].
{ apply: contraPT conn3G => Hx [_ min3].
  have /min3 := separator_from_smerge2 sep_zw Hx.
  by rewrite card_imset // cards2; case: (_ == _). }
wlog have: z w zDw sep_zw {x_in small_zw} / w = x' => [W|]; last subst w.
{ case/set2P : x_in => /esym; last exact: W sep_zw.
  rewrite eq_sym setUC in sep_zw zDw. exact: W sep_zw. }
exists (val z); apply/vseparatorP.
have := smerge2_separator sep_zw.
by rewrite imsetU !imset_set1 /= [[set _;x]]setUC setUA [[set _;x]]setUC.
Qed.

(* This could be an alterative to the direct argument in
[contract_three_connected]
Lemma component_two_connected (G : sgraph) (x y a : G) (A : {set G}) (S := [set x; y]) :
  2.-connected G -> vseparator S ->
  a \in A -> [disjoint A & S] -> connected A -> {in A & ~: A, forall x y, x--y -> y \in S} ->
  forall w, connected ((S :|: A) :\ w). *)

(** The following proposition drives the inductive proof of Wagner's
Theorem, as it allows maintainig 3-connectedness thoughout the
induction. *)
Proposition contract_three_connected (G : sgraph) :
  5 <= #|G| ->
  3.-connected G -> exists x y, x -- y /\ 3.-connected (smerge2 G x y).
Proof.
move=> le5G connG.
suff : ~ forall x y, x -- y -> ~ 3.-connected (smerge2 G x y).
{ move => A. (* TODO: simplify? *)
  setoid_rewrite (rwP (kconnectedP _ _)).
  setoid_rewrite (rwP andP).
  do 2 setoid_rewrite (rwP existsP).
  apply: contra_notT A => C x y xy.
  apply: contraNnot C => H. apply/existsP;exists x; apply/exists_inP;exists y => //.
  exact/kconnectedP. }
move => not3xy.
pose cmp3 (x y z : G) F :=
  [/\ x -- y, vseparator [set x;y;z], connected F & [disjoint F & [set x;y;z]]].
have [x [y [z [F [[xy sepF connF disjF] max_xyF]]]]] : exists (x y z : G) (F : {set G}),
    cmp3 x y z F /\ forall x' y' z' F', cmp3 x' y' z' F' -> #|F'| <= #|F|.
{ pose p := [pred xyz : G * G * G | let: ((x,y),z) := xyz in
            x -- y && vseparatorb [set x;y;z]].
  have [xyz0 p_xyz0] : exists xyz , p xyz.
  { have [x[y xy]] := kconnected_edge connG.
    have [z Hz] := edge_separator le5G connG xy (not3xy _ _ xy).
    by exists ((x,y),z); rewrite /= xy /= Hz. }
  pose p' (xyz : G * G * G) :=
    [pred A | let: ((x,y),z) := xyz in connectedb A && [disjoint A & [set x;y; z]]].
  pose mcmp (xyz : G * G * G) : nat := \max_(A | p' xyz A) #|A|.
  pose xyz := arg_max xyz0 p mcmp.
  have inh_p' (xyz' : G * G * G) : p' xyz' set0.
  { case: xyz' => -[x y] z /=; rewrite disjoints0 ?andbT.
    exact/connectedP/connected0. }
  pose F : {set G} := arg_max set0 (p' xyz) (fun x => #|x|).
  pose x := xyz.1.1; pose y := xyz.1.2; pose z := xyz.2.
  exists x, y,z, F. revert xyz F x y z.
  case: arg_maxnP => // -[[x y] z] /= /andP [P1 P2] max_xyz.
  case: arg_maxnP => // F /= /andP [/connectedP connF disF] maxF.
  split; first by split => //; exact/vseparatorP.
  move => x' y' z' F' [F1 /vseparatorP F2 /connectedP F3 F4].
  have:= max_xyz (x',y',z'); rewrite F1 F2 => /(_ isT) le_mcp.
  apply: (@leq_trans (mcmp (x,y,z))).
  - apply: leq_trans le_mcp. by apply: leq_bigmax_cond => /=; rewrite F3.
  - by apply/bigmax_leqP => A; apply: maxF. }
have [_ min3sep] := connG.
pose H := [set x; y] :|: F.
have min_xyz : smallest vseparator [set x;y;z].
{ split => // V /min3sep. apply: leq_trans. exact: cards3. }
move defXYZ : [set x;y;z] => XYZ.
have /set0Pn[f f_F] : F != set0.
{ apply: contraTneq le5G => eqF0; rewrite -leqNgt.
  suff /subset_leq_card S : G \subset [set x;y;z].
    by apply: leq_trans S _; rewrite leqW // cards3.
  apply: wlog_neg => /subsetPn [u _ Hu].
  have:= max_xyF x y z [set u]; rewrite cards1 eqF0 cards0 ltnn.
  case/(_ _)/Wrap => //; split; rewrite ?disjoints1 //. exact: connected1. }
have compF : {in F & ~: F, forall u v, u -- v -> v \in XYZ}.
{ move=> u v u_F; rewrite !inE -defXYZ => vNF uv. apply/negPn/negP => vXYZ.
  suff/max_xyF : cmp3 x y z (v |: F).
    by rewrite leqNgt cardsU1 vNF add1n leqnn.
  split => //; last by rewrite disjointsU // disjoints1.
  rewrite setUC; apply: connectedU_edge uv _ _  => //; last exact: connected1.
  by rewrite !inE eqxx. }
have psepH : proper_separation (F :|: XYZ) (~: F :|: XYZ).
{ rewrite defXYZ in min_xyz disjF.
  exact: component_separation min_xyz f_F disjF connF compF. }
have [u zu uNH] : exists2 u, z -- u & u \notin H.
{ rewrite defXYZ in min_xyz.
  have := @svseparator_neighbours _ _ _ z psepH.
  rewrite setUUC -{2}defXYZ !inE eqxx; case => // u [v] [_ Hz _ zv].
  exists v => //. apply: contraNN Hz => {zv}. apply/subsetP : v.
  by rewrite /H setUC setUS // -defXYZ subsetUl. }
have/andP [xDz yDz] : (x != z) && (y != z).
{ move/min3sep : sepF. rewrite -setUA !cardsU1 cards1 !inE (sg_edgeNeq xy) /=.
  by do 2 case: (_ == _). }
have zNF : z \in F = false by rewrite (disjointFl disjF) // !inE eqxx.
have zNH : z \notin H by rewrite !inE ![z == _]eq_sym !negb_or xDz yDz zNF.
have x_H : x \in H by rewrite !inE eqxx.
suff connH w : connected (H :\ w).
{ (* extending the [z--u] to a separator contradicts the maximality of F *)
  have [v /vseparatorP V2] := edge_separator le5G connG zu (not3xy _ _ zu).
  pose F' := H :\ v.
  have cmp3_F : cmp3 z u v F'.
  { split => //; first exact: connH; rewrite disjoint_sym disjoint_subset.
    apply/subsetP => i; rewrite !inE -orbA => /or3P[] /eqP->.
    - by rewrite ![z == _]eq_sym (negbTE xDz) (negbTE yDz) zNF.
    - by move: uNH; rewrite !inE => /negbTE ->.
    - by rewrite eqxx. }
  have:= max_xyF z u v F' cmp3_F.
  rewrite /F'/H -setUA => X; have {X} := leq_trans (leq_cardsD1 _ _) X.
  rewrite !cardsU1 !inE sg_edgeNeq //= !(disjointFl disjF) ?add1n ?ltnn //.
  all: by rewrite !inE eqxx. }
case: (boolP (w \in [set x; y])) => [w_xy|].
{ (* [x] and [y] cannot disconnect [H] *)
  case/set2P : w_xy => ->.
  - have -> : H :\ x = F :|: [set y].
      apply/setP => i; rewrite setUC !inE. case: (eqVneq i x) => // ->.
      by rewrite (sg_edgeNeq xy) /= (disjointFl disjF) // !inE eqxx.
    have [v vy v_F] : exists2 v, v -- y & v \in F.
    { rewrite defXYZ in min_xyz.
      have := @svseparator_neighbours _ _ _ y psepH.
      rewrite setUUC -{2}defXYZ !inE eqxx; case => // v [?] [Hv _ vy _].
      exists v; rewrite 1?sgP //. by move: Hv; rewrite !inE negb_or negbK => /andP[]//. }
    apply: connectedU_edge vy _ _ => //. by rewrite inE eqxx. exact: connected1.
  - (* same as above - TODO: symmetry reasoning *)
    have -> : H :\ y = F :|: [set x].
      apply/setP => i; rewrite setUC !inE. case: (eqVneq i y) => // ->.
      by rewrite [y==x]eq_sym (sg_edgeNeq xy) /= (disjointFl disjF) // !inE eqxx.
    have [v vx v_F] : exists2 v, v -- x & v \in F.
    { rewrite defXYZ in min_xyz.
      have := @svseparator_neighbours _ _ _ x psepH.
      rewrite setUUC -{2}defXYZ !inE eqxx; case => // v [?] [Hv _ vx _].
      exists v; rewrite 1?sgP //. by move: Hv; rewrite !inE negb_or negbK => /andP[]//. }
    apply: connectedU_edge vx _ _ => //. by rewrite inE eqxx. exact: connected1. }
rewrite !inE negb_or => /andP [wDx wDy].
pose Cx := [set v | connect (restrict (H :\ w) sedge) x v ].
wlog [s /setD1P [sNw s_H] sNCx] : / exists2 s, s \in H:\ w & s \notin Cx.
{ have [/exists_inP ?|] := boolP [exists s in H :\ w, s \notin Cx]; first by apply.
  move/exists_inPnn => C _.
  apply: (@connected_center _ x); last by rewrite !inE eqxx eq_sym wDx.
  by move=> v /C; rewrite !inE. }
suff : separates x s [set w;z].
{ by move/separates_vseparator/min3sep; rewrite cards2; case (_ == _). }
have sDx : s != x by apply: contraNneq sNCx => ->; rewrite inE connect0.
have sDy : s != y.
{ apply: contraNneq sNCx => ->; rewrite inE connect1 //= xy andbT.
  by rewrite !inE !eqxx ![_ == w]eq_sym wDx wDy. }
have s_F : s \in F by move: s_H; rewrite !inE (negbTE sDx) (negbTE sDy).
have sDz : s != z by apply: contraTneq s_F => ->; rewrite zNF.
apply: separatesI; split.
- by rewrite !inE negb_or xDz eq_sym wDx.
- rewrite !inE negb_or sNw /=. by apply: contraNneq zNH => <-.
- elim/card_ind => p IHp Ip.
  have [z_p|zNp] := boolP (z \in p); first by exists z => //; rewrite !inE eqxx.
  have W_xs (q : Path x s) : q \subset H -> w \in q.
  { move/subsetP => qH; apply: contraNT sNCx => wNq; rewrite inE.
    apply: (connectRI q) => i i_q. rewrite inE qH // andbT inE.
    by apply: contraNneq wNq => <-. }
  have [/W_xs|/subsetPn [i i_p iNH]] := boolP (p \subset H).
  { by exists w => //; rewrite !inE eqxx. }
  case def_p : _ / (isplitP Ip i_p) => [p1 p2 Ip1 Ip2 E1].
  have y_p2 : y \in p2.
  { case: psepH => sepH _.
    have [] := @separation_separates _ s i _ _ sepH.
    - by rewrite !inE negb_or negbK s_F -defXYZ !inE (negbTE sDx) (negbTE sDy) sDz.
    - rewrite -defXYZ setUA [F :|: _]setUC -/H inE negb_or iNH inE.
      by apply: contraTneq i_p => ->.
    - move => _ _ /(_ (prev p2)) [y']; rewrite setUUC mem_prev -defXYZ => y'_p2.
      rewrite !inE -orbA => /or3P[] /eqP ?; subst y' => //.
      + by apply: contraNT iNH => _; rewrite -(E1 x).
      + by rewrite def_p !inE y'_p2 orbT in zNp. }
  case def_p2 : _ / (isplitP Ip2 y_p2) => [p21 p22 Ip21 Ip22 E2].
  pose q := pcat (edgep xy) p22.
  have q_sub_p : {subset q <= p}.
  { by move=>j; case/edgeLP => [->|]; rewrite ?def_p ?def_p2 ?inE // => ->. }
  have [||j J1 J2] := IHp q.
  + apply/proper_card/properP; split; first exact/subsetP.
    exists i => //. apply: contraNN iNH => /edgeLP [->//|i_p22].
    by rewrite [i]E2 ?inE // eqxx.
  + rewrite irred_edgeL Ip22 andbT. apply: contraTN iNH => x_p22.
    by rewrite -(E1 x) ?negbK // def_p2 inE x_p22.
  + exists j => //. rewrite -def_p2 -def_p. exact: q_sub_p.
Qed.

(** ** Isomorphims for vertex merging *)

Arguments inl_inj {A B}.
Arguments inr_inj {A B}.

(** The case for overlap 1 - one [smerge2] operation *)

Lemma diso_separation1 (G : sgraph) (V1 V2 : {set G}) (x : G) (xV1 : x \in V1) (xV2 : x \in V2) :
  separation V1 V2 -> V1 :&: V2 = [set x] ->
  let G' := (induced V1 ∔ induced V2)%sg in
  diso (smerge2 G' (inl (Sub x xV1)) (inr (Sub x xV2))) G.
Proof.
move=> sepV capV G'.
have sepV' u v : u \in V1 -> v \in V2 -> u != x -> v != x -> u -- v = false.
{ move=> uV1 vV2 uDx vDx. apply: sepV.2.
  - apply: contraNN uDx => uV2. by rewrite -in_set1 -capV !inE uV1.
  - apply: contraNN vDx => vV1. by rewrite -in_set1 -capV !inE vV2. }
set x1 : G' := inl (Sub x xV1); set x2 : G' := inr (Sub x xV2).
set H := smerge2 _ _ _.
have h_dec (u : G) :    ({ uV1 : u \in V1 | inl (Sub u uV1) != x2 })
                      + ({ uV2 : u \in V2 | inr (Sub u uV2) != x2 }).
{ case: {-}_ /(boolP (u \in V1)) => [p|uNV1]; first by left; exists p.
  have uV2 : u \in V2 by apply: sep_inR sepV _.
  right; exists uV2; rewrite (inj_eq inr_inj) -val_eqE /=.
  by rewrite -in_set1 -capV inE negb_and uNV1. }
pose h (u : G) : H :=
  match h_dec u with
    inl (exist uV1 uDx2) => Sub (inl (Sub u uV1)) uDx2
  | inr (exist uV2 uDx2) => Sub (inr (Sub u uV2)) uDx2
  end.
pose g (x : H) : G := match val x with inl z => val z | inr z => val z end.
have can_g : cancel g h.
{ move => [[u uDx2|u uDx2]]; rewrite /g/h/=; apply: val_inj => /=.
  - case: (h_dec _) => -[uV uDx2']; first by rewrite valK'.
    case: notF ; rewrite (inj_eq inr_inj) -val_eqE /= in uDx2'.
    by rewrite -in_set1 -capV inE (valP u) uV in uDx2'.
  - case: (h_dec _) => -[uV uDx2']; last by rewrite /= valK'.
    case: notF ; rewrite (inj_eq inr_inj) -val_eqE /= in uDx2.
      by rewrite -in_set1 -capV inE (valP u) uV in uDx2. }
have can_h : cancel h g.
{ by move => u; rewrite /h/g; case: (h_dec u) => -[uV uDx2]. }
have hom_g : is_dhom g.
{ move => u v.
 rewrite {1}/edge_rel/= /g.
 rewrite -[sval u]/(val u) -[sval v]/(val v).
 case: (eqVneq (val u) x1) => [->|_]; case: (eqVneq (val v) x1) => [->|_] /=.
 - by rewrite sgP.
 - by case: (sval v) => -[z Hz] /=; rewrite {1 2}/edge_rel/= ?orbF 1?sg_sym.
 - by case: (sval u) => -[z Hz]; rewrite {1 2}/edge_rel/= ?orbF.
 - by case: (sval u) => -[z Hz]; case: (sval v) => -[z' Hz']. }
have hom_h : is_dhom h.
{ move => u v uv; rewrite /h.
  case: (h_dec u) => -[uV uDx2]; case: (h_dec v) => -[vV vDx2] => //.
  - by apply: smerge2_edge.
  - rewrite /edge_rel/= !(inj_eq inl_inj) -!val_eqE /=.
    rewrite (inj_eq inr_inj) -val_eqE /= in vDx2.
    case: (eqVneq u x) => [?|vDx] /=; first by subst u; rewrite sgP.
    by rewrite sepV' in uv. (* violates separation property *)
  - have uDx : u != x by rewrite (inj_eq inr_inj) -val_eqE /= in uDx2.
    rewrite /edge_rel/= !(inj_eq inl_inj) -!val_eqE /=.
    case: (eqVneq v x) => [?|vDx] /=; first by subst v.
    by rewrite sgP sepV' in uv. (* violates separation property *) }
exact: Diso'' can_g can_h _ _.
Qed.

(** The case for overlap 2 - two [smerge2] operations *)

(** In the case of a proper separtion [(V1,V2)] that overlaps in a set
[[set x;y]] with [x -- y], we need two [smerge2] operations to
collapse [induced V1] and [induced V2]. Given the complex definition
of the edge relation for [smerge2], this leads to a rather messy
construction. To alleviate this somewhat, we introduce an intermediate
construction [glue2] that merges two vertices from different graphs in
one go. *)

Section Glue2.
Variables (G : sgraph) (x y : G) (H : sgraph) (x' y' : H).

Definition glue2_vertex : Type := G + { z | z \notin [set x';y'] }.

Definition glue2_rel (u v : glue2_vertex) :=
  match u,v with
  | inl u, inl v => u -- v
  | inr u, inr v => val u -- val v
  | inl u, inr v => (u == x) && x' -- val v || (u == y) && y' -- val v
  | inr v, inl u => (u == x) && x' -- val v || (u == y) && y' -- val v
  end.

Lemma glue2_sym : symmetric glue2_rel.
Proof. move => [u|u] [v|v] //=; by rewrite sgP. Qed.

Lemma glue2_irrefl : irreflexive glue2_rel.
Proof. by move => [u|u] /=; rewrite sgP. Qed.

Definition glue2 := SGraph glue2_sym glue2_irrefl.

(** injection for elements of H *)
Definition glue2_r (z : H) : glue2.
refine (
  if @boolP (z == x') isn't AltFalse b1 then inl x else
    if @boolP (z == y') isn't AltFalse b2 then inl y else
      inr (Sub z _)
); abstract (by rewrite !inE negb_or b1 b2).
Defined.

End Glue2.
Arguments glue2 : clear implicits.
Arguments glue2_r [G x y H x' y'] _.

Open Scope implicit_scope.

Lemma smerge2_glue2 (G H : sgraph) (x1 y1 : G) (x2 y2 : H) (p1 : inl y1 != inr x2) (p2 : inr y2 != inr x2) :
  x1 != y1 -> x1 -- y1 ->
  diso (smerge2 (smerge2 (G ∔ H)%sg (inl x1) (inr x2)) (Sub (inl y1) p1) (Sub (inr y2) p2))
       (glue2 G x1 y1 H x2 y2).
Proof.
move=> x1Dy1 x1y1.
set U' := smerge2 (G ∔ H)%sg (inl x1) (inr x2).
set U := smerge2 _ _ _.
(* neither smerge2 operation contracts an edge *)
have x1Nx2 : ~~ inl x1 -- inr x2 :> (G ∔ H)%sg by [].
have y1Ny2 p q : ~~ (Sub (inl y1) p) -- (Sub (inr y2) q) :> U'.
{ by rewrite /edge_rel/= eq_sym (inj_eq inl_inj) (negbTE x1Dy1). }
set V := glue2 _ _ _ _ _ _.
pose f (u : U) : V :=
  match val (val u) with
  | inl z => inl z
  | inr z => glue2_r z
  end.
pose y1' : U := (Sub (Sub (inl y1) isT) isT).
pose x1' : U' := (Sub (inl x1) isT).
pose g (v : V) : U :=
  match v with
  | inl z => Sub (Sub (inl z) isT) isT
  | inr z => insubd y1' (insubd x1' (inr (val z)))
  end.
have gP1 z : z \notin [set x2; y2] -> val (insubd x1' (inr z)) = inr z.
{ move=> ?; rewrite insubdK // -topredE/= (inj_eq inr_inj); set_tac. }
have gP2 z : z \notin [set x2; y2] -> val (val (insubd y1' (insubd x1' (inr z)))) = inr z.
{ move=> ?. rewrite val_insubd -val_eqE gP1 //= ifT ?gP1 // (inj_eq inr_inj). by set_tac. }
have can_f : cancel f g.
{ rewrite /f/g. move => [[[u|u] U2] U1] => /=; do 2 apply: val_inj => //=.
  rewrite /glue2_r altF altF. rewrite !insubdK //=.
  rewrite -val_eqE /= in U1. by rewrite -topredE/= -val_eqE insubdK. }
have can_g : cancel g f.
{ rewrite /f/g. move => [v|[v Hv]] //=.
  move : {-}(Hv); rewrite !(inE,negb_or) => /andP[vDx2 vDy2].
  rewrite insubdK; last by rewrite -topredE/= -val_eqE /= val_insubd vDx2.
  rewrite insubdK // /glue2_r !altF; congr (inr _). exact: val_inj. }
have hom_g : is_dhom g.
{ move => [u|[u Hu]] [v|[v Hv]]; rewrite /g/=.
  - move => ?. by do 2 apply: smerge2_edge.
  - rewrite {1}/edge_rel/=. case/orP => -/andP[/eqP-> ev].
    + apply: smerge2_edge. apply: smerge2edgeL => //; by rewrite gP2 // sgP.
    + apply: smerge2edgeL => //; first by rewrite -val_eqE.
      by apply: smerge2_edge; rewrite gP2 //= sgP.
  - rewrite {1}/edge_rel/=. case/orP => -/andP[/eqP-> ev].
    + rewrite sgP. apply: smerge2_edge. apply: smerge2edgeL => //.
      by rewrite gP2 // sgP.
    + rewrite sgP. apply: smerge2edgeL => //; first by rewrite -val_eqE.
      by apply: smerge2_edge; rewrite gP2 //= sgP.
  - rewrite {1}/edge_rel/= => uv. do 2 apply: smerge2_edge. by rewrite !gP2. }
have hom_f : is_dhom f.
{ rewrite /is_dhom. apply: smerge2Ecase => //; first by move=> ? ?; rewrite sgP.
  - (* edge of inner smerge operation (megring x1 and x2 *)
    move => [u Hu] [v Hv] /= uv. move: Hu Hv. pattern u,v.
    apply: smerge2Ecase => //= {u v uv}.
    + move=> u v; split => A Hu Hv; rewrite sgP; apply: A.
    + (* original edge *)
      move => [[u|u] Hu] [[v|v] Hv] //; rewrite /f/=.
      rewrite -?val_eqE /= !(inj_eq inr_inj) => uv uDy2 vDy2.
      by rewrite /glue2_r !altF /edge_rel/=.
    + (* edge modified by inner smerge2 operation *)
      move => [[u|u] Hu] // [[v|v] Hv] //=; first by rewrite andbF.
      case/andP=> [eq_u vx2]; rewrite /f/= -val_eqE /= (inj_eq inr_inj) => _ vDy2.
      rewrite /glue2_r 2!altF /edge_rel/=; apply/orP;left; apply/andP; split => //.
      by rewrite sgP.
  - (* edge modified by outer smerge2 operation *)
    move => [u Hu] [v Hv] /= => /andP[/eqP ?]; subst u; rewrite /f/=.
    rewrite smerge2edgeD // => /or3P [].
    + case: v Hv => -[v|v] Hv' Hv //= vy2. rewrite -val_eqE /= in Hv.
      rewrite /glue2_r 2!altF. rewrite /edge_rel/= eqxx [y2 -- _]sgP.
      by apply/orP; right.
    + case/andP => [def_v E]. rewrite (eqP def_v).
      by rewrite /edge_rel/= sgP.
    + done. }
exact: Diso'' can_f can_g hom_f hom_g.
Qed.

Lemma separation_capN (G : sgraph) (V1 V2 : {set G}) u v :
  separation V1 V2 -> u \in V1 -> v \in V2 -> u -- v -> (u \in V1 :&: V2) || (v \in V1 :&: V2).
Proof.
move => sepV uV1 vV2 uv; rewrite !inE uV1 vV2 andbT /=.
by apply: contraTT uv; rewrite negb_or => /andP[uNV2 vNV1]; rewrite sepV.
Qed.

Lemma diso_separation2_glue (G : sgraph) (V1 V2 : {set G}) (x y : G)
  (xV1 : x \in V1) (xV2 : x \in V2) (yV1 : y \in V1) (yV2 : y \in V2) :
  separation V1 V2 -> V1 :&: V2 = [set x;y] ->
  diso (glue2 (induced V1) (Sub x xV1) (Sub y yV1) (induced V2) (Sub x xV2) (Sub y yV2)) G.
Proof.
set x' := Sub x xV2; set y' := Sub y yV2.
move => sepV capV; set H := glue2 _ _ _ _ _ _.
pose g (u : H) : G :=
  match u with inl u => val u | inr u => val (val u) end.
have h_dec (u : G) : (u \in V1) + ({ uV2 : u \in V2 | Sub u uV2 \notin [set x';y'] }).
{ case: (boolP (u \in V1)) => [|uV1]; [by left|right].
  by exists (sep_inR sepV uV1); rewrite in_set2 -!val_eqE /= -in_set2 -capV inE (negbTE uV1). }
have h_dec_l u (uV1 : u \in V1) : h_dec u = inl uV1.
{ case: (h_dec u) => [uV1'|[uV2 p]]; first by congr(inl _); exact: bool_irrelevance.
  case: notF. by rewrite in_set2 -!val_eqE /= -in_set2 -capV !inE uV1 uV2 in p. }
have h_dec_r u (uV2 : u \in V2) (p : Sub u uV2 \notin [set x';y']) : h_dec u = inr (Sub uV2 p).
{ case: (h_dec u) => [uV1|[uV2' p']]; last by congr (inr _); apply: val_inj; apply: bool_irrelevance.
  case: notF. by rewrite in_set2 -!val_eqE /= -in_set2 -capV !inE uV1 uV2 in p. }
pose h (u : G) : H :=
  match h_dec u with
  | inl uV1 => inl (Sub u uV1)
  | inr (exist uV2 p) => inr (Sub (Sub u uV2) p)
  end.
have can_g : cancel g h.
{ move => [[u uV1]|[[u uV2] p]]; rewrite /h/g/=.
  + by rewrite h_dec_l.
  + by rewrite h_dec_r. }
have can_h : cancel h g.
{ by move => u; rewrite /h; case: (h_dec _) => [uV1|[uV1 p]]. }
have hom_g : is_dhom g.
{ move=> u v. rewrite [u -- v]/edge_rel/=.
  move: u v => [u|u] [v|v] //=. by case/orP => [/andP[/eqP->]|/andP[/eqP->]].
  case/orP => [/andP[/eqP->]|/andP[/eqP->]] //; by rewrite sgP. }
have hom_h : is_dhom h.
{ move => u v uv. rewrite /h/edge_rel/=.
  case: (h_dec u) => [uV1|[uV2 p]]; case: (h_dec v) => [vV1|[vV2 q]] /=.
  1,4 : by rewrite induced_edge.
  - rewrite !inE -!val_eqE /= -in_set2 in q.
    rewrite -!val_eqE !induced_edge /=.
    have := separation_capN sepV uV1 vV2 uv; rewrite capV (negbTE q) orbF.
    by case/set2P => ?; subst u; rewrite eqxx uv.
  - rewrite !inE -!val_eqE /= -in_set2  in p.
    rewrite -!val_eqE !induced_edge /=; rewrite sgP in uv.
    have := separation_capN sepV vV1 uV2 uv; rewrite capV (negbTE p) orbF.
    by case/set2P => ?; subst v; rewrite eqxx uv. }
exact: Diso'' hom_g hom_h.
Qed.

Lemma diso_separation2 (G : sgraph) (V1 V2 : {set G}) (x y : G)
   (xV1 : x \in V1) (xV2 : x \in V2) (yV1 : y \in V1) (yV2 : y \in V2)
   (G1 := induced V1) (G2 := induced V2) (G12 := (G1 ∔ G2)%sg)
   (x1 : G12 := inl (Sub x xV1)) (x2 : G12 := inr (Sub x xV2))
   (y1 : G12 := inl (Sub y yV1)) (y2 : G12 := inr (Sub y yV2))
   (y1Gm : y1 != x2) (y2Gm : y2 != x2) :
  separation V1 V2 -> V1 :&: V2 = [set x; y] -> x -- y ->
  diso (smerge2 (smerge2 (G1 ∔ G2) x1 x2) (Sub y1 y1Gm) (Sub y2 y2Gm)) G.
Proof.
move=> sepV capV xy.
have := diso_separation2_glue xV1 xV2 yV1 yV2 sepV capV.
apply: diso_comp. apply: smerge2_glue2 => //.
by rewrite -val_eqE /= sg_edgeNeq.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * DecimalNat *)

Require Import Decimal DecimalFacts Arith.

(** The conversion functions bewteen [nat] and [uint], as an extension
    of the Nat module *)

Module Nat.

Include PeanoNat.Nat.

(** ** Tail-recursive versions of [add] and [mul] *)

Fixpoint tail_add n m :=
  match n with
    | O => m
    | S n => tail_add n (S m)
  end.

(** [tail_addmul r n m] is [r + n * m]. *)

Fixpoint tail_addmul r n m :=
  match n with
    | O => r
    | S n => tail_addmul (tail_add m r) n m
  end.

Definition tail_mul n m := tail_addmul 0 n m.

Lemma tail_add_spec n m : tail_add n m = n + m.
Proof.
 revert m. induction n as [|n IH]; simpl; trivial.
 intros. now rewrite IH, add_succ_r.
Qed.

Lemma tail_addmul_spec r n m : tail_addmul r n m = r + n * m.
Proof.
 revert m r. induction n as [| n IH]; simpl; trivial.
 intros. rewrite IH, tail_add_spec.
 rewrite add_assoc. f_equal. apply add_comm.
Qed.

Lemma tail_mul_spec n m : tail_mul n m = n * m.
Proof.
 unfold tail_mul. now rewrite tail_addmul_spec.
Qed.

(** ** Conversion with a decimal representation for printing/parsing *)

Local Notation ten := (S (S (S (S (S (S (S (S (S (S O)))))))))).

Fixpoint of_uint_acc (d:Decimal.uint)(acc:nat) :=
  match d with
  | Decimal.Nil => acc
  | Decimal.D0 d => of_uint_acc d (tail_mul ten acc)
  | Decimal.D1 d => of_uint_acc d (S (tail_mul ten acc))
  | Decimal.D2 d => of_uint_acc d (S (S (tail_mul ten acc)))
  | Decimal.D3 d => of_uint_acc d (S (S (S (tail_mul ten acc))))
  | Decimal.D4 d => of_uint_acc d (S (S (S (S (tail_mul ten acc)))))
  | Decimal.D5 d => of_uint_acc d (S (S (S (S (S (tail_mul ten acc))))))
  | Decimal.D6 d => of_uint_acc d (S (S (S (S (S (S (tail_mul ten acc)))))))
  | Decimal.D7 d => of_uint_acc d (S (S (S (S (S (S (S (tail_mul ten acc))))))))
  | Decimal.D8 d => of_uint_acc d (S (S (S (S (S (S (S (S (tail_mul ten acc)))))))))
  | Decimal.D9 d => of_uint_acc d (S (S (S (S (S (S (S (S (S (tail_mul ten acc))))))))))
  end.

Definition of_uint (d:Decimal.uint) := of_uint_acc d O.

Fixpoint to_little_uint n acc :=
  match n with
  | O => acc
  | S n => to_little_uint n (Decimal.Little.succ acc)
  end.

Definition to_uint n :=
  Decimal.rev (to_little_uint n Decimal.zero).

Definition of_int (d:Decimal.int) : option nat :=
  match Decimal.norm d with
    | Decimal.Pos u => Some (of_uint u)
    | _ => None
  end.

Definition to_int n := Decimal.Pos (to_uint n).

End Nat.

(** Proofs that conversions between decimal numbers and [nat]
    are bijections. *)

Module Unsigned.

(** A few helper functions used during proofs *)

Definition hd d :=
 match d with
 | Nil => 0
 | D0 _ => 0
 | D1 _ => 1
 | D2 _ => 2
 | D3 _ => 3
 | D4 _ => 4
 | D5 _ => 5
 | D6 _ => 6
 | D7 _ => 7
 | D8 _ => 8
 | D9 _ => 9
end.

Definition tl d :=
 match d with
 | Nil => d
 | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d
end.

Fixpoint usize (d:uint) : nat :=
  match d with
  | Nil => 0
  | D0 d => S (usize d)
  | D1 d => S (usize d)
  | D2 d => S (usize d)
  | D3 d => S (usize d)
  | D4 d => S (usize d)
  | D5 d => S (usize d)
  | D6 d => S (usize d)
  | D7 d => S (usize d)
  | D8 d => S (usize d)
  | D9 d => S (usize d)
  end.

(** A direct version of [to_little_uint], not tail-recursive *)
Fixpoint to_lu n :=
 match n with
 | 0 => Decimal.zero
 | S n => Little.succ (to_lu n)
 end.

(** A direct version of [of_little_uint] *)
Fixpoint of_lu (d:uint) : nat :=
  match d with
  | Nil => 0
  | D0 d => 10 * of_lu d
  | D1 d => 1 + 10 * of_lu d
  | D2 d => 2 + 10 * of_lu d
  | D3 d => 3 + 10 * of_lu d
  | D4 d => 4 + 10 * of_lu d
  | D5 d => 5 + 10 * of_lu d
  | D6 d => 6 + 10 * of_lu d
  | D7 d => 7 + 10 * of_lu d
  | D8 d => 8 + 10 * of_lu d
  | D9 d => 9 + 10 * of_lu d
  end.

(** Properties of [to_lu] *)

Lemma to_lu_succ n : to_lu (S n) = Little.succ (to_lu n).
Proof.
 reflexivity.
Qed.

Lemma to_little_uint_succ n d :
 Nat.to_little_uint n (Little.succ d) =
  Little.succ (Nat.to_little_uint n d).
Proof.
 revert d; induction n; simpl; trivial.
Qed.

Lemma to_lu_equiv n :
  to_lu n = Nat.to_little_uint n 0.
Proof.
 induction n; simpl; trivial.
 now rewrite IHn, <- to_little_uint_succ.
Qed.

Lemma to_uint_alt n :
 Nat.to_uint n = rev (to_lu n).
Proof.
 unfold Nat.to_uint. f_equal. symmetry. apply to_lu_equiv.
Qed.

(** Properties of [of_lu] *)

Lemma of_lu_eqn d :
 of_lu d = hd d + 10 * of_lu (tl d).
Proof.
 induction d; simpl; trivial.
Qed.

Ltac simpl_of_lu :=
 match goal with
 | |- context [ of_lu (?f ?x) ] =>
   rewrite (of_lu_eqn (f x)); simpl hd; simpl tl
 end.

Lemma of_lu_succ d :
 of_lu (Little.succ d) = S (of_lu d).
Proof.
 induction d; trivial.
 simpl_of_lu. rewrite IHd. simpl_of_lu.
 now rewrite Nat.mul_succ_r, <- (Nat.add_comm 10).
Qed.

Lemma of_to_lu n :
 of_lu (to_lu n) = n.
Proof.
 induction n; simpl; trivial. rewrite of_lu_succ. now f_equal.
Qed.

Lemma of_lu_revapp d d' :
of_lu (revapp d d') =
 of_lu (rev d) + of_lu d' * 10^usize d.
Proof.
 revert d'.
 induction d; intro d'; simpl usize;
 [ simpl; now rewrite Nat.mul_1_r | .. ];
 unfold rev; simpl revapp; rewrite 2 IHd;
 rewrite <- Nat.add_assoc; f_equal; simpl_of_lu; simpl of_lu;
 rewrite Nat.pow_succ_r'; ring.
Qed.

Lemma of_uint_acc_spec n d :
 Nat.of_uint_acc d n = of_lu (rev d) + n * 10^usize d.
Proof.
 revert n. induction d; intros;
 simpl Nat.of_uint_acc; rewrite ?Nat.tail_mul_spec, ?IHd;
 simpl rev; simpl usize; rewrite ?Nat.pow_succ_r';
 [ simpl; now rewrite Nat.mul_1_r | .. ];
 unfold rev at 2; simpl revapp; rewrite of_lu_revapp;
 simpl of_lu; ring.
Qed.

Lemma of_uint_alt d : Nat.of_uint d = of_lu (rev d).
Proof.
 unfold Nat.of_uint. now rewrite of_uint_acc_spec.
Qed.

(** First main bijection result *)

Lemma of_to (n:nat) : Nat.of_uint (Nat.to_uint n) = n.
Proof.
 rewrite to_uint_alt, of_uint_alt, rev_rev. apply of_to_lu.
Qed.

(** The other direction *)

Lemma to_lu_tenfold n : n<>0 ->
 to_lu (10 * n) = D0 (to_lu n).
Proof.
 induction n.
 - simpl. now destruct 1.
 - intros _.
   destruct (Nat.eq_dec n 0) as [->|H]; simpl; trivial.
   rewrite !Nat.add_succ_r.
   simpl in *. rewrite (IHn H). now destruct (to_lu n).
Qed.

Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil.
Proof.
 induction d; try simpl_of_lu; try easy.
 rewrite Nat.add_0_l.
 split; intros H.
 - apply Nat.eq_mul_0_r in H; auto.
   rewrite IHd in H. simpl. now rewrite H.
 - simpl in H. destruct (nztail d); try discriminate.
   now destruct IHd as [_ ->].
Qed.

Lemma to_of_lu_tenfold d :
 to_lu (of_lu d) = lnorm d ->
 to_lu (10 * of_lu d) = lnorm (D0 d).
Proof.
 intro IH.
 destruct (Nat.eq_dec (of_lu d) 0) as [H|H].
 - rewrite H. simpl. rewrite of_lu_0 in H.
   unfold lnorm. simpl. now rewrite H.
 - rewrite (to_lu_tenfold _ H), IH.
   rewrite of_lu_0 in H.
   unfold lnorm. simpl. now destruct (nztail d).
Qed.

Lemma to_of_lu d : to_lu (of_lu d) = lnorm d.
Proof.
 induction d; [ reflexivity | .. ];
 simpl_of_lu;
 rewrite ?Nat.add_succ_l, Nat.add_0_l, ?to_lu_succ, to_of_lu_tenfold
  by assumption;
 unfold lnorm; simpl; now destruct nztail.
Qed.

(** Second bijection result *)

Lemma to_of (d:uint) : Nat.to_uint (Nat.of_uint d) = unorm d.
Proof.
 rewrite to_uint_alt, of_uint_alt, to_of_lu.
 apply rev_lnorm_rev.
Qed.

(** Some consequences *)

Lemma to_uint_inj n n' : Nat.to_uint n = Nat.to_uint n' -> n = n'.
Proof.
 intro EQ.
 now rewrite <- (of_to n), <- (of_to n'), EQ.
Qed.

Lemma to_uint_surj d : exists n, Nat.to_uint n = unorm d.
Proof.
 exists (Nat.of_uint d). apply to_of.
Qed.

Lemma of_uint_norm d : Nat.of_uint (unorm d) = Nat.of_uint d.
Proof.
 unfold Nat.of_uint. now induction d.
Qed.

Lemma of_inj d d' :
 Nat.of_uint d = Nat.of_uint d' -> unorm d = unorm d'.
Proof.
 intros. rewrite <- !to_of. now f_equal.
Qed.

Lemma of_iff d d' : Nat.of_uint d = Nat.of_uint d' <-> unorm d = unorm d'.
Proof.
 split. apply of_inj. intros E. rewrite <- of_uint_norm, E.
 apply of_uint_norm.
Qed.

End Unsigned.

(** Conversion from/to signed decimal numbers *)

Module Signed.

Lemma of_to (n:nat) : Nat.of_int (Nat.to_int n) = Some n.
Proof.
 unfold Nat.to_int, Nat.of_int, norm. f_equal.
 rewrite Unsigned.of_uint_norm. apply Unsigned.of_to.
Qed.

Lemma to_of (d:int)(n:nat) : Nat.of_int d = Some n -> Nat.to_int n = norm d.
Proof.
 unfold Nat.of_int.
 destruct (norm d) eqn:Hd; intros [= <-].
 unfold Nat.to_int. rewrite Unsigned.to_of. f_equal.
 revert Hd; destruct d; simpl.
 - intros [= <-]. apply unorm_invol.
 - destruct (nzhead d); now intros [= <-].
Qed.

Lemma to_int_inj n n' : Nat.to_int n = Nat.to_int n' -> n = n'.
Proof.
 intro E.
 assert (E' : Some n = Some n').
 { now rewrite <- (of_to n), <- (of_to n'), E. }
 now injection E'.
Qed.

Lemma to_int_pos_surj d : exists n, Nat.to_int n = norm (Pos d).
Proof.
 exists (Nat.of_uint d). unfold Nat.to_int. now rewrite Unsigned.to_of.
Qed.

Lemma of_int_norm d : Nat.of_int (norm d) = Nat.of_int d.
Proof.
 unfold Nat.of_int. now rewrite norm_invol.
Qed.

Lemma of_inj_pos d d' :
 Nat.of_int (Pos d) = Nat.of_int (Pos d') -> unorm d = unorm d'.
Proof.
 unfold Nat.of_int. simpl. intros [= H]. apply Unsigned.of_inj.
 now rewrite <- Unsigned.of_uint_norm, H, Unsigned.of_uint_norm.
Qed.

End Signed.