Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.ErasedRefine.

Opaque reducible_values.

Lemma annotated_subtype_refine:
  forall Θ Γ A B p q x,
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv p) ->
    ~(x ∈ fv q) ->
    ~(x ∈ fv A) ->
    ~(x ∈ Θ) ->
    wf q 1 ->
    is_annotated_term q ->
    subset (fv q) (support Γ) ->
    [[ Θ; (x, T_refine A p) :: Γ ⊨ open 0 q (fvar x term_var) ≡ ttrue ]] ->
    [[ Θ; Γ ⊨ A <: B ]] ->
    [[ Θ; Γ ⊨ T_refine A p <: T_refine B q ]].
Proof.
  unfold open_equivalent, open_subtype;
    repeat step.

  apply subtype_refine with
    (erase_context Γ) (erase_type A) (erase_term p) x;
    repeat step || t_instantiate_sat3 || erase_open;
    side_conditions.
Qed.

Lemma annotated_subtype_refine2:
  forall Θ Γ A B p,
    [[ Θ; Γ ⊨ A <: B ]] ->
    [[ Θ; Γ ⊨ T_refine A p <: B ]].
Proof.
  unfold open_equivalent, open_subtype;
    repeat step || simp_red.
Qed.

Lemma annotated_subtype_refine3:
  forall Θ Γ A,
    [[ Θ; Γ ⊨ A <: T_refine A ttrue ]].
Proof.
  unfold open_equivalent, open_subtype;
    repeat step || simp_red;
    t_closer.
Qed.

Lemma annotated_subtype_refine4:
  forall Θ Γ T A p x,
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv p) ->
    ~(x ∈ fv T) ->
    ~(x ∈ Θ) ->
    wf p 1 ->
    is_annotated_term p ->
    subset (fv p) (support Γ) ->
    [[ Θ; (x, T) :: Γ ⊨ open 0 p (fvar x term_var) ≡ ttrue ]] ->
    [[ Θ; Γ ⊨ T <: A ]] ->
    [[ Θ; Γ ⊨ T <: T_refine A p ]].
Proof.
  unfold open_equivalent, open_subtype;
    repeat step.

  apply subtype_refine4 with (erase_context Γ) (erase_type T) x;
    repeat step || t_instantiate_sat3 || erase_open;
    side_conditions.
Qed.

Lemma annotated_subtype_refine5:
  forall Θ Γ T A b x p,
    ~(x ∈ fv_context Γ) ->
    ~(p ∈ fv_context Γ) ->
    ~(x = p) ->
    ~(x ∈ fv b) ->
    ~(p ∈ fv b) ->
    ~(x ∈ fv T) ->
    ~(p ∈ fv T) ->
    ~(x ∈ fv A) ->
    ~(p ∈ fv A) ->
    ~(x ∈ Θ) ->
    ~(p ∈ Θ) ->
    is_annotated_term b ->
    [[ Θ; (p, T_equiv (open 0 b (fvar x term_var)) ttrue) :: (x, A) :: Γ ⊨ fvar x term_var: T ]] ->
    [[ Θ; Γ ⊨ T_refine A b <: T ]].
Proof.
  unfold open_equivalent, open_subtype;
    repeat step.

  apply subtype_refine5 with (erase_context Γ) (erase_type A) (erase_term b) x p;
    repeat step || t_instantiate_sat3 || erase_open;
    side_conditions.
Qed.


Require Import FMapList OrderedType OrderedTypeEx Compare_dec Peano_dec.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool eqtype ssrnat seq fintype ssrfun tuple finset div.
From Bits
     Require Import bits extraction.axioms32.
Require Import spec.

Require create get insert remove inter union symdiff compl keep_min min cardinal shift.

(** * A formalisation of bitsets using OCaml's integers *)

(**

    We establish a relation between OCaml's types (which extracts
    efficiently to machine-native datatypes) and the finset
    library. This is achieved by composing the representation of [BITS
    32] with OCaml's [int] (defined in [coq:bits]) and the
    representation of [finset] with [BITS n].

 *)

Definition machine_repr (n: Int32)(E: {set 'I_wordsize}): Prop :=
  exists bv, native_repr n bv /\ repr bv E.

(** We go from Coq's [nat] to [Int] by (brutally) collapsing [nat]
    to [int]: *)

Extract Inductive nat => int [ "0" "succ" ]
                             "(fun fO fS n -> if n=0 then fO () else fS (n-1))".

Axiom toInt: nat -> Int32.

Extract Inlined Constant toInt => "".

Axiom toInt_def : forall n, toInt n = bitsToInt32 (# n).

Axiom fromInt: Int32 -> nat.

Extract Inlined Constant fromInt => "".

Axiom fromInt_def : forall n, fromInt n = toNat (bitsFromInt32 n).

(** ** Equality *)

Lemma eq_repr: forall i i' E E', machine_repr i E -> machine_repr i' E' -> (eq i i') = (E == E').
Proof.
  move=> i i' E E' [bv [Hbv1 Hbv2]] [bv' [Hbv'1 Hbv'2]].
  rewrite (axioms32.eq_repr _ _ bv bv')=> //.
  by rewrite -(@spec.eq_repr _ bv bv' E E').
Qed.

(** ** Zero *)

Lemma zero_repr:
  machine_repr zero set0.
Proof.
  exists (spec.zero wordsize).
  split.
  rewrite -fromNat0.
  apply zero_repr.
  exact: empty_repr.
Qed.

(** ** Singleton *)

Definition singleton (x: 'I_wordsize) :=
  lsl one (toInt x).

Lemma singleton_repr:
  forall (x: 'I_wordsize),
    machine_repr (singleton x) [set x].
Proof.
  move=> x.
  exists (shlBn #1 x).
  split.
  * apply lsl_repr=> //.
    apply (leq_trans (n := x.+1))=> //.
    apply one_repr.
    apply/existsP; exists # (x); apply/andP; split=> //.
    apply/eqInt32P.
    rewrite toInt_def=> //.
  * rewrite getBit_shlBn=> //.
    apply singleton_repr.
Qed.

(** ** Left & right shift *)

Lemma sl_repr:
  forall i E, machine_repr i E ->
    machine_repr (lsl i one) [set i : 'I_wordsize | 0 < i & @inord wordsize.-1 i.-1 \in E].
Proof.
  move=> i E [bv [r_native r_set]].
  exists (shlBn bv 1); split.
  * apply: lsl_repr=> //.
    apply/existsP; eexists; apply/andP; split; first by apply one_repr.
    done.
  * have H: wordsize = wordsize.-1.+1 by compute.
    have ->: [set i0 : 'I_wordsize | 0 < i0 & inord i0.-1 \in E]
           = [set i0 : 'I_wordsize | 0 < i0 & cast_ord H (inord i0.-1) \in E].
      rewrite -setP /eq_mem=> x.
      rewrite !in_set.
      have ->: cast_ord H (inord x.-1) = inord x.-1.
        apply ord_inj.
        by rewrite nat_cast_ord.
      by rewrite //.
    by apply shift.sl_repr.
Qed.

Lemma sr_repr:
  forall i E, machine_repr i E ->
    machine_repr (lsr i one) [set i : 'I_wordsize | i < wordsize.-1 & @inord wordsize.-1 i.+1 \in E].
Proof.
  move=> i E [bv [r_native r_set]].
  exists (shrBn bv 1); split.
  * apply: lsr_repr=> //.
    apply/existsP; eexists; apply/andP; split; first by apply one_repr.
    done.
  * have H: wordsize = wordsize.-1.+1 by compute.
    have ->: [set i0 : 'I_wordsize | i0 < wordsize.-1 & inord i0.+1 \in E]
           = [set i0 : 'I_wordsize | i0 < wordsize.-1 & cast_ord H (inord i0.+1) \in E].
      rewrite -setP /eq_mem=> x.
      rewrite !in_set.
      have ->: cast_ord H (inord x.+1) = inord x.+1.
        apply ord_inj.
        by rewrite nat_cast_ord.
      by rewrite //.
    by apply shift.sr_repr.
Qed.

(** ** Complement *)

Definition compl (bs: Int32): Int32 := lnot bs.
Lemma compl_repr: forall i E,
    machine_repr i E -> machine_repr (compl i) (~: E).
Proof.
  move=> i E [bv [r_native r_set]].
  exists (invB bv); split.
  * rewrite /compl; apply lnot_repr => //.
  * apply compl.compl_repr => //.
Qed.

(** ** Set creation *)

Definition create (b: bool): Int32
  := if b then dec (toInt 0) else (toInt 0).

Lemma create_repr:
  forall (b: bool),
    machine_repr (create b) (if b then [ set : 'I_wordsize ] else set0).
Proof.
  move=> b.
  exists (create.create b). split; last first.
  * apply create.create_repr => //.
  * rewrite /create/create.create; case: b.
    + (* Case: b ~ true *)
      apply dec_repr.
      by rewrite toInt_def;
         apply/eqInt32P.
    + (* Case: b ~ false *)
      by rewrite toInt_def; apply/eqInt32P.
Qed.

(** ** Querying *)

Definition get (bs: Int32) (k: 'I_wordsize): bool
  := eq (land (lsr bs (toInt k)) one) one.

Lemma get_repr:
  forall i E (k: 'I_wordsize), machine_repr i E ->
    get i k = (k \in E).
Proof.
  move=> i E k H.
  rewrite /get.
  move: H=> [bv [Hbv1 Hbv2]].
  rewrite (axioms32.eq_repr _ _ (andB (shrBn bv k) #1) #1);
    last by apply one_repr.
  apply get.get_repr=> //.
  apply land_repr;
     last by apply one_repr.
  apply lsr_repr=> //.
  apply (leq_trans (n := k.+1))=> //.
  apply/existsP; exists # (k); apply/andP; split=> //.
  rewrite toInt_def.
  by apply/eqInt32P.
Qed.

(** ** Intersection *)

Definition inter (bs: Int32) (bs': Int32): Int32
  := land bs bs'.

Lemma inter_repr:
  forall i i' E E', machine_repr i E -> machine_repr i' E' ->
    machine_repr (inter i i') (E :&: E').
Proof.
  move=> i i' E E' H H'.
  rewrite /machine_repr.
  move: H=> [bv [Hbv1 Hbv2]].
  move: H'=> [bv' [Hbv'1 Hbv'2]].
  exists (inter.inter bv bv').
  split.
  apply land_repr=> //.
  exact: inter.inter_repr.
Qed.

(** ** Minimal element *)

Definition keep_min (bs: Int32): Int32
  := land bs (neg bs).

Lemma keep_min_repr:
  forall i E x, machine_repr i E -> x \in E ->
    machine_repr (keep_min i) [set [arg min_(k < x in E) k]].
Proof.
  move=> i E x H Hx.
  move: H=> [bv [Hbv1 Hbv2]].
  exists (keep_min.keep_min bv).
  split.
  apply land_repr=> //.
  apply neg_repr=> //.
  by apply keep_min.keep_min_repr.
Qed.

(** ** Insertion *)

Definition insert (bs: Int32) k: Int32
  := lor bs (lsl (toInt 1) k).

Lemma insert_repr:
  forall i (k: 'I_wordsize) E, machine_repr i E ->
    machine_repr (insert i (toInt k)) (k |: E).
Proof.
  move=> i k E [bv [Hbv1 Hbv2]].
  exists (insert.insert bv k).
  split.
  rewrite /insert /insert.insert.
  apply lor_repr=> //.
  apply lsl_repr=> //.
  apply (leq_trans (n := k.+1))=> //.
  + by rewrite toInt_def; apply/eqInt32P.
  + rewrite toInt_def; apply/existsP; exists # (k); apply/andP; split=> //.
    by apply/eqInt32P.
  by apply insert.insert_repr.
Qed.

(** ** Removal *)
Definition remove (bs: Int32) k: Int32
  := land bs (lnot (lsl (toInt 1) k)).

Lemma remove_repr:
  forall i (k: 'I_wordsize) E, machine_repr i E ->
    machine_repr (remove i (toInt k)) (E :\ k).
Proof.
  move=> i k E [bv [Hbv1 Hbv2]].
  exists (remove.remove bv k).
  split.
  rewrite /remove /remove.remove.
  apply land_repr=> //.
  apply lnot_repr=> //.
  apply lsl_repr=> //.
  apply (leq_trans (n := k.+1))=> //.
  by rewrite toInt_def; apply/eqInt32P.
  rewrite toInt_def; apply/existsP; exists # (k); apply/andP; split=> //.
    by apply/eqInt32P.
  by apply remove.remove_repr.
Qed.

(** ** Symmetrical difference *)

Definition symdiff (bs: Int32) (bs': Int32): Int32
  := lxor bs bs'.

Lemma symdiff_repr:
  forall i i' E E', machine_repr i E -> machine_repr i' E' ->
    machine_repr (symdiff i i') ((E :\: E') :|: (E' :\: E)).
Proof.
  move=> i i' E E' [bv [Hbv1 Hbv2]] [bv' [Hbv'1 Hbv'2]].
  exists (symdiff.symdiff bv bv').
  split.
  apply lxor_repr=> //.
  by apply symdiff.symdiff_repr.
Qed.

(** ** Union *)

Definition union (bs bs': Int32): Int32
  := lor bs bs'.

Lemma union_repr:
  forall i i' E E', machine_repr i E -> machine_repr i' E' ->
    machine_repr (union i i') (E :|: E').
Proof.
  move=> i i' E E' [bv [Hbv1 Hbv2]] [bv' [Hbv'1 Hbv'2]].
  exists (union.union bv bv').
  split.
  apply lor_repr=> //.
  by apply union.union_repr.
Qed.

(** ** Subset *)

Lemma subset_repr: forall (bs bs': Int32) E E',
  machine_repr bs E -> machine_repr bs' E' ->
    (eq (land bs bs') bs) =
      (E \subset E').
Proof.
  move=> bs bs' E E' HE HE'.
  rewrite (eq_repr _ _ (E :&: E') E)=> //.
  apply/eqP.
  case: setIidPl=> //=.
  apply inter_repr=> //.
Qed.

(** ** Cardinality *)

Lemma fromInt_inj: forall x y,
  fromInt x = fromInt y -> x = y.
Proof.
  move=> x y H.
  rewrite !fromInt_def in H.
  apply toNat_inj in H.
  by apply bitsFromInt32_inj in H.
Qed.

Module Int_as_OT <: OrderedType.

  Definition t := Int32.

  Definition eq x y : Prop := (fromInt x) = (fromInt y).

  Definition lt x y : Prop := (fromInt x) < (fromInt y).
  Definition eq_refl x := @Logic.eq_refl nat (fromInt x).
  Definition eq_sym x y := @Logic.eq_sym nat (fromInt x) (fromInt y).
  Definition eq_trans x y z := @Logic.eq_trans nat (fromInt x) (fromInt y) (fromInt z).

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
  move=> x y z H1 H2.
  rewrite /lt.
  apply (ltn_trans (n := fromInt y)).
  apply H1.
  apply H2.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  move=> x y H.
  rewrite /lt in H.
  move=> Habs.
  move/eqP: Habs=> Habs.
  by rewrite ltn_eqF in Habs.
  Qed.

  Definition compare x y : Compare lt eq x y.
  Proof.
    case_eq (nat_compare (fromInt x) (fromInt y)); intro.
    - apply EQ.
      by apply nat_compare_eq.
    - apply LT.
      apply/ltP.
      by apply nat_compare_Lt_lt.
    - apply GT.
      apply/ltP.
      by apply nat_compare_Gt_gt.
  Qed.

  Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
    move=> x y.
    by apply eq_nat_dec.
  Qed.

End Int_as_OT.

Module M := FMapList.Make(Int_as_OT).

Definition tableSize := 4.

Fixpoint pop_tableAux (i: nat) (m: M.t Int32) :=
  match i with
  | 0 => M.add zero zero m
  | i'.+1 => M.add (toInt i) (toInt (count_mem true (fromNat (n := tableSize) i))) (pop_tableAux i' m)
  end.

Definition pop_table := pop_tableAux (2 ^ tableSize) (M.empty Int32).

Definition pop_elem (bs: Int32)(i: nat): Int32
  := let x := land (lsr bs (toInt (i * tableSize)))
                            (dec (lsl one (toInt tableSize))) in
     match (M.find x pop_table) with
     | None => zero
     | Some x => x
     end.

Lemma pop_elem_repr:
  forall n bs i,
    i * tableSize <= wordsize ->
    native_repr n bs ->
    native_repr (pop_elem n i) (cardinal.pop_elem tableSize bs i).
Proof.
  move=> n bs i ? ?.
  rewrite /pop_elem/cardinal.pop_elem.
  rewrite /cardinal.pop_table.
  rewrite nth_mkseq.
  set i' := land (lsr n (toInt (i * tableSize))) (dec (lsl one (toInt tableSize))).
  rewrite (M.find_1 (e := toInt (count_mem true (fromNat (n := tableSize) (fromInt i'))))).
  have ->: fromInt i' = toNat (andB (shrBn bs (i * tableSize)) (decB (shlBn # (1) tableSize))).
    rewrite fromInt_def.
    have ->: bitsFromInt32 i' = andB (shrBn bs (i * tableSize)) (decB (shlBn # (1) tableSize)).
      apply/eqP.
      rewrite -eq_adj.
      have H: native_repr i' (andB (shrBn bs (i * tableSize)) (decB (shlBn # (1) tableSize))).
        apply land_repr.
        apply lsr_repr=> //.
        rewrite /natural_repr.
        apply/existsP.
        exists # (i * tableSize).
        rewrite /native_repr.
        rewrite toInt_def.
        rewrite eq_refl andbT.
        by apply/eqInt32P.
        apply dec_repr.
        apply lsl_repr.
        rewrite //.
        apply one_repr.
        (* TODO: add a lemma 'natural_repr (toInt x) x'? *)
        rewrite /natural_repr.
        apply/existsP.
        exists #tableSize.
        rewrite eq_refl andbT.
        rewrite /native_repr toInt_def.
        by apply/eqInt32P.
      by apply H.
    rewrite //.
  rewrite toInt_def.
  apply/eqInt32P=> //.
  rewrite /pop_table /pop_tableAux [_ (2^tableSize) _]/=.
  admit. (* Trivial, but painful *)
  by apply toNat_andB.
Admitted.

Fixpoint popAux (bs: Int32)(i: nat): Int32 :=
  match i with
  | 0 => zero
  | i'.+1 => add (pop_elem bs i') (popAux bs i')
  end.

Definition popAux_repr:
  forall n bs i,
    i * tableSize <= wordsize ->
    native_repr n bs ->
    native_repr (popAux n i) (cardinal.popAux tableSize bs i).
Proof.
  move=> n bs i Hi ?.
  elim: i Hi=> [Hi //=|i IH Hi].
  rewrite -fromNat0.
  apply axioms32.zero_repr.
  have Hi': i * tableSize <= wordsize.
    apply (leq_trans (n := i.+1 * tableSize))=> //.
    rewrite leq_pmul2r=> //.
  apply add_repr=> //.
  apply (pop_elem_repr _ bs)=> //.
  by apply IH.
Qed.

Definition cardinal (bs: Int32): Int32
  := popAux bs (wordsize %/ tableSize).

Lemma cardinal_repr:
  forall (bs: Int32) E, machine_repr bs E ->
    natural_repr (cardinal bs) #|E|.
Proof.
  move=> bs E [bv [int_repr fin_repr]].
  rewrite /natural_repr.
  apply/existsP.
  exists # (#|E|).
  apply/andP; split=> //.
  rewrite - (@cardinal.cardinal_repr _ tableSize bv) => //.
  (* Refold [cardinal], for the proof's sake (and my sanity) *)
  rewrite -[cardinal _]/(popAux bs (wordsize %/ tableSize)).
  rewrite /cardinal.cardinal -[div.divn _ _]/(wordsize %/ tableSize).
  by apply (popAux_repr _ bv).
Qed.

(* TODO: what do we use this one for? *)

Definition ntz (bs: Int32): Int32
  := add (toInt wordsize) (neg (cardinal (lor bs (neg bs)))).

Lemma ntz_repr:
  forall (bs: Int32) x E, machine_repr bs E -> x \in E ->
    natural_repr (ntz bs) [arg min_(k < x in E) k].
Proof.
  move=> bs x E [bv [Hbv1 Hbv2]] Hx.
  rewrite /natural_repr.
  apply/existsP.
  exists #[arg min_(k < x in E) k].
  rewrite -(@min.ntz_repr _ bv tableSize)=> //.
  rewrite /ntz /min.ntz.
  set E' := [ set x : 'I_wordsize | getBit (min.fill_ntz bv) x ].
  have H: repr (orB bv (negB bv)) E'.
    rewrite /repr -setP /eq_mem=> i.
    by rewrite !in_set min.fill_ntz_repr.
  apply/andP.
  split=> //.
  rewrite subB_equiv_addB_negB.
  apply add_repr.
  rewrite toInt_def.
  apply/eqInt32P=> //.
  apply neg_repr.
  move: (cardinal.cardinal_repr _ tableSize (orB bv (negB bv)) E')=> H'.
  rewrite H'.
  have Hok: machine_repr (lor bs (neg bs)) E'.
    exists (orB bv (negB bv)).
    split.
    apply lor_repr.
    apply Hbv1.
    apply neg_repr.
    apply Hbv1.
    by apply H.
  move: (cardinal_repr (lor bs (neg bs)) E' Hok)=> /existsP[y /andP[Hy1 /eqP Hy2]].
  rewrite -Hy2 in Hy1.
  apply Hy1.
  trivial.
  trivial.
  trivial.
Qed.

(** printing \emptyset $\emptyset$ #Ø# *)
(** printing \cap $\cap$ #∩# *)
(** printing \cup $\cup$ #∪# *)

(** Module type describing set operations & implementations using bitsets and finsets *)
Module Type SET.
  Parameter T : Type.
  Parameter eq : T -> T -> bool.
  Infix "=" := eq : SET_scope.
  Open Scope SET_scope.
  Bind Scope SET_scope with T.
  Parameter empty : T.
  Notation "\emptyset" := empty : SET_scope.
  Parameter singleton : 'I_wordsize -> T.
  Notation "{ x }" := (singleton x) : SET_scope.
  Parameter compl : T -> T.
  Notation "~ E" := (compl E) : SET_scope.
  Parameter create : bool -> T.
  Parameter get : T -> 'I_wordsize -> bool.
  Notation "x \in E" := (get E x) : SET_scope.
  Parameter inter : T -> T -> T.
  Notation "E1 \cap E2" := (inter E1 E2) (at level 0) : SET_scope.
  Parameter keep_min : forall (E: T) x, x \in E -> T.
  Notation "{ min E }" := (keep_min E) : SET_scope.
  Parameter insert : T -> 'I_wordsize -> T.
  Parameter remove : T -> 'I_wordsize -> T.
  Parameter symdiff : T -> T -> T.
  Notation "E1 \delta E2" := (symdiff E1 E2) (at level 0) : SET_scope.
  Parameter union : T -> T -> T.
  Notation "E1 \cup E2" := (union E1 E2) (at level 0) : SET_scope.
  Parameter cardinal : T -> nat.
  Notation "| E |" := (cardinal E) (at level 30) : SET_scope.
End SET.

Module Finset <: SET.
  Definition T := {set 'I_wordsize}.
  Definition eq (E: T) (E': T) := E == E'.
  Definition empty : T := set0.
  Definition singleton (x: 'I_wordsize) : T := [set x].
  Definition compl (E: T) := ~: E.
  Definition create b := if b then [ set : 'I_wordsize ] else set0.
  Definition get (E: T) x := x \in E.
  Definition inter (E1: T) E2 := E1 :&: E2.
  Definition keep_min (E: T) (x: 'I_wordsize) (Hx: get E x): T := [set [arg min_(k < x in E) k]].
  Definition insert (E: T) k := k |: E.
  Definition remove (E: T) k := E :\ k.
  Definition symdiff (E1: T) E2 := ((E2 :\: E1) :|: (E1 :\: E2)).
  Definition union (E1: T) E2 := E1 :|: E2.
  Definition cardinal (E: T) := #|E|.
End Finset.

Module Bitset <: SET.
  Definition T := Int32.
  Definition eq (E: T) (E': T) := eq E E'.
  Definition empty := zero.
  Definition singleton := singleton.
  Definition compl := compl.
  Definition create := create.
  Definition get := get.
  Definition inter := inter.
  Definition keep_min (E: T) (x: 'I_wordsize) (Hx: get E x): T := keep_min E.
  Definition insert E (x: 'I_wordsize) := insert E (toInt x).
  Definition remove E (x: 'I_wordsize) := remove E (toInt x).
  Definition symdiff := symdiff.
  Definition union := union.
  Definition cardinal (E: T) := fromInt (cardinal E).
End Bitset.


(** 直和型に関するモジュールです。 *)

Require Googology_In_Coq.Base.
Require Googology_In_Coq.Path.
Require Googology_In_Coq.Void.

(** ライブラリを要求します。 *)

Import Googology_In_Coq.Base.
Import Googology_In_Coq.Path.
Import Googology_In_Coq.Void.

(** ライブラリを開きます。 *)

Inductive Sum@{ i | } ( A : Type@{ i } ) ( B : Type@{ i } ) : Type@{ i } := left_Sum : A -> Sum A B | right_Sum : B -> Sum A B.
(* from: originally defined by Hexirp *)

(** 直和型です。 *)

Definition matching_Sum@{ i j | } ( A : Type@{ i } ) ( B : Type@{ i } ) ( P : Type@{ j } ) ( cl : A -> P ) ( cr : B -> P ) ( x : Sum A B ) : P := match x with left_Sum _ _ xl => cl xl | right_Sum _ _ xr => cr xr end.
(* from: originally defined by Hexirp *)

(** 直和型の場合分けです。 *)

Definition identity_matching_Sum@{ i j | } ( A : Type@{ i } ) ( B : Type@{ i } ) ( P : Type@{ j } ) ( display : P -> Sum A B ) ( cl : A -> P ) ( icl : forall xl : A, Path ( Sum A B ) ( display ( cl xl ) ) ( left_Sum A B xl ) ) ( cr : B -> P ) ( icr : forall xr : B, Path ( Sum A B ) ( display ( cr xr ) ) ( right_Sum A B xr ) ) ( x : Sum A B ) : Path ( Sum A B ) ( display ( matching_Sum A B P cl cr x ) ) x := match x as x_ return Path ( Sum A B ) ( display ( matching_Sum A B P cl cr x_ ) ) x_ with left_Sum _ _ xl => icl xl | right_Sum _ _ xr => icr xr end.
(* from: originally defined by Hexirp *)

(** 直和型の場合分けです。 *)

Definition dependent_matching_Sum@{ i j | } ( A : Type@{ i } ) ( B : Type@{ i } ) ( P : Sum A B -> Type@{ j } ) ( cl : forall xl : A, P ( left_Sum A B xl ) ) ( cr : forall xr : B, P ( right_Sum A B xr ) ) ( x : Sum A B ) : P x := match x as x_ return P x_ with left_Sum _ _ xl => cl xl | right_Sum _ _ xr => cr xr end.
(* from: originally defined by Hexirp *)

(** 直和型の依存場合分けです。 *)

Definition path_cons_Sum@{ i si | i < si } ( A : Type@{ i } ) ( B : Type@{ i } ) ( x : Sum A B ) ( y : Sum A B ) : Type@{ i }.
Proof.
  refine ( matching_Sum@{ i si } A B ( forall y_ : Sum A B, Type@{ i } ) _ _ x y ).
  -
    refine ( fun ( xl : A ) ( y_ : Sum A B ) => _ ).
    refine ( matching_Sum@{ i si } A B Type@{ i } _ _ y_ ).
    +
      refine ( fun yl : A => _ ).
      exact ( Path A xl yl ).
    +
      refine ( fun yr : B => _ ).
      exact Void@{ i }.
  -
    refine ( fun ( xr : B ) ( y_ : Sum A B ) => _ ).
    refine ( matching_Sum@{ i si } A B Type@{ i } _ _ y_ ).
    +
      refine ( fun yl : A => _ ).
      exact Void@{ i }.
    +
      refine ( fun yr : B => _ ).
      exact ( Path B xr yr ).
Defined.
(* from: originally defined by Hexirp *)

(** 直和型の構築子の道です。 *)

Definition from_path_cons_Sum@{ i si | i < si } ( A : Type@{ i } ) ( B : Type@{ i } ) ( x : Sum A B ) ( y : Sum A B ) ( p : path_cons_Sum@{ i si } A B x y ) : Path ( Sum A B ) x y.
Proof.
  refine ( dependent_matching_Sum A B ( fun x_ : Sum A B => forall ( y_ : Sum A B ) ( p_ : path_cons_Sum@{ i si } A B x_ y_ ), Path ( Sum A B ) x_ y_ ) _ _ x y p ).
  -
    refine ( fun ( xl : A ) ( y_ : Sum A B ) ( p_ : path_cons_Sum@{ i si } A B ( left_Sum A B xl ) y_ ) => _ ).
    refine ( dependent_matching_Sum A B ( fun y__ : Sum A B => forall p__ : path_cons_Sum@{ i si } A B ( left_Sum A B xl ) y__, Path ( Sum A B ) ( left_Sum A B xl ) y__ ) _ _ y_ p_ ).
    +
      refine ( fun yl : A => _ ).
      change ( path_cons_Sum@{ i si } A B ( left_Sum A B xl ) ( left_Sum A B yl ) -> Path ( Sum A B ) ( left_Sum A B xl ) ( left_Sum A B yl ) ).
      change ( Path A xl yl -> Path ( Sum A B ) ( left_Sum A B xl ) ( left_Sum A B yl ) ).
      refine ( fun p__ : Path A xl yl => _ ).
      exact ( ap_Path A ( Sum A B ) ( left_Sum A B ) xl yl p__ ).
    +
      refine ( fun yr : B => _ ).
      change ( path_cons_Sum@{ i si } A B ( left_Sum A B xl ) ( right_Sum A B yr ) -> Path ( Sum A B ) ( left_Sum A B xl ) ( right_Sum A B yr ) ).
      change ( Void@{ i } -> Path ( Sum A B ) ( left_Sum A B xl ) ( right_Sum A B yr ) ).
      refine ( fun p__ : Void@{ i } => _ ).
      exact ( absurd_Void ( Path ( Sum A B ) ( left_Sum A B xl ) ( right_Sum A B yr ) ) p__ ).
  -
    refine ( fun ( xr : B ) ( y_ : Sum A B ) ( p_ : path_cons_Sum@{ i si } A B ( right_Sum A B xr ) y_ ) => _ ).
    refine ( dependent_matching_Sum A B ( fun y__ : Sum A B => forall p__ : path_cons_Sum@{ i si } A B ( right_Sum A B xr ) y__, Path ( Sum A B ) ( right_Sum A B xr ) y__ ) _ _ y_ p_ ).
    +
      refine ( fun yl : A => _ ).
      change ( path_cons_Sum@{ i si } A B ( right_Sum A B xr ) ( left_Sum A B yl ) -> Path ( Sum A B ) ( right_Sum A B xr ) ( left_Sum A B yl ) ).
      change ( Void@{ i } -> Path ( Sum A B ) ( right_Sum A B xr ) ( left_Sum A B yl ) ).
      refine ( fun p__ : Void@{ i } => _ ).
      exact ( absurd_Void ( Path ( Sum A B ) ( right_Sum A B xr ) ( left_Sum A B yl ) ) p__ ).
    +
      refine ( fun yr : B => _ ).
      change ( path_cons_Sum@{ i si } A B ( right_Sum A B xr ) ( right_Sum A B yr ) -> Path ( Sum A B ) ( right_Sum A B xr ) ( right_Sum A B yr ) ).
      change ( Path B xr yr -> Path ( Sum A B ) ( right_Sum A B xr ) ( right_Sum A B yr ) ).
      refine ( fun p__ : Path B xr yr => _ ).
      exact ( ap_Path B ( Sum A B ) ( right_Sum A B ) xr yr p__ ).
Defined.
(* from: originally defined by Hexirp *)

(** 直和型の構築子の道から直和型の道を作る関数です。 *)

Definition map_Sum@{ i j | } ( A : Type@{ i } ) ( B : Type@{ i } ) ( C : Type@{ j } ) ( D : Type@{ j } ) ( f : A -> C ) ( g : B -> D ) : Sum A B -> Sum C D := matching_Sum A B ( Sum C D ) ( fun xl : A => left_Sum C D ( f xl ) ) ( fun xr : B => right_Sum C D ( g xr ) ).
(* from: originally defined by Hexirp *)

(** 直和型の写像です。 *)


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section RequestVoteReplyMoreUpToDate.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition requestVoteReply_moreUpToDate (net : network) : Prop :=
    forall t h h' p,
      currentTerm (snd (nwState net h)) = t ->
      type (snd (nwState net h)) = Candidate ->
      In p (nwPackets net) ->
      pBody p = RequestVoteReply t true ->
      pDst p = h ->
      pSrc p = h' ->
      exists vl,
        moreUpToDate (maxTerm (log (snd (nwState net h)))) (maxIndex (log (snd (nwState net h))))
                     (maxTerm vl) (maxIndex vl) = true /\
        In (t, h, vl) (votesWithLog (fst (nwState net h'))).

  Class requestVoteReply_moreUpToDate_interface : Prop :=
    {
      requestVoteReply_moreUpToDate_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          requestVoteReply_moreUpToDate net
    }.
End RequestVoteReplyMoreUpToDate.


From stdpp Require Import gmap.
From iris.bi Require Import bi.
From cgraphs Require Import util.

Ltac qed := done || eauto || naive_solver lia || set_solver.
Definition uforest A `{Countable A} := gset (A * A).

Section uforest.
  Context `{Countable A}.
  Context `{Inhabited A}.
  Notation G := (uforest A).
  Notation P := (list A).

  Definition path (g : G) (xs : P) :=
    ∀ i a b, xs !! i = Some a -> xs !! (i+1) = Some b -> (a,b) ∈ g.

  Definition undirected (g : G) :=
    ∀ x y, (x,y) ∈ g → (y,x) ∈ g.

  Definition no_self_loops (g : G) :=
    ∀ x, (x,x) ∉ g.

  Definition has_u_turn (xs : P) :=
    ∃ i x, xs !! i = Some x ∧ xs !! (i+2) = Some x.

  Record is_uforest (g : G) : Prop := {
    forest_undirected : undirected g;
    forest_u_turns : ∀ x xs, path g ([x] ++ xs ++ [x]) -> has_u_turn ([x] ++ xs ++ [x])
  }.

  Lemma forest_no_self_loops (g : G) :
    is_uforest g -> no_self_loops g.
  Proof.
    intros Hforest x Hx.
    destruct (forest_u_turns g Hforest x []) as (i & a & H1 & H2).
    - simpl. intros i a b.
      destruct i; simpl.
      + qed.
      + destruct i; qed.
    - simpl in *.
      destruct i; simpl in *; simplify_eq.
      destruct i; simpl in *; simplify_eq.
  Qed.

  Lemma has_u_turn_reverse (xs : P) :
    has_u_turn (reverse xs) -> has_u_turn xs.
  Proof.
    intros (i & x & Hx1 & Hx2).
    assert (i+2 < length xs).
    {
      apply lookup_lt_Some in Hx2. rewrite reverse_length in Hx2. done.
    }
    apply lookup_reverse_Some in Hx1.
    apply lookup_reverse_Some in Hx2.
    exists (length xs - S (i + 2)), x.
    split. done.
    rewrite <- Hx1. f_equiv. lia.
  Qed.

  Lemma has_u_turn_reverse' (xs : P) :
    has_u_turn xs -> has_u_turn (reverse xs).
  Proof.
    intros HH. rewrite <-(reverse_involutive xs) in HH.
    by apply has_u_turn_reverse.
  Qed.

  (* NB. connected g a a <-> False *)
  Definition connected (g : G) (a b : A) := ∃ xs, path g ([a] ++ xs ++ [b]).

  Lemma path_reverse (g : G) (xs : P) :
    undirected g -> path g xs -> path g (reverse xs).
  Proof.
    unfold path. intros Hundir Hpath i a b H1 H2.
    apply lookup_reverse_Some_iff in H1 as [].
    apply lookup_reverse_Some_iff in H2 as [].
    apply Hundir.
    eapply Hpath. done.
    rewrite <- H1. f_equiv. lia.
  Qed.

  Lemma connected_sym (g : G) (a b : A) :
    undirected g -> connected g a b -> connected g b a.
  Proof.
    unfold connected.
    intros Hundir (xs & Hxs).
    exists (reverse xs).
    simpl. rewrite <-reverse_cons, <-reverse_snoc.
    apply path_reverse; done.
  Qed.

  Lemma path_app (g : G) (a : A) (xs ys : P) :
    path g (xs ++ [a]) -> path g ([a] ++ ys) -> path g (xs ++ [a] ++ ys).
  Proof.
    intros H1 H2 i x y Hx Hy.
    rewrite !lookup_app_lr in Hx.
    rewrite !lookup_app_lr in Hy.
    simpl in *.
    repeat (case_decide; try lia); unfold path in *.
    - eapply H1; rewrite lookup_app_lr; case_decide; (done || lia).
    - eapply H1; rewrite lookup_app_lr; case_decide; (done || lia).
    - replace (i + 1 - length xs - 1) with (i - length xs) in * by lia.
      eapply (H2 0).
      + simpl. rewrite-> lookup_singleton_Some in Hx. qed.
      + simpl. apply lookup_singleton_Some in Hx as []. rewrite H7 in Hy. done.
    - replace (i + 1 - length xs - 1) with ((i - length xs - 1) + 1) in * by lia.
      eapply (H2 (S (i - length xs - 1))); done.
  Qed.

  Lemma path_edge (g : G) (a b : A) :
    (a,b) ∈ g -> path g [a;b].
  Proof.
    intros Hedge i x y Hx Hy.
    destruct i; simpl in *; simplify_eq. done.
    destruct i; simpl in *; simplify_eq.
  Qed.

  Lemma connected_trans (g : G) (a b c : A) :
    connected g a b -> connected g b c -> connected g a c.
  Proof.
    intros (xs & Hxs) (ys & Hys).
    exists (xs ++ [b] ++ ys).
    replace ([a] ++ (xs ++ [b] ++ ys) ++ [c]) with (([a] ++ xs) ++ [b] ++ (ys ++ [c])).
    - apply path_app; rewrite <-?app_assoc; done.
    - rewrite !app_assoc. done.
  Qed.

  Definition uedge (x y : A) : uforest A := {[ (x,y); (y,x) ]}.

  Lemma edge_sym x y : uedge x y = uedge y x.
  Proof. unfold uedge. set_solver. Qed.

  Lemma path_delete (g : G) (a b : A) (xs : P) :
    path (g ∖ uedge a b) xs -> path g xs.
  Proof.
    intros Hpath i x y Hx Hy.
    unfold path in *.
    specialize (Hpath i x y Hx Hy).
    rewrite-> elem_of_difference in Hpath.
    destruct Hpath. done.
  Qed.

  Lemma has_u_turn_dec (xs : P) :
    Decision (has_u_turn xs).
  Proof.
    induction xs.
    - right. intros (i & xs & H1 & H2). destruct i; simpl in *; simplify_eq.
    - destruct IHxs.
      + left. destruct h as (i & x & H1 & H2).
        exists (i+1),x.
        replace (i+1) with (S i) by lia. simpl. split;done.
      + destruct xs.
        { right. intros (i & x & H1 & H2). destruct i; simpl in *; simplify_eq. }
        destruct xs.
        { right. intros (i & x & H1 & H2). do 2 try destruct i; simpl in *; simplify_eq. }
        destruct (decide (a = a1)).
        * left. exists 0,a; simpl. subst. split;done.
        * right. intros (i & x & H1 & H2).
          destruct i; simpl in *; simplify_eq.
          apply n. exists i,x. split;done.
  Qed.

  Theorem list_length_ind {T} (P : list T -> Prop): (∀ xs, (∀ l, length l < length xs -> P l) -> P xs) -> ∀ xs, P xs.
  Proof.
    intros H'.
    assert (∀ xs l : list T, length l <= length xs -> P l) as Hind.
    { induction xs; intros l Hlen; apply H'; intros l0 H0'.
      - inversion Hlen. lia.
      - apply IHxs. simpl in Hlen. lia.
    }
    intros xs.
    eapply (Hind xs). lia.
  Qed.

  Lemma path_sub_r (g : G) (xs ys : P) :
    path g (xs ++ ys) -> path g ys.
  Proof.
    intros Hpath i x y Hx Hy.
    apply (Hpath (i + length xs)); rewrite lookup_app_r; try lia.
    - replace (i + length xs - length xs) with i by lia. done.
    - replace (i + length xs + 1 - length xs) with (i + 1) by lia. done.
  Qed.

  Lemma edge_undirected a b : undirected (uedge a b).
  Proof.
    intros x y HH.
    unfold uedge in *. set_solver.
  Qed.

  Lemma path_cons (g : G) (a b : A) (xs : P) :
    (a,b) ∈ g -> path g (b :: xs) -> path g (a :: b :: xs).
  Proof.
    intros Hedge Hpath i x y Hx Hy.
    destruct i; simpl in *; simplify_eq. done.
    eapply Hpath; done.
  Qed.

  Lemma path_remove_mid (g : G) (x : A) (i j : nat) (xs : P) :
    i <= j -> xs !! i = Some x -> xs !! j = Some x ->
    path g xs -> path g (take i xs ++ drop j xs).
  Proof.
    intros Hle Hi Hj Hpath.
    intros k a b Ha Hb.
    unfold path in *.
    rewrite lookup_app_lr in Ha.
    rewrite lookup_app_lr in Hb.
    repeat case_decide; try lia.
    - apply lookup_take_Some in Ha.
      apply lookup_take_Some in Hb.
      eauto.
    - assert (k+1 = length (take i xs)) by lia.
      clear H1 H2.
      replace (k + 1 - length (take i xs)) with 0 in Hb by lia.
      rewrite ->take_length_le in H3 by (apply lookup_lt_Some in Hi; lia).
      apply lookup_take_Some in Ha. subst.
      rewrite lookup_drop in Hb.
      replace (j + 0) with j in Hb by lia.
      assert (x = b) as -> by qed.
      eapply Hpath; eauto.
    - rewrite lookup_drop in Ha.
      rewrite lookup_drop in Hb.
      replace (j + (k + 1 - length (take i xs))) with
              (j + (k - length (take i xs)) + 1) in Hb by lia.
      eapply Hpath; eauto.
  Qed.

  Lemma connected_no_u_turn (g : G) (a b : A) (xs : P) :
    a≠b -> path g ([a] ++ xs ++ [b]) -> ∃ xs', path g ([a] ++ xs' ++ [b]) ∧ ¬ has_u_turn ([a] ++ xs' ++ [b]).
  Proof.
    intros Hneq.
    induction xs using list_length_ind.
    intros Hpath.
    destruct (has_u_turn_dec ([a] ++ xs ++ [b])); eauto.
    destruct h as (i & x & Hs1 & Hs2).
    destruct i.
    - simpl in *. simplify_eq. destruct xs. simpl in *; simplify_eq.
      simpl in *. destruct xs; simpl in *; simplify_eq.
      eapply (H1 xs). lia.
      replace (x :: a :: x :: xs ++ [b]) with ([x;a] ++ x :: xs ++ [b]) in Hpath by set_solver.
      eapply path_sub_r. done.
    - simpl in *.
      rewrite lookup_app_l in Hs1.
      2: { apply lookup_lt_Some in Hs2. rewrite app_length in Hs2. simpl in *. lia. }
      eapply (H1 (take i xs ++ drop (i+2) xs)).
      {
        rewrite app_length.
        rewrite drop_length.
        rewrite take_length_le.
        { apply lookup_lt_Some in Hs2. rewrite app_length in Hs2. simpl in *. lia. }
        apply lookup_lt_Some in Hs1. lia.
      }
      rewrite !app_comm_cons.
      rewrite <-firstn_cons.
      rewrite <-app_assoc.
      rewrite <-drop_app_le.
      2: { apply lookup_lt_Some in Hs2; rewrite app_length in Hs2; simpl in *; lia. }
      replace (take (S i) (a :: xs)) with ((take (S i) (a :: xs ++ [b]))).
      2: { rewrite-> app_comm_cons, take_app_le. done. simpl. apply lookup_lt_Some in Hs1. lia. }
      replace (drop (i + 2) (xs ++ [b])) with (drop (i + 3) (a :: xs ++ [b])).
      2: { replace (i+3) with (S (i+2)) by lia. simpl. done. }
      eapply path_remove_mid; try done; try lia.
      + simpl. rewrite lookup_app_l. done. apply lookup_lt_Some in Hs1. lia.
      + replace (i+3) with (S (i+2)) by lia. simpl. done.
  Qed.

  Lemma find_first_edge (xs : P) (a b : A) :
    (∃ i, xs !! i = Some a ∧ xs !! S i = Some b ∧
      ∀ j, j < i -> ¬ (xs !! j = Some a ∧ xs !! S j = Some b)) ∨
    (∀ i, ¬ (xs !! i = Some a ∧ xs !! S i = Some b)).
  Proof.
    induction xs.
    { right. intros i []. destruct i; simplify_eq. }
    destruct xs; simpl in *.
    { right. intros i []. destruct i; simplify_eq.  }
    destruct (decide (a0 = a ∧ a1 = b)).
    { left. exists 0. qed. }
    destruct IHxs.
    - left. destruct H1 as (i & Ha & Hb & Hlow).
      exists (S i). simpl. split. done. split. done.
      intros j Hj.
      intros []. apply n.
      destruct j; simpl in *. qed.
      specialize (Hlow j).
      assert (j < i) as Q by lia.
      specialize (Hlow Q).
      exfalso.
      apply Hlow. done.
    - right. intros i [].
      destruct i; simpl in *. qed.
      specialize (H1 i). apply H1.
      done.
  Qed.

  Definition has_edge (xs : P) a b i :=
    (xs !! i = Some a ∧ xs !! (i + 1) = Some b) ∨
    (xs !! i = Some b ∧ xs !! (i + 1) = Some a).

  Lemma has_edge_dec xs a b i : Decision (has_edge xs a b i).
  Proof. solve_decision. Qed.

  Lemma has_edge_sym xs a b i :
    has_edge xs a b i <-> has_edge xs b a i.
  Proof.
    unfold has_edge. qed.
  Qed.

  Lemma find_first_has_edge (xs : P) (a b : A) :
    (∃ i, has_edge xs a b i ∧ ∀ j, j < i -> ¬ has_edge xs a b j)
    ∨ (∀ i, ¬ has_edge xs a b i).
  Proof.
    induction xs; simpl.
    { right. intros i HH. unfold has_edge in *. destruct i; simpl in *; qed. }
    destruct xs.
    { right. intro. unfold has_edge. replace (i + 1) with (S i) by lia; simpl. destruct i; simpl; qed. }
    destruct (decide ((a0 = a ∧ a1 = b) ∨ (a0 = b ∧ a1 = a))).
    {
      left. exists 0. split; intros; try lia.
      unfold has_edge. simpl. qed.
    }
    destruct IHxs.
    {
      left. destruct H1 as (i & Hi1 & Hi2). exists (S i).
      split.
      - unfold has_edge. simpl. unfold has_edge in Hi1. qed.
      - intros. destruct j.
        + unfold has_edge. simpl. qed.
        + unfold has_edge in *. simpl.
          assert (j < i) as QQ by lia.
          specialize (Hi2 _ QQ).
          qed.
    }
    right. intro. intro. unfold has_edge in *.
    destruct i; simpl in *; qed.
  Qed.

  Lemma has_edge_reverse xs a b i :
    has_edge (reverse xs) a b i -> has_edge xs a b (length xs - (i + 2)).
  Proof.
    unfold has_edge. intros [[]|[]];
    assert (i+1 < length xs) by (apply lookup_lt_Some in H2; rewrite reverse_length in H2; lia);
    apply lookup_reverse_Some in H1;
    apply lookup_reverse_Some in H2;
    rewrite <- H1; rewrite <- H2; [right | left]; split; f_equiv; lia.
  Qed.

  Lemma path_has_edge g a b xs :
    path (g ∪ uedge a b) xs -> (∀ i, ¬ has_edge xs a b i) ->
    path g xs.
  Proof.
    intros Hpath Hne i x y Hx Hy.
    specialize (Hpath i x y Hx Hy).
    apply elem_of_union in Hpath as []; first done.
    specialize (Hne i). contradict Hne.
    unfold has_edge. unfold uedge in H1.
    set_solver.
  Qed.

  Lemma path_take g i xs :
    path g xs -> path g (take i xs).
  Proof.
    intros Hpath j a b Ha Hb.
    apply lookup_take_Some in Ha.
    apply lookup_take_Some in Hb.
    eapply Hpath; done.
  Qed.

  Lemma path_drop g i xs :
    path g xs -> path g (drop i xs).
  Proof.
    intros Hpath j a b Ha Hb.
    rewrite lookup_drop in Ha.
    rewrite lookup_drop in Hb.
    rewrite Nat.add_assoc in Hb.
    eapply Hpath; done.
  Qed.

  Lemma has_edge_take a b j i xs :
    has_edge xs a b i ∧ i+1 < j <-> has_edge (take j xs) a b i.
  Proof.
    split.
    - intros [].
      destruct H1 as [[]|[]]; [left | right]; split;
      rewrite lookup_take; (done || lia).
    - intros [[]|[]];
      apply lookup_take_Some_iff in H1;
      apply lookup_take_Some_iff in H2; split; try lia; [left | right]; qed.
  Qed.

  Lemma has_edge_drop a b j i xs :
    has_edge xs a b i ∧ i >= j -> has_edge (drop j xs) a b (i - j).
  Proof.
    intros [].
    destruct H1 as [[]|[]]; [left | right]; split;
    rewrite lookup_drop; rewrite <-?H1, <-?H3; f_equiv; lia.
  Qed.

  Lemma connected_alt g a b :
    a≠b ->
      connected g a b <->
      ∃ xs, path g xs ∧ xs !! 0 = Some a ∧ last xs = Some b.
  Proof.
    intros Hneq.
    split.
    + intros [xs Hxs]. exists ([a] ++ xs ++ [b]).
      split; first done.
      split; first done.
      rewrite app_assoc.
      by rewrite last_snoc.
    + intros (xs & Hpath & Hxs1 & Hxs2).
      assert (length xs > 1).
      { destruct xs; simplify_eq. destruct xs; simpl in *; simplify_eq. lia.  }
      apply split_last in Hxs2.
      rewrite Hxs2 in Hxs1.
      apply split_first in Hxs1.
      rewrite drop_app_le in Hxs1.
      exists (drop 1 (take (length xs - 1) xs)).
      by rewrite <-Hxs1, <-Hxs2.
      destruct xs; simpl in *. simplify_eq.
      destruct xs; simpl in *; try lia.
  Qed.

  (* Hiding this in a definition is necessary because otherwise the wlog tactic
     will generalize over the Lookup instance.
     This way the wlog tactic can not peek inside the proposition and won't find any
     Lookup instance as a subterm. *)
  Definition bar (xs : P) x i1 a b :=
    ([x] ++ xs ++ [x]) !! i1 = Some a ∧ ([x] ++ xs ++ [x]) !! (i1 + 1) = Some b.

  Definition connected0 g a b := (a = b) ∨ connected g a b.

  Lemma path_singleton g b : path g [b].
  Proof.
    intros i x y Hx Hy. destruct i; simplify_eq.
  Qed.

  Lemma connected0_alt g a b :
    connected0 g a b <->
    ∃ xs, path g xs ∧ xs !! 0 = Some a ∧ last xs = Some b.
  Proof.
    destruct (decide (a = b)).
    - unfold connected0. split; eauto. intros _. subst.
      exists [b]. eauto using path_singleton.
    - unfold connected0. rewrite connected_alt; qed.
  Qed.

  Lemma last_cons {T} (x : T) xs z :
    last xs = Some z ->
    last (x :: xs) = Some z.
  Proof.
    induction xs; simpl; intros; simplify_eq. done.
  Qed.

  Lemma connected0_sym g a b :
    undirected g -> connected0 g a b -> connected0 g b a.
  Proof.
    unfold connected0.
    intros Hundir []; eauto. right.
    apply connected_sym; eauto.
  Qed.

  Lemma connected0_trans g a b c :
    connected0 g a b -> connected0 g b c -> connected0 g a c.
  Proof.
    intros []; subst; first done.
    intros []; subst.
    { unfold connected0. eauto. }
    right. eapply connected_trans; done.
  Qed.

  Lemma split_both (xs : P) a :
    length xs > 1 -> xs !! 0 = Some a -> last xs = Some a ->
    xs = [a] ++ drop 1 (take (length xs - 1) xs) ++ [a].
  Proof.
    intros Hlen H1 H2.
    apply split_last in H2.
    rewrite H2 in H1.
    apply split_first in H1.
    rewrite drop_app_le in H1; first by rewrite <-H1.
    rewrite take_length. lia.
  Qed.

  Lemma has_u_turn_alt (g : G) xs x :
    is_uforest g -> path g xs -> length xs > 1 ->
    xs !! 0 = Some x -> last xs = Some x ->
    has_u_turn xs.
  Proof.
    intros Hforest Hpath Hlen H1 H2.
    pose proof (split_both xs x Hlen H1 H2).
    rewrite H3. rewrite H3 in Hpath.
    destruct Hforest; eauto.
  Qed.

  Lemma has_u_turn_drop xs i :
    has_u_turn (drop i xs) -> has_u_turn xs.
  Proof.
    intros [j [x HH]].
    rewrite !lookup_drop in HH.
    rewrite Nat.add_assoc in HH.
    unfold has_u_turn. eauto.
  Qed.

  Lemma has_u_turn_take xs i :
    has_u_turn (take i xs) -> has_u_turn xs.
  Proof.
    intros [j [x []]].
    apply lookup_take_Some in H1.
    apply lookup_take_Some in H2.
    unfold has_u_turn; eauto.
  Qed.

  Lemma has_u_turn_mid (g : G) xs i1 i2 x :
    is_uforest g -> path g (drop i1 (take (S i2) xs)) -> i1 < i2 ->
    xs !! i1 = Some x -> xs !! i2 = Some x ->
    has_u_turn xs.
  Proof.
    intros Hforest Hpath Hneq H1 H2.
    eapply has_u_turn_take.
    eapply has_u_turn_drop.
    eapply (has_u_turn_alt g (drop i1 (take (S i2) xs))); eauto.
    - rewrite drop_length. rewrite take_length. apply lookup_lt_Some in H2. apply lookup_lt_Some in H1. lia.
    - rewrite lookup_drop. apply lookup_take_Some_iff. split; last lia.
      rewrite<-H1. f_equiv. lia.
    - rewrite<-H2. rewrite last_drop. eapply last_take.
      + by apply lookup_lt_Some in H2.
      + rewrite take_length. apply lookup_lt_Some in H2. apply lookup_lt_Some in H1. lia.
  Qed.

  Lemma forest_connect (g : G) (a b : A) :
    is_uforest g -> ¬ connected0 g a b -> is_uforest (g ∪ uedge a b).
  Proof.
    intros [] Hnconn.
    constructor.
    { intros x y HH.
      apply elem_of_union.
      apply elem_of_union in HH as [].
      + left. apply forest_undirected0. done.
      + right. apply edge_undirected. done. }
    intros x xs Hpath.
    destruct (find_first_has_edge ([x] ++ xs ++ [x]) a b) as [(i1 & Hi1v & Hi1r)|H1].
    {
      (* Use wlog (a,b) here *)
      unfold has_edge in Hi1v.
      wlog: a b Hpath Hi1v Hi1r Hnconn / bar xs x i1 a b; unfold bar.
      {
        intros Hwlog.
        destruct Hi1v.
        { apply (Hwlog a b); eauto. }
        apply (Hwlog b a); eauto.
        - rewrite edge_sym. done.
        - intro. rewrite has_edge_sym. eauto.
        - contradict Hnconn. apply connected0_sym; eauto.
      }
      clear Hi1v. intros [Hi1vA Hi1vB].
      (* Now we are in the situation x .. a b ... x *)
      assert (path g (take (i1+1) ([x] ++ xs ++ [x]))) as Hpath1.
      {
        apply (path_has_edge g a b).
        - apply path_take. done.
        - intros j He.
          apply has_edge_take in He as [He Hle].
          assert (j < i1) by lia.
          eapply Hi1r; done.
      }
      destruct (find_first_has_edge (drop (i1 + 1) ([x] ++ xs ++ [x])) a b).
      {
        (* Now we are in the situation x ... a b ... (ab|ba) ... x *)
        destruct H1 as (i2 & He & Hne).
        assert (path g (take (i2+1) $ drop (i1+1) ([x] ++ xs ++ [x]))) as Hpath2.
        {
          apply (path_has_edge g a b).
          - apply path_take. apply path_drop. done.
          - intros j He'.
            rewrite <-has_edge_take in He'.
            destruct He' as [He' Hne'].
            assert (j < i2) by lia.
            eapply Hne; done.
        }
        assert (take (i2 + 1) (drop (i1 + 1) ([x] ++ xs ++ [x])) !! 0 = Some b) as Hsb.
        {
          rewrite lookup_take; last lia. rewrite lookup_drop.
          rewrite Nat.add_0_r. done.
        }
        destruct He as [He|He].
        {
          (* Now we are in the situation x ... a b ... a b ... x *)
          exfalso. apply Hnconn. apply connected0_sym; first done.
          apply connected0_alt.
          eexists.
          split; first done. split; first done.
          replace (i2+1) with (S i2) by lia.
          apply last_take_Some. destruct He. done.
        }
        {
          (* Now we are in the situation x ... a b ... b a ... x *)
          assert (last (take (i2 + 1) (drop (i1 + 1) ([x] ++ xs ++ [x]))) = Some b) as Hsb'.
          {
            replace (i2 + 1) with (S i2) by lia.
            destruct He.
            rewrite last_take; first done.
            apply lookup_lt_Some in H1. done.
          }
          destruct He.
          destruct (decide (i2 = 0)).
          {
            subst. simpl in *.
            rewrite lookup_drop in H1.
            apply lookup_take_Some in Hsb. rewrite lookup_drop in Hsb.
            rewrite lookup_drop in H2.
            exists i1, a.
            split; eauto.
            rewrite<-H2. f_equiv. lia.
          }
          rewrite take_drop_commute in Hpath2.
          replace (i1 + 1 + (i2 + 1)) with (S (i1 + (i2 + 1))) in Hpath2 by lia.
          eapply has_u_turn_mid.
          + constructor; eauto.
          + exact Hpath2.
          + lia.
          + apply lookup_take_Some in Hsb. rewrite lookup_drop in Hsb. replace (i1 + 1 + 0) with (i1 + 1) in Hsb by lia.
            done.
          + rewrite lookup_drop in H1. rewrite <- H1. f_equiv. lia.
        }
      }
      {
        (* Now we are in the situation x ... a b ... x *)
        assert (path g (drop (i1+1) ([x] ++ xs ++ [x]))) as Hpath2.
        {
          apply (path_has_edge g a b).
          - apply path_drop. done.
          - intros j He'. eapply H1. done.
        }
        contradict Hnconn.
        apply connected0_sym; first done.
        apply (connected0_trans g b x a).
        - apply connected0_alt. eexists.
          split; first exact Hpath2.
          split.
          + rewrite lookup_drop. rewrite <- Hi1vB. f_equiv. lia.
          + rewrite last_drop.
            * rewrite app_assoc. rewrite last_snoc. done.
            * apply lookup_lt_Some in Hi1vB. done.
        - apply connected0_alt. eexists.
          split; first exact Hpath1; replace (i1 + 1) with (S i1) by lia.
          split; first done.
          rewrite last_take; first done.
          apply lookup_lt_Some in Hi1vA. done.
      }
    }
    (* No (a,b)|(b,a) *)
    apply forest_u_turns0. revert H1 Hpath.
    generalize ([x] ++ xs ++ [x]). intros.
    intros i q r Hq Hr.
    specialize (Hpath i q r).
    rewrite-> elem_of_union in Hpath.
    destruct Hpath; eauto.
    specialize (H1 i). exfalso. apply H1.
    unfold has_edge.
    assert ((q = a ∧ r = b) ∨ (q = b ∧ r = a)) as [[]|[]] by (unfold uedge in *; set_solver);
    subst; eauto.
  Qed.

  Lemma forest_disconnect (g : G) (a b : A) :
    is_uforest g -> (a,b) ∈ g -> ¬ connected0 (g ∖ uedge a b) a b.
  Proof.
    intros [] Hedge [|Hconn].
    { subst. eapply forest_no_self_loops; try constructor; eauto. }
    destruct Hconn as (xs & Hpath).
    apply connected_no_u_turn in Hpath.
    - destruct Hpath as (xs' & Hpath' & Hnut).
      pose proof (forest_u_turns0 b ([a] ++ xs')).
      destruct H1.
      {
        simpl. apply path_cons. apply forest_undirected; done. eapply path_delete. done.
      }
      destruct H1. destruct H1.
      destruct x; simpl in *.
      assert (x0 = b) as -> by qed. simplify_eq.
      + destruct xs'; simpl in *; simplify_eq.
        * specialize (Hpath' 0 a b); simpl in *. unfold uedge in *. set_solver.
        * specialize (Hpath' 0 a b); simpl in *. unfold uedge in *. set_solver.
      + apply Hnut. exists x,x0. split; eauto.
    - intro. subst. pose proof (forest_no_self_loops g).
      cut ((b,b) ∉ g). { intro Q. apply Q. done. }
      apply H1. constructor; done.
  Qed.

  Lemma forest_delete (g : G) (a b : A) :
    is_uforest g -> is_uforest (g ∖ uedge a b).
  Proof.
    intros [].
    constructor.
    - intros x y Hxy.
      rewrite-> elem_of_difference in *.
      destruct Hxy.
      apply forest_undirected0 in H1.
      split; [done|].
      unfold uedge in *. set_solver.
    - intros x xs Hpath.
      eauto using path_delete.
  Qed.

  Lemma forest_empty : is_uforest ∅.
  Proof.
    constructor.
    - intros ???.
      eauto using not_elem_of_empty.
    - intros x xs Hpath.
      exfalso.
      specialize (Hpath 0 x).
      destruct xs.
      + simpl in *.
        specialize (Hpath x).
        apply not_elem_of_empty in Hpath; done.
      + simpl in *.
        specialize (Hpath a).
        apply not_elem_of_empty in Hpath; done.
  Qed.

  Definition lone (x : A) (g : uforest A) :=
    ∀ y, (x,y) ∉ g.

  Lemma forest_extend (x y : A) (g : uforest A) :
    x ≠ y → lone y g →
    is_uforest g → is_uforest (g ∪ uedge x y).
  Proof.
    intros Hneq Hlone [].
    apply forest_connect; [done..|].
    intros [->|[]]; eauto.
    unfold path in *. unfold lone in *.
    destruct (([x] ++ x0 ++ [y]) !! length x0) eqn:E.
    2: {
      apply lookup_ge_None_1 in E. simpl in *.
      rewrite app_length in E. lia.
    }
    eapply Hlone.
    apply forest_undirected0.
    eapply (H1 (length x0)); [done|].
    replace (length x0 + 1) with (length ([x] ++ x0) + 0); simpl; [|lia].
    rewrite lookup_app_plus. done.
  Qed.

  Lemma connected_edge (g : G) (x y : A) :
    (x,y) ∈ g -> connected0 g x y.
  Proof.
    intros Hxy. right.
    exists []. simpl.
    intros i a b Ha Hb.
    destruct i; simpl in *. simplify_eq. done.
    destruct i; simpl in *. simplify_eq.
    rewrite lookup_nil in Ha. simplify_eq.
  Qed.

  Lemma forest_modify (x y z : A) (g : uforest A) :
    x ≠ z -> y ≠ z ->
    is_uforest g -> (x,y) ∈ g -> (x,z) ∈ g ->
    is_uforest ((g ∖ uedge x z) ∪ uedge y z).
  Proof.
    intros Hxnz Hynz Hforest Hxy Hxz.
    apply forest_connect; try done.
    - by apply forest_delete.
    - pose proof (forest_disconnect g x z Hforest Hxz) as Hconn.
      intro Hconn'.
      eapply connected0_trans in Hconn'.
      apply Hconn. exact Hconn'.
      apply connected_edge.
      unfold uedge. set_solver.
  Qed.

  Definition uvertices (g : G) : gset A :=
    set_map fst g ∪ set_map snd g.

  Definition no_u_turns (f : A -> option A) : Prop :=
      ∀ a b c, f a = Some b -> f b = Some c -> a ≠ c.

  Fixpoint search_iter
    (g : uforest A) (f : A -> option A) (a : A) (n : nat) : A :=
    match n with
    | 0 => a
    | S n => match f a with
             | None => a
             | Some a' => search_iter g f a' n
             end
    end.

  Definition search (g : uforest A) (x : A) (f : A -> option A) : A :=
    search_iter g f x (size (uvertices g)).

  Fixpoint search_iter_list
    (g : uforest A) (f : A -> option A) (a : A) (n : nat) : list A :=
    match n with
    | 0 => []
    | S n => match f a with
             | None => []
             | Some a' => a' :: search_iter_list g f a' n
             end
    end.

  Definition valid (g : uforest A) (f : A -> option A) :=
    ∀ x y, x ∈ uvertices g -> f x = Some y -> (x,y) ∈ g.

  Definition fpath (g : G) (f : A -> option A) (xs : P) :=
    ∀ i a b, xs !! i = Some a -> xs !! (i+1) = Some b -> f a = Some b.

  Lemma fpath_sub (g : G) (f : A -> option A) (xs ys : P) :
    fpath g f (xs ++ ys) -> fpath g f xs.
  Proof.
    intros Hpath i a b Ha Hb.
    eapply Hpath.
    - rewrite lookup_app_l. done.
      eapply lookup_lt_Some; done.
    - rewrite lookup_app_l. done.
      eapply lookup_lt_Some; done.
  Qed.

  Lemma edge_in_uvertices (g : G) (x y : A) :
    (x,y) ∈ g -> y ∈ uvertices g.
  Proof.
    intro. unfold uvertices.
    apply elem_of_union_r.
    apply elem_of_map.
    exists (x,y). simpl. eauto.
  Qed.

  Lemma fpath_uvertices (g : G) (f : A -> option A) (x : A) (xs : P) :
    valid g f -> x ∈ uvertices g -> fpath g f (x::xs) -> ∀ a, a ∈ (x::xs) -> a ∈ uvertices g.
  Proof.
    rewrite <- (reverse_involutive xs).
    generalize (reverse xs). clear xs.
    intros xs Hvalid Hvert Hfpath.
    induction xs as [|y xs IHxs]; simpl; intros a Hin.
    { apply elem_of_cons in Hin as []; qed. }
    rewrite reverse_cons in Hin.
    rewrite reverse_cons in Hfpath.
    rewrite-> app_comm_cons in *.
    apply elem_of_app in Hin as [].
    - apply IHxs; eauto.
      eapply fpath_sub; done.
    - assert (a = y) as <- by set_solver. clear H1.
      unfold valid in *.
      destruct xs; simpl in *.
      + eapply edge_in_uvertices. eapply Hvalid.
        done.
        eapply (Hfpath 0). done. done.
      + eapply edge_in_uvertices. eapply Hvalid.
        eapply IHxs.
        * eapply fpath_sub. done.
        * rewrite reverse_cons. rewrite app_comm_cons.
          apply elem_of_app. right. assert (∀ (x:A), x ∈ [x]) by set_solver.
          apply H1.
        * eapply (Hfpath (length (x :: reverse xs))).
          -- rewrite reverse_cons. rewrite app_comm_cons.
             rewrite lookup_app_l. rewrite app_comm_cons.
             replace (length (x :: reverse xs)) with (length (x :: reverse xs) + 0) by lia.
             rewrite lookup_app_plus. done.
             rewrite app_comm_cons.
             rewrite app_length. simpl. lia.
          -- rewrite app_comm_cons.
             rewrite lookup_app_r.
             simpl.
             rewrite reverse_cons. rewrite app_length. simpl.
             replace (length (reverse xs) + 1 - (length (reverse xs) + 1)) with 0 by lia. done.
             rewrite reverse_cons. rewrite app_comm_cons. rewrite app_length. simpl.
             lia.
  Qed.

  Lemma fpath_path (g : G) (f : A -> option A) (x : A) (xs : P) :
    x ∈ uvertices g -> valid g f -> fpath g f (x::xs) -> path g (x::xs).
  Proof.
    intros Hvert Hvalid Hfpath i a b Ha Hb.
    apply Hvalid.
    - eapply fpath_uvertices; try done. eapply elem_of_list_lookup_2;done.
    - unfold fpath in *. eapply Hfpath; done.
  Qed.

  Lemma fpath_drop (g : G) (f : A -> option A) (xs : P) (k : nat) :
    fpath g f xs -> fpath g f (drop k xs).
  Proof.
    intros Hfpath i a b Ha Hb.
    rewrite-> (lookup_drop xs) in Ha.
    rewrite-> (lookup_drop xs) in Hb.
    eapply Hfpath.
    exact Ha.
    rewrite <-Nat.add_assoc. done.
  Qed.

  Lemma fpath_take (g : G) (f : A -> option A) (xs : P) (k : nat) :
    fpath g f xs -> fpath g f (take k xs).
  Proof.
    intros Hfpath i a b Ha Hb.
    apply lookup_take_Some in Ha.
    apply lookup_take_Some in Hb.
    eapply Hfpath; eauto.
  Qed.

  Lemma fpaths_no_u_turns f g xs :
    no_u_turns f -> fpath g f xs -> ¬ has_u_turn xs.
  Proof.
    intros Hnut Hpath Hut.
    destruct Hut as (i & x & H1 & H2).
    unfold fpath in *.
    destruct (xs !! (i+1)) eqn:E.
    - pose proof (Hpath _ _ _ H1 E).
      replace (i+2) with (i+1+1) in H2.
      pose proof (Hpath _ _ _ E H2).
      eapply Hnut; eauto. lia.
    - apply lookup_ge_None_1 in E.
      apply lookup_lt_Some in H2. lia.
  Qed.

  Lemma forest_no_floops (g : G) (f : A -> option A) (x y : A) (xs : P) i j :
    valid g f -> no_u_turns f -> is_uforest g -> x ∈ uvertices g ->
    xs !! 0 = Some x -> i < j -> xs !! i = Some y -> xs !! j = Some y ->
    fpath g f xs -> False.
  Proof.
    intros Hvalid Hnut Hforest Hvert Hstart Hle H1 H2 Hfpath.
    assert (path g xs).
    { destruct xs; simpl in *; simplify_eq. apply fpath_path in Hfpath; try done. }
    assert (has_u_turn xs).
    {
      eapply has_u_turn_mid; eauto. apply path_drop. apply path_take. done.
    }
    eapply fpaths_no_u_turns; eauto.
  Qed.

  Lemma forest_no_floops' (g : G) (f : A -> option A) (x : A) (xs : P) :
    valid g f -> no_u_turns f -> is_uforest g -> x ∈ uvertices g -> fpath g f ([x] ++ xs ++ [x]) -> False.
  Proof.
    intros Hvalid Hnut [] Hvert Hfpath.
    apply fpath_path in Hfpath as Hpath; try done.
    edestruct forest_u_turns0. exact Hpath.
    destruct H1 as (y & Hy1 & Hy2).
    unfold fpath in Hfpath.
    destruct (([x] ++ xs ++ [x]) !! (x0 + 1)) eqn:Hymid.
    2: {
      apply lookup_ge_None_1 in Hymid.
      apply lookup_lt_Some in Hy2.
      lia.
    }
    specialize (Hfpath x0 y a Hy1 Hymid) as Q1.
    specialize (Hfpath (x0 + 1) a y Hymid) as Q2. replace (x0 + 1 + 1)  with (x0 + 2)  in Q2 by lia.
    specialize (Q2 Hy2).
    unfold no_u_turns in *.
    eapply Hnut; eauto.
  Qed.

  Lemma search_lemma (g : uforest A) (x : A) (f : A -> option A) :
    is_uforest g -> no_u_turns f -> valid g f ->
    x ∈ uvertices g -> f (search g x f) = None.
  Proof.
    intros Hforest Huturn Hvalid Hx.
    (* Suppose f (search g x f) = Some y *)
    destruct (f (search g x f)) eqn:Hss;[|done].
    exfalso.
    (* Have a long f-path in g *)
    assert (∃ xs, fpath g f (x::xs) ∧ size (uvertices g) < length (x::xs)).
    {
      unfold search in Hss.
      exists (search_iter_list g f x (size (uvertices g))).
      revert x Hss Hx.
      induction (size (uvertices g)); simpl in *; intros.
      - split;last lia. unfold fpath. intros. destruct i; simpl in *; simplify_eq.
      - destruct (f x) eqn:E; simpl in *; simplify_eq.
        specialize (IHn _ Hss). destruct IHn. unfold valid in *.
        eapply edge_in_uvertices. eapply Hvalid; eauto.
        split; last lia.
        unfold fpath in *.
        intros. destruct i; simpl in *; simplify_eq; eauto.
    }
    destruct H1 as (xs & Hpath & Hsize).
    (* Since the path is longer than the number of uvertices, there must be a duplicate vertex in the path *)
    edestruct (pigeon (uvertices g) (x::xs)) as (i & j & y & Hi & Hj & Hneq); eauto.
    {
      intros. apply elem_of_list_lookup_2 in H1. eapply fpath_uvertices; eauto.
    }
    wlog: i j Hi Hj Hneq / i < j.
    {
      intros. destruct (decide (i < j)); eauto.
      assert (j < i) by lia.
      eauto.
    }
    intros Hlt. clear Hneq.
    (* Duplicate vertex gives a u-turn -> contradiction *)
    eapply forest_no_floops; eauto; done.
  Qed.

  Lemma search_in_uvertices (g : uforest A) (x : A) (f: A -> option A) :
    is_uforest g -> valid g f -> x ∈ uvertices g -> search g x f ∈ uvertices g.
  Proof.
    unfold search.
    revert x.
    induction (size _); simpl; eauto. intros.
    destruct (f x) eqn:E; eauto. apply IHn; eauto.
    unfold valid in *.
    eapply edge_in_uvertices; eauto.
  Qed.

  Lemma search_exists (g : uforest A) (x : A) (f : A -> option A) :
    is_uforest g -> no_u_turns f -> valid g f ->
    x ∈ uvertices g -> ∃ y, f y = None ∧ y ∈ uvertices g.
  Proof.
    intros. exists (search g x f).
    split.
    + apply search_lemma; eauto.
    + apply search_in_uvertices; eauto.
  Qed.

  Lemma path_uvertices g xs :
    is_uforest g -> 2 ≤ length xs -> path g xs -> ∀ x, x ∈ xs -> x ∈ uvertices g.
  Proof.
    intros Hforest. intros.
    unfold path in *.
    apply elem_of_list_lookup in H3 as (? & ?).
    destruct x0.
    - destruct (xs !! 1) eqn:E.
      + specialize (H2 _ _ _ H3 E).
        eapply edge_in_uvertices.
        eapply forest_undirected; eauto.
      + eapply lookup_ge_None in E. lia.
    - destruct (xs !! x0) eqn:E.
      + eapply edge_in_uvertices. eapply H2; eauto. rewrite <- H3.
        f_equiv. lia.
      + eapply lookup_lt_Some in H3.
        eapply lookup_ge_None in E.
        lia.
  Qed.

  Lemma lookup_take_spec (xs : list A) k n :
    take n xs !! k = if decide (k < n) then xs !! k else None.
  Proof.
    case_decide.
    - rewrite lookup_take; eauto.
    - rewrite lookup_take_ge; eauto. lia.
  Qed.

  Lemma lookup_length_unfold (xs : list A) k :
    xs !! k = if decide (k < length xs) then xs !! k else None.
  Proof.
    case_decide; eauto.
    eapply lookup_ge_None_2. lia.
  Qed.

  Lemma lookup_list_singleton_spec k (x : A) :
    [x] !! k = if decide (k = 0) then Some x else None.
  Proof.
    case_decide; subst; eauto. destruct k; simpl; eauto. lia.
  Qed.

  Lemma long_paths_have_u_turns g xs :
    is_uforest g -> size (uvertices g)+10 < length xs -> path g xs -> has_u_turn xs.
  Proof.
    intros Hforest Hsize Hpath.
    edestruct (pigeon (uvertices g) xs) as (i & j & y & Hi & Hj & Hneq); eauto.
    { intros. eapply path_uvertices; eauto using elem_of_list_lookup_2. lia. }
    { lia. }
    wlog: i j Hi Hj Hneq / i < j.
    {
      intros. destruct (decide (i < j)); eauto.
      assert (j < i) by lia.
      eauto.
    }
    intros Hlt.
    assert (path g (drop i (take (S j) xs))) as Hsubpath
      by eauto using path_take, path_drop.
    eapply has_u_turn_mid; eauto.
  Qed.

  Definition asym (R : A -> A -> Prop) :=
    ∀ x y, R x y -> R y x -> x = y.
  Definition Rpath (R : A -> A -> Prop) (xs : list A) : Prop :=
    ∀ i x y, xs !! i = Some x -> xs !! (i + 1) = Some y -> R y x.
  Definition Rvalid (R : A -> A -> Prop) (g : uforest A) : Prop :=
    ∀ x y, R x y -> (y,x) ∈ g.

  Lemma Rpath_path g (R : A -> A -> Prop) (xs : list A) :
    Rpath R xs -> Rvalid R g -> path g xs.
  Proof.
    intros H1 H2 i a b Ha Hb.
    eapply H2.
    eapply H1; eauto.
  Qed.

  Lemma Rpath_no_u_turns R xs g :
    is_uforest g -> Rvalid R g -> Rpath R xs -> asym R -> ¬ has_u_turn xs.
  Proof.
    intros Hforest Hvalid H1 H2 (i & x & Q1 & Q2).
    destruct (xs !! (i + 1)) eqn:E; last first.
    { eapply lookup_ge_None in E.
      eapply lookup_lt_Some in Q2. lia. }
    assert (x = a).
    {
      eapply H2.
      - eapply H1. exact E.
        replace (i + 1 + 1) with (i + 2) by lia. done.
      - eapply H1; last done. done.
    }
    subst.
    eapply forest_no_self_loops; first done.
    eapply Hvalid.
    eapply H1. exact Q1. done.
  Qed.

  Lemma lookup_length_app (xs : list A) (ys : list A) n :
    (xs ++ ys) !! (length xs + n) = ys !! n.
  Proof.
    rewrite lookup_app.
    destruct (xs !! (length xs + n)) eqn:E.
    apply lookup_lt_Some in E; first lia.
    f_equiv. lia.
  Qed.

  Lemma Rpath_snoc xs x y R :
    Rpath R (xs ++ [x]) -> R y x -> Rpath R ((xs ++ [x]) ++ [y]).
  Proof.
    intros.
    unfold Rpath in *.
    intros.
    destruct (decide (i + 1 < length (xs ++ [x]))).
    - eapply (H1 i).
      + rewrite lookup_app in H3.
        rewrite <-H3.
        destruct ((xs ++ [x]) !! i) eqn:E; eauto.
        destruct (i - length (xs ++ [x])) eqn:F; simpl in *; simplify_eq.
        eapply lookup_ge_None in E.
        assert (length (xs ++ [x]) = i) by lia.
        subst.
        rewrite lookup_length_app in H4. simpl in *. simplify_eq.
      + rewrite lookup_app in H4.
        rewrite <-H4.
        destruct ((xs ++ [x]) !! (i + 1)) eqn:E; eauto.
        destruct (i + 1 - length (xs ++ [x])) eqn:F; simpl in *; simplify_eq.
        eapply lookup_ge_None in E. lia.
    - assert (i + 1 = length (xs ++ [x])).
      { eapply lookup_lt_Some in H4. rewrite app_length in H4. simpl in *. lia. }
      rewrite H5 in H4.
      replace (length (xs ++ [x])) with (length (xs ++ [x]) + 0) in H4 by lia.
      rewrite lookup_length_app in H4. simpl in H4. simplify_eq.
      rewrite lookup_app in H3.
      rewrite lookup_app in H3.
      destruct (xs !! i) eqn:E.
      { eapply lookup_lt_Some in E.
        rewrite app_length in H5. simpl in *. lia. }
      destruct (i - length xs) eqn:F.
      + simpl in *. simplify_eq. done.
      + simpl in *. destruct ((i - length (xs ++ [x]))) eqn:G;
        simpl in *; simplify_eq.
        rewrite app_length in G. simpl in *.
        rewrite app_length in n.
        rewrite app_length in H5.
        simpl in *. lia.
  Qed.

  Definition ureachable (R : A -> A -> Prop) g n x :=
    ∃ xs, Rpath R (xs ++ [x]) ∧
      length (xs ++ [x]) + n > size (uvertices g) + 10.

  Lemma rel_wf_helper (R : A -> A -> Prop) (g : uforest A) n :
    is_uforest g -> asym R -> Rvalid R g ->
    ∀ x, ureachable R g n x -> Acc R x.
  Proof.
    intros Hforest Hasym Hvalid.
    induction n.
    - intros x (xs & HRpath & Hlen).
      exfalso. eapply Rpath_no_u_turns; eauto.
      eapply long_paths_have_u_turns; eauto. lia.
      eapply Rpath_path; eauto.
    - intros x (xs & HRpath & Hlen).
      constructor. intros. eapply IHn.
      exists (xs ++ [x]). split.
      + eapply Rpath_snoc; eauto.
      + simpl. rewrite app_length; simpl. lia.
  Qed.

  Lemma ureachable_0 R g a :
    ureachable R g (size (uvertices g) + 10) a.
  Proof.
    unfold ureachable.
    exists [].
    split.
    - unfold Rpath. intros. simpl in *.
      destruct i; simpl in *; simplify_eq.
    - simpl in *. lia.
  Qed.

  Lemma rel_wf (R : A -> A -> Prop) (g : uforest A) :
    asym R ->
    Rvalid R g ->
    is_uforest g -> wf R.
  Proof.
    intros. unfold wf. intro.
    eapply rel_wf_helper; eauto using ureachable_0.
  Qed.

  Lemma uforest_ind (R : A -> A -> Prop) (g : uforest A) (P : A -> Prop) :
    is_uforest g ->
    asym R ->
    (∀ x, (∀ y, R x y -> (x,y) ∈ g -> P y) -> P x) -> (∀ x, P x).
  Proof.
    intros Hforest Hasym Hind.
    set T := λ x y, R y x ∧ (y,x) ∈ g.
    assert (asym T).
    { intros x y [] []. eapply Hasym; eauto. }
    assert (Rvalid T g).
    { intros x y []. done. }
    pose proof (rel_wf T g H1 H2 Hforest).
    intros x. specialize (H3 x).
    induction H3. eapply Hind.
    intros. eapply H4. split; eauto.
  Qed.

End uforest.

Lemma rtc_list {T} (R : T -> T -> Prop) a b :
  rtc R a b <-> ∃ xs, xs !! 0 = Some a ∧ last xs = Some b ∧
                  ∀ i x y, xs !! i = Some x -> xs !! (i+1) = Some y -> R x y.
Proof.
  split.
  - induction 1.
    + exists [x]; simpl.
      split_and!; eauto.
      intros. destruct i; simpl in *; simplify_eq.
    + destruct IHrtc as (xs & Hxs & Qf & Ql).
      exists (x :: xs).
      split_and!; eauto.
      * destruct xs; eauto using path_singleton.
        simpl in *. simplify_eq.
      * intros. destruct i; simpl in *; simplify_eq; eauto.
  - intros (xs & Qf & Ql & Qxs).
    destruct xs; simpl in *; simplify_eq. revert a Qxs Ql.
    induction xs; intros; simplify_eq/=; try reflexivity.
    eapply rtc_transitive.
    + eapply rtc_once. eapply (Qxs 0); simpl; eauto.
    + eapply IHxs; eauto.
      intros. eapply (Qxs (S i)); simpl; eauto.
Qed.

Lemma connected0_elem_of `{Countable A} (f : uforest A) v1 v2 :
  is_uforest f ->
  connected0 f v1 v2 <-> rtsc (λ x y, (x,y) ∈ f) v1 v2.
Proof.
  intros.
  rewrite connected0_alt.
  split.
  - unfold rtsc. rewrite rtc_list. intros (xs & Hpath & Qf & Ql).
    exists xs. split_and!; eauto.
    intros. left. eapply Hpath; eauto.
  - unfold rtsc. rewrite rtc_list.
    intros (xs & Qf & Ql & Hpath).
    exists xs. split_and!; eauto.
    intros ?????.
    edestruct Hpath; first exact H1; eauto.
    eapply forest_undirected; eauto.
Qed.


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

(** * BigNumPrelude *)

(** Auxillary functions & theorems used for arbitrary precision efficient
    numbers. *)

Require Import ArithRing.
Require Export ZArith.
Require Export Znumtheory.
Require Export Zpow_facts.

Declare ML Module "numbers_syntax_plugin".

(* *** Nota Bene ***
   All results that were general enough has been moved in ZArith.
   Only remain here specialized lemmas and compatibility elements.
   (P.L. 5/11/2007).
*)

Local Open Scope Z_scope.

(* For compatibility of scripts, weaker version of some lemmas of Zdiv *)

Lemma Zlt0_not_eq : forall n, 0<n -> n<>0.
Proof.
 auto with zarith.
Qed.

Definition Zdiv_mult_cancel_r a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H).
Definition Zdiv_mult_cancel_l a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H).
Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H).

(* Automation *)

Hint  Extern 2 (Zle _ _) =>
 (match goal with
   |- Zpos _ <= Zpos _ => exact (refl_equal _)
|   H: _ <=  ?p |- _ <= ?p => apply Zle_trans with (2 := H)
|   H: _ <  ?p |- _ <= ?p => apply Zlt_le_weak; apply Zle_lt_trans with (2 := H)
  end).

Hint  Extern 2 (Zlt _ _) =>
 (match goal with
   |- Zpos _ < Zpos _ => exact (refl_equal _)
|      H: _ <=  ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H)
|   H: _ <  ?p |- _ <= ?p => apply Zle_lt_trans with (2 := H)
  end).

Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.

(**************************************
   Properties of order and product
 **************************************)

 Theorem beta_lex: forall a b c d beta,
       a * beta + b <= c * beta + d ->
       0 <= b < beta -> 0 <= d < beta ->
       a <= c.
 Proof.
  intros a b c d beta H1 (H3, H4) (H5, H6).
  assert (a - c < 1); auto with zarith.
  apply Zmult_lt_reg_r with beta; auto with zarith.
  apply Zle_lt_trans with (d  - b); auto with zarith.
  rewrite Zmult_minus_distr_r; auto with zarith.
 Qed.

 Theorem beta_lex_inv: forall a b c d beta,
      a < c -> 0 <= b < beta ->
      0 <= d < beta ->
      a * beta + b < c * beta  + d.
 Proof.
  intros a b c d beta H1 (H3, H4) (H5, H6).
  case (Zle_or_lt (c * beta + d) (a * beta + b)); auto with zarith.
  intros H7; contradict H1;apply Zle_not_lt;apply beta_lex with (1 := H7);auto.
 Qed.

 Lemma beta_mult : forall h l beta,
   0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2.
 Proof.
  intros h l beta H1 H2;split. auto with zarith.
  rewrite <- (Zplus_0_r (beta^2)); rewrite Zpower_2;
   apply beta_lex_inv;auto with zarith.
 Qed.

 Lemma Zmult_lt_b :
   forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1.
 Proof.
  intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith.
  apply Zle_trans with ((b-1)*(b-1)).
  apply Zmult_le_compat;auto with zarith.
  apply Zeq_le;ring.
 Qed.

 Lemma sum_mul_carry : forall xh xl yh yl wc cc beta,
   1 < beta ->
   0 <= wc < beta ->
   0 <= xh < beta ->
   0 <= xl < beta ->
   0 <= yh < beta ->
   0 <= yl < beta ->
   0 <= cc < beta^2 ->
   wc*beta^2 + cc = xh*yl + xl*yh ->
   0 <= wc <= 1.
 Proof.
  intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7.
  assert (H8 := Zmult_lt_b beta xh yl H2 H5).
  assert (H9 := Zmult_lt_b beta xl yh H3 H4).
  split;auto with zarith.
  apply beta_lex with (cc) (beta^2 - 2) (beta^2); auto with zarith.
 Qed.

 Theorem mult_add_ineq: forall x y cross beta,
   0 <= x < beta ->
   0 <= y < beta ->
   0 <= cross < beta ->
   0 <= x * y + cross < beta^2.
 Proof.
  intros x y cross beta HH HH1 HH2.
  split; auto with zarith.
  apply Zle_lt_trans with  ((beta-1)*(beta-1)+(beta-1)); auto with zarith.
  apply Zplus_le_compat; auto with zarith.
  apply Zmult_le_compat; auto with zarith.
  repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r);
  rewrite Zpower_2; auto with zarith.
 Qed.

 Theorem mult_add_ineq2: forall x y c cross beta,
   0 <= x < beta ->
   0 <= y < beta ->
   0 <= c*beta + cross <= 2*beta - 2 ->
   0 <= x * y + (c*beta + cross) < beta^2.
 Proof.
  intros x y c cross beta HH HH1 HH2.
  split; auto with zarith.
  apply Zle_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith.
  apply Zplus_le_compat; auto with zarith.
  apply Zmult_le_compat; auto with zarith.
  repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r);
   rewrite Zpower_2; auto with zarith.
 Qed.

Theorem mult_add_ineq3: forall x y c cross beta,
   0 <= x < beta ->
   0 <= y < beta ->
   0 <= cross <= beta - 2 ->
   0 <= c <= 1 ->
   0 <= x * y + (c*beta + cross) < beta^2.
 Proof.
  intros x y c cross beta HH HH1 HH2 HH3.
  apply mult_add_ineq2;auto with zarith.
  split;auto with zarith.
  apply Zle_trans with (1*beta+cross);auto with zarith.
 Qed.

Hint Rewrite Zmult_1_r Zmult_0_r Zmult_1_l Zmult_0_l Zplus_0_l Zplus_0_r Zminus_0_r: rm10.

(**************************************
 Properties of Zdiv and Zmod
**************************************)

Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
 Proof.
  intros a b H H1;case (Z_mod_lt a b);auto with zarith;intros H2 H3;split;auto.
  case (Zle_or_lt b a); intros H4; auto with zarith.
  rewrite Zmod_small; auto with zarith.
 Qed.

 Theorem Zmod_distr: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a ->
  (2 ^a * r + t) mod (2 ^ b) = (2 ^a * r) mod (2 ^ b) + t.
 Proof.
  intros a b r t (H1, H2) H3 (H4, H5).
  assert (t < 2 ^ b).
  apply Zlt_le_trans with (1:= H5); auto with zarith.
  apply Zpower_le_monotone; auto with zarith.
  rewrite Zplus_mod; auto with zarith.
  rewrite Zmod_small with (a := t); auto with zarith.
  apply Zmod_small; auto with zarith.
  split; auto with zarith.
  assert (0 <= 2 ^a * r); auto with zarith.
  apply Zplus_le_0_compat; auto with zarith.
  match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
   auto with zarith.
  pattern (2 ^ b) at 2; replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a);
    try ring.
  apply Zplus_le_lt_compat; auto with zarith.
  replace b with ((b - a) + a); try ring.
  rewrite Zpower_exp; auto with zarith.
  pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a));
   try rewrite <- Zmult_minus_distr_r.
  rewrite (Zmult_comm (2 ^(b - a))); rewrite  Zmult_mod_distr_l;
   auto with zarith.
  rewrite (Zmult_comm (2 ^a)); apply Zmult_le_compat_r; auto with zarith.
  match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
   auto with zarith.
 Qed.

 Theorem Zmod_shift_r:
   forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a ->
     (r * 2 ^a + t) mod (2 ^ b) = (r * 2 ^a) mod (2 ^ b) + t.
 Proof.
  intros a b r t (H1, H2) H3 (H4, H5).
  assert (t < 2 ^ b).
  apply Zlt_le_trans with (1:= H5); auto with zarith.
  apply Zpower_le_monotone; auto with zarith.
  rewrite Zplus_mod; auto with zarith.
  rewrite Zmod_small with (a := t); auto with zarith.
  apply Zmod_small; auto with zarith.
  split; auto with zarith.
  assert (0 <= 2 ^a * r); auto with zarith.
  apply Zplus_le_0_compat; auto with zarith.
  match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
   auto with zarith.
  pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring.
  apply Zplus_le_lt_compat; auto with zarith.
  replace b with ((b - a) + a); try ring.
  rewrite Zpower_exp; auto with zarith.
  pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a));
   try rewrite <- Zmult_minus_distr_r.
  repeat rewrite (fun x => Zmult_comm x (2 ^ a)); rewrite Zmult_mod_distr_l;
   auto with zarith.
  apply Zmult_le_compat_l; auto with zarith.
  match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
   auto with zarith.
 Qed.

  Theorem Zdiv_shift_r:
    forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a ->
      (r * 2 ^a + t) /  (2 ^ b) = (r * 2 ^a) / (2 ^ b).
  Proof.
   intros a b r t (H1, H2) H3 (H4, H5).
   assert (Eq: t < 2 ^ b); auto with zarith.
   apply Zlt_le_trans with (1 := H5); auto with zarith.
   apply Zpower_le_monotone; auto with zarith.
   pattern (r * 2 ^ a) at 1; rewrite Z_div_mod_eq with (b := 2 ^ b);
    auto with zarith.
   rewrite <- Zplus_assoc.
   rewrite <- Zmod_shift_r; auto with zarith.
   rewrite (Zmult_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith.
   rewrite (fun x y => @Zdiv_small (x mod y)); auto with zarith.
   match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
    auto with zarith.
  Qed.

 Lemma shift_unshift_mod : forall n p a,
     0 <= a < 2^n ->
     0 <= p <= n ->
     a * 2^p = a / 2^(n - p) * 2^n + (a*2^p) mod 2^n.
 Proof.
  intros n p a H1 H2.
  pattern (a*2^p) at 1;replace (a*2^p) with
     (a*2^p/2^n * 2^n + a*2^p mod 2^n).
  2:symmetry;rewrite (Zmult_comm (a*2^p/2^n));apply Z_div_mod_eq.
  replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial.
  replace (2^n) with (2^(n-p)*2^p).
  symmetry;apply Zdiv_mult_cancel_r.
  destruct H1;trivial.
  cut (0 < 2^p); auto with zarith.
  rewrite <- Zpower_exp.
  replace (n-p+p) with n;trivial. ring.
  omega. omega.
  apply Zlt_gt. apply Zpower_gt_0;auto with zarith.
 Qed.

 Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n ->
   ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) =
   a mod 2 ^ p.
 Proof.
 intros.
 rewrite Zmod_small.
 rewrite Zmod_eq by (auto with zarith).
 unfold Zminus at 1.
 rewrite Z_div_plus_l by (auto with zarith).
 assert (2^n = 2^(n-p)*2^p).
  rewrite <- Zpower_exp by (auto with zarith).
  replace (n-p+p) with n; auto with zarith.
 rewrite H0.
 rewrite <- Zdiv_Zdiv, Z_div_mult by (auto with zarith).
 rewrite (Zmult_comm (2^(n-p))), Zmult_assoc.
 rewrite Zopp_mult_distr_l.
 rewrite Z_div_mult by (auto with zarith).
 symmetry; apply Zmod_eq; auto with zarith.

 remember (a * 2 ^ (n - p)) as b.
 destruct (Z_mod_lt b (2^n)); auto with zarith.
 split.
 apply Z_div_pos; auto with zarith.
 apply Zdiv_lt_upper_bound; auto with zarith.
 apply Zlt_le_trans with (2^n); auto with zarith.
 rewrite <- (Zmult_1_r (2^n)) at 1.
 apply Zmult_le_compat; auto with zarith.
 cut (0 < 2 ^ (n-p)); auto with zarith.
 Qed.

 Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p.
 Proof.
  intros p x Hle;destruct (Z_le_gt_dec 0 p).
  apply  Zdiv_le_lower_bound;auto with zarith.
  replace (2^p) with 0.
  destruct x;compute;intro;discriminate.
  destruct p;trivial;discriminate z.
 Qed.

 Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y.
 Proof.
  intros p x y H;destruct (Z_le_gt_dec 0 p).
  apply Zdiv_lt_upper_bound;auto with zarith.
  apply Zlt_le_trans with y;auto with zarith.
  rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith.
  assert (0 < 2^p);auto with zarith.
  replace (2^p) with 0.
  destruct x;change (0<y);auto with zarith.
  destruct p;trivial;discriminate z.
 Qed.

 Theorem Zgcd_div_pos a b:
   0 < b -> 0 < Zgcd a b -> 0 < b / Zgcd a b.
 Proof.
 intros Ha Hg.
 case (Zle_lt_or_eq 0 (b/Zgcd a b)); auto.
 apply Z_div_pos; auto with zarith.
 intros H; generalize Ha.
 pattern b at 1; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto.
 rewrite <- H; auto with zarith.
 assert (F := (Zgcd_is_gcd a b)); inversion F; auto.
 Qed.

 Theorem Zdiv_neg a b:
   a < 0 -> 0 < b -> a / b < 0.
 Proof.
 intros Ha Hb.
 assert (b > 0) by omega.
 generalize (Z_mult_div_ge a _ H); intros.
 assert (b * (a / b) < 0)%Z.
  apply Zle_lt_trans with a; auto with zarith.
 destruct b; try (compute in Hb; discriminate).
 destruct (a/Zpos p)%Z.
 compute in H1; discriminate.
 compute in H1; discriminate.
 compute; auto.
 Qed.

 Lemma Zdiv_gcd_zero : forall a b, b / Zgcd a b = 0 -> b <> 0 ->
  Zgcd a b = 0.
 Proof.
 intros.
 generalize (Zgcd_is_gcd a b); destruct 1.
 destruct H2 as (k,Hk).
 generalize H; rewrite Hk at 1.
 destruct (Z_eq_dec (Zgcd a b) 0) as [H'|H']; auto.
 rewrite Z_div_mult_full; auto.
 intros; subst k; simpl in *; subst b; elim H0; auto.
 Qed.

 Lemma Zgcd_mult_rel_prime : forall a b c,
  Zgcd a c = 1 -> Zgcd b c = 1 -> Zgcd (a*b) c = 1.
 Proof.
 intros.
 rewrite Zgcd_1_rel_prime in *.
 apply rel_prime_sym; apply rel_prime_mult; apply rel_prime_sym; auto.
 Qed.

 Lemma Zcompare_gt : forall (A:Type)(a a':A)(p q:Z),
  match (p?=q)%Z with Gt => a | _ => a' end =
  if Z_le_gt_dec p q then a' else a.
 Proof.
 intros.
 destruct Z_le_gt_dec as [H|H].
 red in H.
 destruct (p?=q)%Z; auto; elim H; auto.
 rewrite H; auto.
 Qed.

Theorem Zbounded_induction :
  (forall Q : Z -> Prop, forall b : Z,
    Q 0 ->
    (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) ->
      forall n, 0 <= n -> n < b -> Q n)%Z.
Proof.
intros Q b Q0 QS.
set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)).
assert (H : forall n, 0 <= n -> Q' n).
apply natlike_rec2; unfold Q'.
destruct (Zle_or_lt b 0) as [H | H]. now right. left; now split.
intros n H IH. destruct IH as [[IH1 IH2] | IH].
destruct (Zle_or_lt (b - 1) n) as [H1 | H1].
right; auto with zarith.
left. split; [auto with zarith | now apply (QS n)].
right; auto with zarith.
unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3].
assumption. apply Zle_not_lt in H3. false_hyp H2 H3.
Qed.

Lemma Zsquare_le : forall x, x <= x*x.
Proof.
intros.
destruct (Z_lt_le_dec 0 x).
pattern x at 1; rewrite <- (Zmult_1_l x).
apply Zmult_le_compat; auto with zarith.
apply Zle_trans with 0; auto with zarith.
rewrite <- Zmult_opp_opp.
apply Zmult_le_0_compat; auto with zarith.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Cocartesian.
Require Import Category.Construction.Coproduct.
Require Import Category.Instance.Cat.

Generalizable All Variables.

(* Another way of reading this is that we're proving Cat^op is Cartesian. *)

#[export]
Program Instance Cat_Cocartesian : @Cocartesian Cat := {
  product_obj := @Coproduct;
  fork := fun _ _ _ F G =>
    {| fobj := fun x =>
                 match x with
                 | Datatypes.inl x => F x
                 | Datatypes.inr x => G x
                 end
     ; fmap := fun x y f =>
                 match x with
                 | Datatypes.inl x =>
                   match y with
                   | Datatypes.inl y => _
                   | Datatypes.inr y => False_rect _ _
                   end
                 | Datatypes.inr x =>
                   match y with
                   | Datatypes.inl y => False_rect _ _
                   | Datatypes.inr y => _
                   end
                 end |};
  exl := fun _ _ =>
            {| fobj := Datatypes.inl
             ; fmap := fun _ _ => _ |};
  exr := fun _ _ =>
            {| fobj := Datatypes.inr
             ; fmap := fun _ _ => _ |};
}.
Next Obligation. exact (fmap f). Defined.
Next Obligation. exact (fmap f). Defined.
Next Obligation.
  proper.
  destruct x, y; simpl in *;
  solve [ apply fmap_respects; auto | contradiction ].
Qed.
Next Obligation.
  destruct x; simpl in *; cat.
Qed.
Next Obligation.
  destruct x, y, z; simpl in *; try tauto;
  apply fmap_comp.
Qed.
Next Obligation.
  rename x into A.
  rename y into B.
  rename z into C.
  proper.
  destruct x3, y1; simpl; auto; tauto.
Qed.
Next Obligation.
  rename x into A.
  rename y into B.
  rename z into C.
  split; intros; simplify.
  - apply (e (Datatypes.inl x0) (Datatypes.inl y)).
  - apply (e (Datatypes.inr x0) (Datatypes.inr y)).
  - destruct x1; auto.
  - destruct x1, y.
    + apply e0; tauto.
    + tauto.
    + tauto.
    + apply e; tauto.
Qed.


(* Checking typability of intermediate return predicates in nested pattern-matching *)

Inductive A : (Type->Type) -> Type := J : A (fun x => x).
Definition ret (x : nat * A (fun x => x))
  := match x return Type with
     | (y,z) => match z in A f return f Type with
                | J => bool
                end
     end.
Definition foo : forall x, ret x.
Proof.
Fail refine (fun x
          => match x return ret x with
             | (y,J) => true
             end
         ).