From Coq Require Import List.
From StructTact Require Import StructTactics.
From StructTact Require Import ListTactics ListUtil.
From StructTact Require Import RemoveAll PropUtil.
From Coq Require Import FunctionalExtensionality.
From Coq Require Import Sumbool Sorting.Permutation.
From Coq Require Import Relation_Definitions RelationClasses.
Import ListNotations.

Definition update2 {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (f : A -> A -> B) (x y : A) (v : B) :=
  fun x' y' => if sumbool_and _ _ _ _ (A_eq_dec x x') (A_eq_dec y y') then v else f x' y'.

Fixpoint collate {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (from : A) (f : A -> A -> list B) (ms : list (A * B)) :=
  match ms with
   | [] => f
   | (to, m) :: ms' => collate A_eq_dec from (update2 A_eq_dec f from to (f from to ++ [m])) ms'
  end.

Fixpoint collate_ls {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (s : list A) (f : A -> A -> list B) (to : A) (m : B) :=
  match s with
   | [] => f
   | from :: s' => collate_ls A_eq_dec s' (update2 A_eq_dec f from to (f from to ++ [m])) to m
  end.

Fixpoint filter_rel {A : Type} {rel : relation A} (A_rel_dec : forall x y : A, {rel x y} + {~ rel x y}) (x : A) (l : list A) :=
  match l with
   | [] => []
   | y :: tl => if A_rel_dec x y then y :: filter_rel A_rel_dec x tl else filter_rel A_rel_dec x tl
  end.

Definition map2fst {A B : Type} (a : A) := map (fun (b : B) => (a, b)).

Definition map2snd {A B : Type} (b : B) := map (fun (a : A) => (a, b)).

Section Update2.
  Variables A B : Type.

  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Lemma update2_diff1 :
    forall (sigma : A -> A -> B) x y v x' y',
      x <> x' ->
      update2 A_eq_dec sigma x y v x' y' = sigma x' y'.
  Proof using.
    unfold update2.
    intros.
    break_if; intuition congruence.
  Qed.

  Lemma update2_diff2 :
    forall (sigma : A -> A -> B) x y v x' y',
      y <> y' ->
      update2 A_eq_dec sigma x y v x' y' = sigma x' y'.
  Proof using.
    unfold update2.
    intros.
    break_if; intuition congruence.
  Qed.

  Lemma update2_diff_prod :
    forall (sigma : A -> A -> B) x y v x' y',
      (x, y) <> (x', y') ->
      update2 A_eq_dec sigma x y v x' y' = sigma x' y'.
  Proof using.
    unfold update2.
    intros.
    break_if; intuition congruence.
  Qed.

  Lemma update2_nop :
    forall (sigma : A -> A -> B) x y x' y',
      update2 A_eq_dec sigma x y (sigma x y) x' y' = sigma x' y'.
  Proof using.
    unfold update2.
    intros. break_if; intuition congruence.
  Qed.

  Lemma update2_eq :
    forall (sigma : A -> A -> B) x y x' y' v,
      x = x' ->
      y = y' ->
      update2 A_eq_dec sigma x y v x' y' = v.
  Proof using.
    intros. subst.
    unfold update2.
    break_if; intuition congruence.
  Qed.

  Lemma update2_eq_prod :
    forall (sigma : A -> A -> B) x y x' y' v,
      (x, y) = (x', y') ->
      update2 A_eq_dec sigma x y v x' y' = v.
  Proof using.
    intros. subst.
    unfold update2.
    break_if; intuition congruence.
  Qed.

  Lemma update2_same :
    forall (sigma : A -> A -> B) x y v,
      update2 A_eq_dec sigma x y v x y = v.
  Proof using.
    intros.
    rewrite update2_eq; auto.
  Qed.

  Lemma update2_nop_ext :
    forall (sigma : A -> A -> B) x y,
      update2 A_eq_dec sigma x y (sigma x y) = sigma.
  Proof using.
    intros.
    do 2 (apply functional_extensionality; intros).
    apply update2_nop.
  Qed.

  Lemma update2_nop_ext' :
    forall (sigma : A -> A -> B) x y v,
      sigma x y = v ->
      update2 A_eq_dec sigma x y v = sigma.
  Proof using.
    intros.
    subst.
    apply update2_nop_ext.
  Qed.

  Lemma update2_overwrite :
    forall (sigma : A -> A -> B) x y st st',
      update2 A_eq_dec (update2 A_eq_dec sigma x y st) x y st' = update2 A_eq_dec sigma x y st'.
  Proof using.
    intros.
    do 2 (apply functional_extensionality; intros).
    destruct (A_eq_dec x x0);
      destruct (A_eq_dec y x1).
    - repeat rewrite update2_eq; auto.
    - repeat rewrite update2_diff2; auto.
    - repeat rewrite update2_diff1; auto.
    - repeat rewrite update2_diff1; auto.
  Qed.

End Update2.

Lemma update2_fun_comm :
  forall A B C A_eq_dec (f : B -> C) (st : A -> A -> B) x y v x' y',
    f (update2 A_eq_dec st x y v x' y') = update2 A_eq_dec (fun x y => f (st x y)) x y (f v) x' y'.
Proof using.
  intros.
  destruct (prod_eq_dec A_eq_dec A_eq_dec (x, y) (x', y')); subst;
    repeat first [rewrite update2_diff_prod by congruence |
                  rewrite update2_eq_prod  by auto ]; auto.
Qed.

Ltac update2_destruct_goal :=
  match goal with
  | [ |- context [ update2 ?eq_dec _ ?x ?y _ ?x' ?y' ] ] =>
    destruct (prod_eq_dec eq_dec eq_dec (x, y) (x', y'))
  end.

Ltac update2_destruct_hyp :=
  match goal with
  | [ _ : context [ update2 ?eq_dec _ ?x ?y _ ?x' ?y' ] |- _ ] =>
    destruct (prod_eq_dec eq_dec eq_dec (x, y) (x', y'))
  end.

Ltac update2_destruct := update2_destruct_goal || update2_destruct_hyp.

Ltac rewrite_update2' H :=
  first [rewrite update2_diff_prod in H by congruence |
         rewrite update2_eq_prod in H by auto ].

Ltac rewrite_update2 :=
  repeat match goal with
           | [ H : context [ update2 _ _ _ _ _ _ _ ] |- _ ] =>
             rewrite_update2' H; repeat rewrite_update2' H
           | [ |- _ ] => repeat (try rewrite update2_diff_prod by congruence;
                                 try rewrite update2_eq_prod by auto)
         end.

Ltac destruct_update2 :=
  repeat (update2_destruct; subst; rewrite_update2).

Ltac destruct_update2_hyp :=
  repeat ((update2_destruct_hyp || update2_destruct_goal); subst; rewrite_update2).

Ltac update2_destruct_simplify :=
  update2_destruct; subst; rewrite_update2; simpl in *.

Ltac update2_destruct_simplify_hyp :=
  update2_destruct_hyp || update2_destruct_goal; subst; rewrite_update2; simpl in *.

Ltac update2_destruct_max_simplify :=
  update2_destruct; subst_max; rewrite_update2; simpl in *.

Section Update2Rel.
  Variables A B : Type.
  Variable R : relation A.

  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.
  Hypothesis R_dec : forall x y : A, {R x y} + {~ R x y}.

  Lemma filter_rel_related :
    forall n n' ns,
      In n' (filter_rel R_dec n ns) ->
      In n' ns /\ R n n'.
  Proof using.
    intros.
    induction ns; simpl in *; [ intuition | idtac ].
    break_if; simpl in *.
    - break_or_hyp; auto.
      concludes.
      break_and.
      auto.
    - concludes.
      break_and.
      auto.
  Qed.

  Lemma related_filter_rel :
    forall n n' ns,
      In n' ns ->
      R n n' ->
      In n' (filter_rel R_dec n ns).
  Proof using.
    intros.
    induction ns; simpl in *; [ intuition | idtac ].
    break_if.
    - break_or_hyp.
      * left; auto.
      * concludes.
        right; auto.
    - break_or_hyp.
      * intuition.
      * concludes.
        assumption.
  Qed.

  Lemma not_in_not_in_filter_rel :
    forall ns n h,
      ~ In n ns ->
      ~ In n (filter_rel R_dec h ns).
  Proof using.
    induction ns; intros; auto.
    assert (H_neq: a <> n).
    intro.
    subst.
    auto with datatypes.
    assert (H_not_in: ~ In n ns).
    intro.
    intuition auto with datatypes.
    simpl.
    break_if; auto.
    simpl.
    intro.
    break_or_hyp; auto.
    intuition eauto.
  Qed.

  Lemma NoDup_filter_rel:
    forall h ns,
      NoDup ns ->
      NoDup (filter_rel R_dec h ns).
  Proof using.
    intros.
    induction ns; auto.
    invc_NoDup.
    concludes.
    simpl in *.
    break_if; auto.
    apply NoDup_cons; auto.
    apply not_in_not_in_filter_rel.
    assumption.
  Qed.

  Lemma filter_rel_self_eq {irreflexive_R : Irreflexive R} :
    forall ns0 ns1 h,
      filter_rel R_dec h (ns0 ++ h :: ns1) = filter_rel R_dec h (ns0 ++ ns1).
  Proof using.
    induction ns0; intros; simpl in *.
    - break_if; auto.
      find_apply_lem_hyp irreflexive_R.
      intuition.
    - break_if; auto.
      find_higher_order_rewrite.
      trivial.
  Qed.

  Lemma collate_f_eq :
    forall (f : A -> A -> list B) g h n n' l,
      f n n' = g n n' ->
      collate A_eq_dec h f l n n' = collate A_eq_dec h g l n n'.
  Proof using.
    intros f g h n n' l.
    generalize f g; clear f g.
    induction l; auto.
    intros.
    simpl in *.
    break_let.
    destruct a.
    find_injection.
    set (f' := update2 _ _ _ _ _).
    set (g' := update2 _ _ _ _ _).
    rewrite (IHl f' g'); auto.
    unfold f', g', update2.
    break_if; auto.
    break_and.
    subst.
    find_rewrite.
    trivial.
  Qed.

  Lemma collate_in_in :
    forall l h n n' (f : A -> A -> list B) a,
      In a (f n' n) ->
      In a ((collate A_eq_dec h f l) n' n).
  Proof using.
    induction l; intros; auto.
    destruct a.
    apply IHl.
    unfold update2.
    break_if; auto.
    break_and.
    subst.
    apply in_or_app.
    left.
    assumption.
  Qed.

  Lemma collate_head_head :
    forall l h n n' (f : A -> A -> list B) a,
      head (f n' n) = Some a ->
      head ((collate A_eq_dec h f l) n' n) = Some a.
  Proof using.
    induction l; intros; auto.
    destruct a.
    simpl.
    apply IHl.
    unfold update2.
    break_if; auto.
    break_and; subst.
    destruct (f n' n); auto.
    find_apply_lem_hyp hd_error_some_nil.
    intuition.
  Qed.

  Lemma collate_neq :
    forall h n n' ns (f : A -> A -> list B),
      h <> n ->
      collate A_eq_dec h f ns n n' = f n n'.
  Proof using.
    intros.
    revert f.
    induction ns; intros; auto.
    destruct a.
    simpl in *.
    rewrite IHns.
    unfold update2.
    break_if; auto.
    break_and; subst.
    intuition.
  Qed.

  Lemma collate_not_in_eq :
    forall h' h (f : A -> A -> list B) l,
      ~ In h (map fst l) ->
      collate A_eq_dec h' f l h' h = f h' h.
  Proof using.
    intros.
    revert f.
    induction l; intros; auto.
    simpl in *.
    break_let.
    destruct a.
    find_injection.
    rewrite IHl; unfold update2.
    - break_if.
      * break_and; subst.
        simpl in *.
        contradict H.
        left.
        trivial.
      * intros.
        trivial.
    - intro.
      contradict H.
      right.
      assumption.
  Qed.

  Lemma collate_app :
    forall h' l1 l2 (f : A -> A -> list B),
      collate A_eq_dec h' f (l1 ++ l2) = collate A_eq_dec h' (collate A_eq_dec h' f l1) l2.
  Proof using.
    induction l1; intros; auto.
    simpl.
    break_let.
    destruct a.
    find_injection.
    rewrite IHl1.
    trivial.
  Qed.

  Lemma collate_neq_update2 :
    forall h h' n (f : A -> A -> list B) l ms,
      n <> h' ->
      collate A_eq_dec h (update2 A_eq_dec f h n ms) l h h' = collate A_eq_dec h f l h h'.
  Proof using.
    intros.
    assert (H_eq: update2 A_eq_dec f h n ms h h' =  f h h').
    unfold update2.
    break_if; auto.
    break_and; subst.
    intuition.
    rewrite (collate_f_eq _ _ _ _ _ _ H_eq).
    trivial.
  Qed.

  Lemma collate_not_in :
    forall h h' l1 l2 (f : A -> A -> list B),
      ~ In h' (map fst l1) ->
      collate A_eq_dec h f (l1 ++ l2) h h' = collate A_eq_dec h f l2 h h'.
  Proof using.
    intros.
    rewrite collate_app.
    revert f.
    induction l1; intros; simpl in *; auto.
    break_let.
    rewrite IHl1.
    - destruct a.
      find_injection.
      simpl in *.
      assert (H_neq: a0 <> h').
      intro.
      contradict H.
      left.
      trivial.
      rewrite collate_neq_update2; trivial.
    - intro.
      contradict H.
      right.
      trivial.
  Qed.

  Lemma collate_not_in_rest :
    forall h h' l1 l2 (f : A -> A -> list B),
      ~ In h' (map fst l2) ->
      collate A_eq_dec h f (l1 ++ l2) h h' = collate A_eq_dec h f l1 h h'.
  Proof using.
    intros.
    rewrite collate_app.
    revert f.
    induction l2; intros; simpl in *; auto.
    break_let.
    subst_max.
    simpl in *.
    assert (H_neq: a0 <> h'); auto.
    rewrite collate_neq_update2; auto.
  Qed.

  Lemma collate_not_in_mid :
    forall h h' l1 l2 (f : A -> A -> list B) m,
      ~ In h (map fst (l1 ++ l2)) ->
      collate A_eq_dec h' (update2 A_eq_dec f h' h (f h' h ++ [m])) (l1 ++ l2) = collate A_eq_dec h' f (l1 ++ (h, m) :: l2).
  Proof using.
    intros h h' l1 l2 f m H_in.
    apply functional_extensionality; intro from.
    apply functional_extensionality; intro to.
    case (A_eq_dec h' from); intro H_dec.
    - rewrite <- H_dec.
      case (A_eq_dec h to); intro H_dec'.
      * rewrite <- H_dec'.
        rewrite collate_not_in.
      + subst.
        rewrite collate_not_in; auto.
        intro.
        contradict H_in.
        rewrite map_app.
        apply in_or_app.
        left.
        assumption.
      + intro.
        contradict H_in.
        rewrite map_app.
        apply in_or_app.
        left.
        assumption.
        * rewrite collate_neq_update2; auto.
          rewrite collate_app.
          rewrite collate_app.
          simpl.
          rewrite collate_neq_update2; auto.
    - rewrite collate_neq; auto.
      rewrite collate_neq; auto.
      unfold update2.
      break_if; auto.
      break_and; subst.
      intuition.
  Qed.

  Lemma NoDup_Permutation_collate_eq :
    forall h (f : A -> A -> list B) l l',
      NoDup (map fst l) ->
      Permutation l l' ->
      collate A_eq_dec h f l = collate A_eq_dec h f l'.
  Proof using.
    intros h f l.
    revert h f.
    induction l.
    - intros.
      find_apply_lem_hyp Permutation_nil.
      subst.
      trivial.
    - intros.
      destruct a.
      simpl in *.
      invc_NoDup.
      assert (H_in': In (a, b) ((a, b) :: l)).
      left.
      trivial.
      pose proof (Permutation_in _ H0 H_in') as H_pm'.
      apply in_split in H_pm'.
      break_exists; subst.
      find_apply_lem_hyp Permutation_cons_app_inv.
      pose proof (IHl h (update2 A_eq_dec f h a (f h a ++ [b])) _ H4 H0) as IHl'.
      rewrite IHl'.
      rewrite collate_not_in_mid; auto.
      intro.
      assert (H_pm': Permutation (map (fun nm : A * B => fst nm) l) (map (fun nm : A * B => fst nm) (x ++ x0))).
      apply Permutation_map_fst.
      trivial.
      contradict H3.
      revert H.
      apply Permutation_in.
      apply Permutation_sym.
      trivial.
  Qed.

  Lemma collate_map2snd_not_related :
    forall m n h ns (f : A -> A -> list B),
      ~ R h n ->
      collate A_eq_dec h f (map2snd m (filter_rel R_dec h ns)) h n = f h n.
  Proof using.
    intros m n h ns f H_adj.
    revert f.
    induction ns; intros; auto.
    simpl.
    break_if; simpl; auto.
    rewrite IHns.
    unfold update2.
    break_if; auto.
    break_and; subst.
    intuition.
  Qed.

  Lemma collate_map2snd_in_neq_in_before :
    forall from (f : A -> A -> list B) m dsts a b x,
      In x (collate A_eq_dec from f (map2snd m dsts) a b) ->
      x <> m ->
      In x (f a b).
  Proof using.
    intros.
    generalize dependent f.
    induction dsts.
    - auto.
    - simpl; intros f H_coll.
      eapply IHdsts in H_coll.
      destruct (A_eq_dec from a), (A_eq_dec a0 b); subst.
      + rewrite update2_same in *.
        find_eapply_lem_hyp in_app_or; break_or_hyp.
        * assumption.
        * exfalso;
          find_eapply_lem_hyp in_inv; break_or_hyp; exfalso; auto.
      + rewrite update2_diff2 in *; auto.
      + rewrite update2_diff1 in *; auto.
      + rewrite update2_diff1 in *; auto.
  Qed.

  Lemma collate_map2snd_not_in :
    forall m n h ns (f : A -> A -> list B),
      ~ In n ns ->
      collate A_eq_dec h f (map2snd m (filter_rel R_dec h ns)) h n = f h n.
  Proof using.
    intros m n h ns f.
    revert f.
    induction ns; intros; auto.
    simpl in *.
    break_if; simpl.
    - rewrite IHns.
      * unfold update2.
        break_if; auto.
        break_and; subst.
        contradict H.
        left.
        trivial.
      * intro.
        contradict H.
        right.
        assumption.
    - rewrite IHns; auto.
  Qed.

  Lemma collate_map2snd_not_in_remove_all :
    forall m n h ns (f : A -> A -> list B) ns',
      ~ In n ns ->
      collate A_eq_dec h f (map2snd m (filter_rel R_dec h (remove_all A_eq_dec ns' ns))) h n = f h n.
  Proof using.
    intros m n h ns f ns' H_in.
    apply collate_map2snd_not_in.
    intro.
    find_apply_lem_hyp in_remove_all_was_in.
    intuition.
  Qed.

  Lemma collate_map2snd_not_in_related :
    forall m n h ns (f : A -> A -> list B) ns',
      ~ In n ns' ->
      R h n ->
      In n ns ->
      NoDup ns ->
      collate A_eq_dec h f (map2snd m (filter_rel R_dec h (remove_all A_eq_dec ns' ns))) h n = f h n ++ [m].
  Proof using.
    intros m n h ns f ns' H_in H_adj.
    revert f.
    induction ns; intros; [ contradict H | idtac ].
    invc_NoDup.
    simpl in *.
    break_or_hyp.
    - pose proof (remove_all_cons A_eq_dec ns' n ns) as H_ra.
      break_or_hyp; break_and; intuition.
      find_rewrite.
      simpl.
      break_if; intuition.
      simpl.
      rewrite collate_map2snd_not_in_remove_all; auto.
      unfold update2.
      break_if; auto.
      intuition.
    - assert (H_neq: a <> n).
      intro.
      subst.
      intuition.
      pose proof (remove_all_cons A_eq_dec ns' a ns) as H_ra.
      break_or_hyp; break_and.
      * find_rewrite.
        rewrite IHns; auto.
      * find_rewrite.
        simpl.
        break_if; auto.
        simpl.
        rewrite IHns; auto.
        unfold update2.
        break_if; auto.
        break_and.
        subst.
        intuition.
  Qed.

  Lemma collate_map2snd_in :
    forall m n h ns (f : A -> A -> list B) ns',
      In n ns' ->
      collate A_eq_dec h f (map2snd m (filter_rel R_dec h (remove_all A_eq_dec ns' ns))) h n = f h n.
  Proof using.
    intros m n h ns f ns'.
    revert f.
    induction ns; intros.
    - rewrite remove_all_nil.
      trivial.
    - pose proof (remove_all_cons A_eq_dec ns' a ns) as H_ra.
      break_or_hyp; break_and; find_rewrite.
      * rewrite IHns; trivial.
      * simpl.
        break_if.
      + simpl.
        rewrite IHns; simpl; auto.
        unfold update2.
        break_if; auto.
        break_and; subst.
        intuition.
      + rewrite IHns; trivial.
  Qed.

  Lemma collate_map2snd_related_not_in :
    forall a n h ns (f : A -> A -> list B),
      R h n ->
      ~ In n ns ->
      collate A_eq_dec h f (map2snd a (filter_rel R_dec h (n :: ns))) h n = f h n ++ [a].
  Proof using.
    intros a n h ns f H_adj H_in.
    simpl.
    break_if; intuition.
    clear r.
    revert f n h H_in H_adj.
    induction ns; intros; simpl.
    - unfold update2.
      break_if; auto.
      intuition.
    - assert (H_in': ~ In n ns).
      intro.
      contradict H_in.
      right.
      trivial.
      assert (H_neq: n <> a0).
      intro.
      subst.
      contradict H_in.
      left.
      trivial.
      simpl in *.
      break_if.
      * simpl.
        unfold update2 at 3.
        break_if; intuition eauto.
        pose proof (IHns f) as IH'.
        rewrite collate_map2snd_not_in; auto.
        unfold update2.
        break_if; intuition eauto.
        break_if; auto.
        intuition.
      * rewrite IHns; auto.
  Qed.

  Lemma in_collate_in :
    forall ns n h (f : A -> A -> list B) a,
      ~ In n ns ->
      In a (collate A_eq_dec h f (map2snd a (filter_rel R_dec h ns)) h n) ->
      In a (f h n).
  Proof using.
    induction ns; intros; auto.
    assert (H_in': ~ In n ns).
    intro.
    contradict H.
    right.
    trivial.
    assert (H_neq: n <> a).
    intro.
    subst.
    contradict H.
    left.
    trivial.
    simpl in *.
    break_if; auto.
    simpl in *.
    assert (H_eq_f: update2 A_eq_dec f h a (f h a ++ [a0]) h n = f h n).
    unfold update2.
    break_if; auto.
    break_and; subst.
    intuition.
    rewrite (collate_f_eq _ _ _ _ _ _ H_eq_f) in H0.
    apply IHns; auto.
  Qed.

  Lemma not_in_map2snd :
    forall n h (m : B) ns,
      ~ In n ns ->
      ~ In (n, m) (map2snd m (filter_rel R_dec h ns)).
  Proof using.
    intros.
    induction ns; intros; auto.
    simpl in *.
    break_if.
    - simpl.
      intro.
      break_or_hyp.
      * find_injection.
        contradict H.
        left.
        trivial.
      * contradict H1.
        apply IHns.
        intro.
        contradict H.
        right.
        assumption.
    - apply IHns.
      intro.
      contradict H.
      right.
      assumption.
  Qed.

  Lemma NoDup_map2snd :
    forall h (m : B) ns,
      NoDup ns ->
      NoDup (map2snd m (filter_rel R_dec h ns)).
  Proof using.
    intros.
    induction ns.
    - apply NoDup_nil.
    - invc_NoDup.
      concludes.
      simpl.
      break_if; auto.
      simpl.
      apply NoDup_cons; auto.
      apply not_in_map2snd.
      assumption.
  Qed.

  Lemma in_map2snd_snd :
    forall h (m : B) ns nm,
      In nm (map2snd m (filter_rel R_dec h ns)) ->
      snd nm = m.
  Proof using.
    intros.
    induction ns; intros; simpl in *; intuition.
    break_if.
    - simpl in *.
      break_or_hyp; intuition eauto.
    - apply IHns.
      assumption.
  Qed.

  Lemma in_map2snd_related_in :
    forall (m : B) ns n h,
      In (n, m) (map2snd m (filter_rel R_dec h ns)) ->
      R h n /\ In n ns.
  Proof using.
    intros m.
    induction ns; intros; simpl in *; [ intuition | idtac ].
    break_if; simpl in *.
    - break_or_hyp.
      * find_injection; auto.
      * find_apply_hyp_hyp.
        break_and.
        auto.
    - find_apply_hyp_hyp.
      break_and.
      auto.
  Qed.

  Lemma collate_ls_not_in :
    forall ns (f : A -> A -> list B) h mg from to,
      ~ In from ns ->
      collate_ls A_eq_dec ns f h mg from to = f from to.
  Proof using.
    induction ns; intros; auto.
    assert (H_neq: a <> from).
    intro.
    subst.
    contradict H.
    left.
    trivial.
    assert (H_in': ~ In from ns).
    intro.
    contradict H.
    right.
    assumption.
    simpl.
    rewrite IHns; auto.
    unfold update2.
    break_if; auto.
    break_and; subst.
    intuition.
  Qed.

  Lemma collate_ls_in_in :
    forall ns (f : A -> A -> list B) to m x a b,
      In x (f a b) ->
      In x (collate_ls A_eq_dec ns f to m a b).
  Proof using.
    intros.
    generalize dependent f.
    induction ns.
    - auto.
    - intros.
      simpl.
      eapply IHns; eauto.
      destruct (A_eq_dec a a0), (A_eq_dec to b); subst.
      + rewrite update2_eq; auto using in_or_app.
      + rewrite update2_diff2; auto using in_or_app.
      + rewrite update2_diff1; auto using in_or_app.
      + rewrite update2_diff1; auto using in_or_app.
  Qed.

  Lemma collate_ls_neq_to :
    forall ns (f : A -> A -> list B) h mg from to,
      h <> to ->
      collate_ls A_eq_dec ns f h mg from to = f from to.
  Proof using.
    induction ns; intros; auto.
    simpl in *.
    rewrite IHns; auto.
    unfold update2.
    break_if; auto.
    break_and; subst.
    intuition.
  Qed.

  Lemma collate_ls_NoDup_in :
    forall ns (f : A -> A -> list B) h mg from,
      NoDup ns ->
      In from ns ->
      collate_ls A_eq_dec ns f h mg from h = f from h ++ [mg].
  Proof using.
    induction ns; intros; simpl in *; [ intuition | idtac ].
    invc_NoDup.
    break_or_hyp.
    - rewrite collate_ls_not_in; auto.
      unfold update2.
      break_if; auto.
      break_or_hyp; intuition.
    - assert (H_neq: a <> from).
      intro.
      find_rewrite.
      auto.
      rewrite IHns; auto.
      unfold update2.
      break_if; auto.
      break_and; subst.
      intuition.
  Qed.

  Lemma collate_ls_live_related :
    forall ns (f : A -> A -> list B) ns' h mg from,
      ~ In from ns' ->
      R h from ->
      In from ns ->
      NoDup ns ->
      collate_ls A_eq_dec (filter_rel R_dec h (remove_all A_eq_dec ns' ns)) f h mg from h = f from h ++ [mg].
  Proof using.
    intros.
    rewrite collate_ls_NoDup_in; auto.
    - apply NoDup_filter_rel.
      apply NoDup_remove_all.
      assumption.
    - apply related_filter_rel.
      apply in_remove_all_preserve; auto.
      assumption.
  Qed.

  Lemma collate_ls_f_eq :
    forall ns (f : A -> A -> list B) g h mg n n',
      f n n' = g n n' ->
      collate_ls A_eq_dec ns f h mg n n' = collate_ls A_eq_dec ns g h mg n n'.
  Proof using.
    induction ns; intros; simpl in *; auto.
    set (f' := update2 _ _ _ _ _).
    set (g' := update2 _ _ _ _ _).
    rewrite (IHns f' g'); auto.
    unfold f', g', update2.
    break_if; auto.
    break_and.
    subst.
    find_rewrite.
    trivial.
  Qed.

  Lemma collate_ls_neq_update2 :
    forall ns (f : A -> A -> list B) n h h' ms mg,
      n <> h' ->
      collate_ls A_eq_dec ns (update2 A_eq_dec f n h ms) h mg h' h = collate_ls A_eq_dec ns f h mg h' h.
  Proof using.
    intros.
    assert (H_eq: update2 A_eq_dec f n h ms h' h = f h' h).
    unfold update2.
    break_if; auto.
    break_and.
    subst.
    intuition.
    rewrite (collate_ls_f_eq _ _ _ _ _ _ _ H_eq).
    trivial.
  Qed.

  Lemma collate_ls_cases :
    forall s (f : A -> A -> list B) to m a b,
      collate_ls A_eq_dec s f to m a b = f a b \/
      exists l,
        (forall x, In x l -> x = m) /\
        collate_ls A_eq_dec s f to m a b = f a b ++ l.
  Proof using.
    intros.
    generalize dependent f.
    induction s as [|n s].
    - auto.
    - intros.
      simpl in *.
      destruct (A_eq_dec b to), (A_eq_dec n a); subst.
      + specialize (IHs (update2 A_eq_dec f a to (f a to ++ [m])));
          break_or_hyp.
        * find_rewrite.
          rewrite update2_eq; eauto.
          right; eexists; intuition.
          find_apply_lem_hyp in_inv;
            break_or_hyp;
            [|exfalso]; eauto using in_nil.
        * break_exists_name l; break_and.
          repeat find_rewrite.
          rewrite update2_same.
          right; exists (m :: l).
          split.
          -- intros;
               find_apply_lem_hyp in_inv;
               intuition.
          -- rewrite <- app_assoc; auto.
      + rewrite collate_ls_neq_update2; auto.
      + rewrite collate_ls_neq_to, update2_diff2; auto.
      + rewrite collate_ls_neq_to, update2_diff2; auto.
  Qed.

  Lemma collate_ls_in_neq_in_before :
    forall s (f : A -> A -> list B) to m a b x,
      In x (collate_ls A_eq_dec s f to m a b) ->
      x <> m ->
      In x (f a b).
  Proof using.
    intros.
    pose proof (collate_ls_cases s f to m a b); break_or_hyp.
    - now find_rewrite.
    - break_exists; break_and.
      find_rewrite.
    find_apply_lem_hyp in_app_or; break_or_hyp; auto.
    find_apply_hyp_hyp; congruence.
  Qed.

  Lemma collate_ls_not_related :
    forall ns (f : A -> A -> list B) n h mg,
      ~ R h n ->
      collate_ls A_eq_dec (filter_rel R_dec h ns) f h mg n h = f n h.
  Proof using.
    induction ns; intros; simpl in *; auto.
    case (A_eq_dec n a); intro.
    - subst.
      break_if; auto.
      intuition.
    - break_if; auto.
      simpl.
      rewrite IHns; auto.
      unfold update2.
      break_if; auto.
      break_and.
      subst.
      intuition.
  Qed.

  Lemma collate_ls_not_in_related :
    forall ns (f : A -> A -> list B) n h mg,
      ~ In n ns ->
      collate_ls A_eq_dec (filter_rel R_dec h ns) f h mg n h = f n h.
  Proof using.
    intros.
    rewrite collate_ls_not_in; auto.
    apply not_in_not_in_filter_rel.
    assumption.
  Qed.

  Lemma collate_ls_not_in_related_remove_all :
    forall ns (f : A -> A -> list B) n h mg ns',
      ~ In n ns ->
      collate_ls A_eq_dec (filter_rel R_dec h (remove_all A_eq_dec ns' ns)) f h mg n h = f n h.
  Proof using.
    intros.
    rewrite collate_ls_not_in; auto.
    apply not_in_not_in_filter_rel.
    intro.
    contradict H.
    eapply in_remove_all_was_in; eauto.
  Qed.

  Lemma collate_ls_in_remove_all :
    forall mg n h ns (f : A -> A -> list B) ns',
      In n ns' ->
      collate_ls A_eq_dec (filter_rel R_dec h (remove_all A_eq_dec ns' ns)) f h mg n h = f n h.
  Proof using.
    intros.
    revert f.
    induction ns; intros.
    - rewrite remove_all_nil.
      trivial.
    - pose proof (remove_all_cons A_eq_dec ns' a ns) as H_cn.
      break_or_hyp; break_and; find_rewrite.
      * rewrite IHns.
        trivial.
      * simpl in *.
        break_if; auto.
        simpl.
        assert (H_neq: a <> n).
        intro.
        subst.
        intuition.
        rewrite IHns.
        unfold update2.
        break_if; auto.
        break_and; subst.
        intuition.
  Qed.

  Lemma collate_ls_app :
    forall l1 l2 (f : A -> A -> list B) h m,
      collate_ls A_eq_dec (l1 ++ l2) f h m = collate_ls A_eq_dec l2 (collate_ls A_eq_dec l1 f h m) h m.
  Proof using.
    induction l1; simpl in *; intuition eauto.
  Qed.

  Lemma collate_ls_split_eq :
    forall l1 l2 (f : A -> A -> list B) h m from to,
      h <> from ->
      collate_ls A_eq_dec (l1 ++ h :: l2) f to m from to =
      collate_ls A_eq_dec  (l1 ++ l2) f to m from to.
  Proof using.
    induction l1; simpl in *; auto.
    intros.
    apply collate_ls_f_eq.
    unfold update2.
    break_if; auto.
    break_and.
    subst.
    intuition.
  Qed.

  Lemma collate_ls_not_in_mid :
    forall h h' l1 l2 (f : A -> A -> list B) m,
      ~ In h' (l1 ++ l2) ->
      collate_ls A_eq_dec (l1 ++ l2) (update2 A_eq_dec f h' h (f h' h ++ [m])) h m = collate_ls A_eq_dec (l1 ++ h' :: l2) f h m.
  Proof using.
    intros h h' l1 l2 f m H_in.
    apply functional_extensionality; intro from.
    apply functional_extensionality; intro to.
    case (A_eq_dec h' from); intro H_dec; case (A_eq_dec h to); intro H_dec'.
    - rewrite <- H_dec.
      rewrite <- H_dec'.
      rewrite collate_ls_not_in; auto.
      rewrite collate_ls_app; simpl.
      set (f' := collate_ls _ l1 _ _ _).
      rewrite collate_ls_not_in.
      * unfold update2 at 2.
        break_if.
      + unfold f'.
        rewrite collate_ls_not_in.
        -- unfold update2.
           break_if; auto.
           break_or_hyp; intuition.
        -- intro.
           contradict H_in.
           apply in_or_app.
           left.
           assumption.
      + break_or_hyp; intuition.
        * intro.
          contradict H_in.
          apply in_or_app.
          right.
          assumption.
    - rewrite collate_ls_neq_to; auto.
      rewrite collate_ls_neq_to; auto.
      unfold update2.
      break_if; auto.
      break_and; subst.
      intuition.
    - rewrite H_dec'.
      rewrite collate_ls_neq_update2; auto.
      rewrite collate_ls_split_eq; auto.
    - rewrite collate_ls_neq_to; auto.
      rewrite collate_ls_neq_to; auto.
      unfold update2.
      break_if; auto.
      break_and; subst.
      intuition.
  Qed.

  Lemma NoDup_Permutation_collate_ls_eq :
    forall l (f : A -> A -> list B) h m l',
      NoDup l ->
      Permutation l l' ->
      collate_ls A_eq_dec l f h m = collate_ls A_eq_dec l' f h m.
  Proof using.
    intros l f h m l'.
    revert f l'.
    induction l.
    - intros.
      find_apply_lem_hyp Permutation_nil.
      subst.
      trivial.
    - intros.
      invc_NoDup.
      simpl in *.
      assert (H_in: In a (a :: l)).
      left.
      trivial.
      pose proof (Permutation_in _ H0 H_in) as H_pm'.
      find_apply_lem_hyp in_split.
      break_exists.
      subst_max.
      find_apply_lem_hyp Permutation_cons_app_inv.
      set (f' := update2 _ _ _ _ _).
      rewrite (IHl f' _ H4 H0); auto.
      unfold f'.
      rewrite collate_ls_not_in_mid; auto.
      intro.
      contradict H3.
      revert H.
      apply Permutation_in.
      apply Permutation_sym.
      assumption.
  Qed.

End Update2Rel.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paco7 pacotac.
Set Implicit Arguments.

Section GeneralizedPaco7.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.

Local Notation rel := (rel7 T0 T1 T2 T3 T4 T5 T6).

Section RClo.

Inductive rclo7 (clo: rel->rel) (r: rel): rel :=
| rclo7_base
    x0 x1 x2 x3 x4 x5 x6
    (IN: r x0 x1 x2 x3 x4 x5 x6):
    @rclo7 clo r x0 x1 x2 x3 x4 x5 x6
| rclo7_clo'
    r' x0 x1 x2 x3 x4 x5 x6
    (LE: r' <7= rclo7 clo r)
    (IN: clo r' x0 x1 x2 x3 x4 x5 x6):
    @rclo7 clo r x0 x1 x2 x3 x4 x5 x6
.

Lemma rclo7_mon_gen clo clo' r r' x0 x1 x2 x3 x4 x5 x6
      (IN: @rclo7 clo r x0 x1 x2 x3 x4 x5 x6)
      (LEclo: clo <8= clo')
      (LEr: r <7= r') :
  @rclo7 clo' r' x0 x1 x2 x3 x4 x5 x6.
Proof.
  induction IN; intros.
  - econstructor 1. apply LEr, IN.
  - econstructor 2; [intros; eapply H, PR|apply LEclo, IN].
Qed.

Lemma rclo7_mon clo:
  monotone7 (rclo7 clo).
Proof.
  repeat intro. eapply rclo7_mon_gen; [apply IN|intros; apply PR|apply LE].
Qed.

Lemma rclo7_clo clo r:
  clo (rclo7 clo r) <7= rclo7 clo r.
Proof.
  intros. econstructor 2; [|apply PR].
  intros. apply PR0.
Qed.

Lemma rclo7_clo_base clo r:
  clo r <7= rclo7 clo r.
Proof.
  intros. eapply rclo7_clo', PR.
  intros. apply rclo7_base, PR0.
Qed.

Lemma rclo7_rclo clo r:
  rclo7 clo (rclo7 clo r) <7= rclo7 clo r.
Proof.
  intros. induction PR.
  - eapply IN.
  - econstructor 2; [eapply H | eapply IN].
Qed.

Lemma rclo7_compose clo r:
  rclo7 (rclo7 clo) r <7= rclo7 clo r.
Proof.
  intros. induction PR.
  - apply rclo7_base, IN.
  - apply rclo7_rclo.
    eapply rclo7_mon; [apply IN|apply H].
Qed.

End RClo.

Section Main.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone7 gf.

Variant gpaco7 clo r rg x0 x1 x2 x3 x4 x5 x6 : Prop :=
| gpaco7_intro (IN: @rclo7 clo (paco7 (compose gf (rclo7 clo)) (rg \7/ r) \7/ r) x0 x1 x2 x3 x4 x5 x6)
.

Definition gupaco7 clo r := gpaco7 clo r r.

Lemma gpaco7_def_mon clo : monotone7 (compose gf (rclo7 clo)).
Proof.
  eapply monotone7_compose. apply gf_mon. apply rclo7_mon.
Qed.

#[local] Hint Resolve gpaco7_def_mon : paco.

Lemma gpaco7_mon clo r r' rg rg' x0 x1 x2 x3 x4 x5 x6
      (IN: @gpaco7 clo r rg x0 x1 x2 x3 x4 x5 x6)
      (LEr: r <7= r')
      (LErg: rg <7= rg'):
  @gpaco7 clo r' rg' x0 x1 x2 x3 x4 x5 x6.
Proof.
  destruct IN. econstructor.
  eapply rclo7_mon. apply IN.
  intros. destruct PR; [|right; apply LEr, H].
  left. eapply paco7_mon. apply H.
  intros. destruct PR.
  - left. apply LErg, H0.
  - right. apply LEr, H0.
Qed.

Lemma gupaco7_mon clo r r' x0 x1 x2 x3 x4 x5 x6
      (IN: @gupaco7 clo r x0 x1 x2 x3 x4 x5 x6)
      (LEr: r <7= r'):
  @gupaco7 clo r' x0 x1 x2 x3 x4 x5 x6.
Proof.
  eapply gpaco7_mon. apply IN. apply LEr. apply LEr.
Qed.

Lemma gpaco7_base clo r rg: r <7= gpaco7 clo r rg.
Proof.
  econstructor. apply rclo7_base. right. apply PR.
Qed.

Lemma gpaco7_gen_guard  clo r rg:
  gpaco7 clo r (rg \7/ r) <7= gpaco7 clo r rg.
Proof.
  intros. destruct PR. econstructor.
  eapply rclo7_mon. apply IN. intros.
  destruct PR; [|right; apply H].
  left. eapply paco7_mon_gen; intros. apply H. apply PR.
  destruct PR. apply H0. right. apply H0.
Qed.

Lemma gpaco7_rclo clo r rg:
  rclo7 clo r <7= gpaco7 clo r rg.
Proof.
  intros. econstructor.
  eapply rclo7_mon. apply PR.
  intros. right. apply PR0.
Qed.

Lemma gpaco7_clo clo r rg:
  clo r <7= gpaco7 clo r rg.
Proof.
  intros. apply gpaco7_rclo. eapply rclo7_clo_base, PR.
Qed.

Lemma gpaco7_gen_rclo clo r rg:
  gpaco7 (rclo7 clo) r rg <7= gpaco7 clo r rg.
Proof.
  intros. destruct PR. econstructor.
  apply rclo7_compose.
  eapply rclo7_mon. apply IN. intros.
  destruct PR; [|right; apply H].
  left. eapply paco7_mon_gen; intros; [apply H| |apply PR].
  eapply gf_mon, rclo7_compose. apply PR.
Qed.

Lemma gpaco7_step_gen clo r rg:
  gf (gpaco7 clo (rg \7/ r) (rg \7/ r)) <7= gpaco7 clo r rg.
Proof.
  intros. econstructor. apply rclo7_base. left.
  pstep. eapply gf_mon. apply PR.
  intros. destruct PR0. eapply rclo7_mon. apply IN.
  intros. destruct PR0.
  - left. eapply paco7_mon. apply H. intros. destruct PR0; apply H0.
  - right. apply H.
Qed.

Lemma gpaco7_step clo r rg:
  gf (gpaco7 clo rg rg) <7= gpaco7 clo r rg.
Proof.
  intros. apply gpaco7_step_gen.
  eapply gf_mon. apply PR. intros.
  eapply gpaco7_mon. apply PR0. left; apply PR1. left; apply PR1.
Qed.

Lemma gpaco7_final clo r rg:
  (r \7/ paco7 gf rg) <7= gpaco7 clo r rg.
Proof.
  intros. destruct PR. apply gpaco7_base, H.
  econstructor. apply rclo7_base.
  left. eapply paco7_mon_gen. apply H.
  - intros. eapply gf_mon. apply PR.
    intros. apply rclo7_base. apply PR0.
  - intros. left. apply PR.
Qed.

Lemma gpaco7_unfold clo r rg:
  gpaco7 clo r rg <7= rclo7 clo (gf (gupaco7 clo (rg \7/ r)) \7/ r).
Proof.
  intros. destruct PR.
  eapply rclo7_mon. apply IN.
  intros. destruct PR; cycle 1. right; apply H.
  left. _punfold H; [|apply gpaco7_def_mon].
  eapply gf_mon. apply H.
  intros. econstructor.
  eapply rclo7_mon. apply PR.
  intros. destruct PR0; cycle 1. right. apply H0.
  left. eapply paco7_mon. apply H0.
  intros. left. apply PR0.
Qed.

Lemma gpaco7_cofix clo r rg
      l (OBG: forall rr (INC: rg <7= rr) (CIH: l <7= rr), l <7= gpaco7 clo r rr):
  l <7= gpaco7 clo r rg.
Proof.
  assert (IN: l <7= gpaco7 clo r (rg \7/ l)).
  { intros. apply OBG; [left; apply PR0 | right; apply PR0 | apply PR]. }
  clear OBG. intros. apply IN in PR.
  destruct PR. econstructor.
  eapply rclo7_mon. apply IN0.
  clear x0 x1 x2 x3 x4 x5 x6 IN0.
  intros. destruct PR; [|right; apply H].
  left. revert x0 x1 x2 x3 x4 x5 x6 H.
  pcofix CIH. intros.
  _punfold H0; [..|apply gpaco7_def_mon]. pstep.
  eapply gf_mon. apply H0. intros.
  apply rclo7_rclo. eapply rclo7_mon. apply PR.
  intros. destruct PR0.
  - apply rclo7_base. right. apply CIH. apply H.
  - destruct H; [destruct H|].
    + apply rclo7_base. right. apply CIH0. left. apply H.
    + apply IN in H. destruct H.
      eapply rclo7_mon. apply IN0.
      intros. destruct PR0.
      * right. apply CIH. apply H.
      * right. apply CIH0. right. apply H.
    + apply rclo7_base. right. apply CIH0. right. apply H.
Qed.

Lemma gpaco7_gupaco clo r rg:
  gupaco7 clo (gpaco7 clo r rg) <7= gpaco7 clo r rg.
Proof.
  eapply gpaco7_cofix.
  intros. destruct PR. econstructor.
  apply rclo7_rclo. eapply rclo7_mon. apply IN.
  intros. destruct PR.
  - apply rclo7_base. left.
    eapply paco7_mon. apply H.
    intros. left; apply CIH.
    econstructor. apply rclo7_base. right.
    destruct PR; apply H0.
  - destruct H. eapply rclo7_mon. apply IN0.
    intros. destruct PR; [| right; apply H].
    left. eapply paco7_mon. apply H.
    intros. destruct PR.
    + left. apply INC. apply H0.
    + right. apply H0.
Qed.

Lemma gpaco7_gpaco clo r rg:
  gpaco7 clo (gpaco7 clo r rg) (gupaco7 clo (rg \7/ r)) <7= gpaco7 clo r rg.
Proof.
  intros. apply gpaco7_unfold in PR.
  econstructor. apply rclo7_rclo. eapply rclo7_mon. apply PR. clear x0 x1 x2 x3 x4 x5 x6 PR. intros.
  destruct PR; [|destruct H; apply IN].
  apply rclo7_base. left. pstep.
  eapply gf_mon. apply H. clear x0 x1 x2 x3 x4 x5 x6 H. intros.
  cut (@gupaco7 clo (rg \7/ r) x0 x1 x2 x3 x4 x5 x6).
  { intros. destruct H. eapply rclo7_mon. apply IN. intros.
    destruct PR0; [|right; apply H].
    left. eapply paco7_mon. apply H. intros. destruct PR0; apply H0.
  }
  apply gpaco7_gupaco. eapply gupaco7_mon. apply PR. intros.
  destruct PR0; [apply H|].
  eapply gpaco7_mon; [apply H|right|left]; intros; apply PR0.
Qed.

Lemma gpaco7_uclo uclo clo r rg
      (LEclo: uclo <8= gupaco7 clo) :
  uclo (gpaco7 clo r rg) <7= gpaco7 clo r rg.
Proof.
  intros. apply gpaco7_gupaco. apply LEclo, PR.
Qed.

Lemma gpaco7_weaken  clo r rg:
  gpaco7 (gupaco7 clo) r rg <7= gpaco7 clo r rg.
Proof.
  intros. apply gpaco7_unfold in PR.
  induction PR.
  - destruct IN; cycle 1. apply gpaco7_base, H.
    apply gpaco7_step_gen. eapply gf_mon. apply H.
    clear x0 x1 x2 x3 x4 x5 x6 H.
    eapply gpaco7_cofix. intros.
    apply gpaco7_unfold in PR.
    induction PR.
    + destruct IN; cycle 1. apply gpaco7_base, H.
      apply gpaco7_step. eapply gf_mon. apply H.
      intros. apply gpaco7_base. apply CIH.
      eapply gupaco7_mon. apply PR.
      intros. destruct PR0; apply H0.
    + apply gpaco7_gupaco.
      eapply gupaco7_mon. apply IN. apply H.
  - apply gpaco7_gupaco.
    eapply gupaco7_mon. apply IN. apply H.
Qed.

End Main.

#[local] Hint Resolve gpaco7_def_mon : paco.

Section GeneralMonotonicity.

Variable gf: rel -> rel.

Lemma gpaco7_mon_gen (gf' clo clo': rel -> rel) x0 x1 x2 x3 x4 x5 x6 r r' rg rg'
      (IN: @gpaco7 gf clo r rg x0 x1 x2 x3 x4 x5 x6)
      (gf_mon: monotone7 gf)
      (LEgf: gf <8= gf')
      (LEclo: clo <8= clo')
      (LEr: r <7= r')
      (LErg: rg <7= rg') :
  @gpaco7 gf' clo' r' rg' x0 x1 x2 x3 x4 x5 x6.
Proof.
  eapply gpaco7_mon; [|apply LEr|apply LErg].
  destruct IN. econstructor.
  eapply rclo7_mon_gen. apply IN. apply LEclo.
  intros. destruct PR; [| right; apply H].
  left. eapply paco7_mon_gen. apply H.
  - intros. eapply LEgf.
    eapply gf_mon. apply PR.
    intros. eapply rclo7_mon_gen. apply PR0. apply LEclo. intros; apply PR1.
  - intros. apply PR.
Qed.

Lemma gpaco7_mon_bot (gf' clo clo': rel -> rel) x0 x1 x2 x3 x4 x5 x6 r' rg'
      (IN: @gpaco7 gf clo bot7 bot7 x0 x1 x2 x3 x4 x5 x6)
      (gf_mon: monotone7 gf)
      (LEgf: gf <8= gf')
      (LEclo: clo <8= clo'):
  @gpaco7 gf' clo' r' rg' x0 x1 x2 x3 x4 x5 x6.
Proof.
  eapply gpaco7_mon_gen. apply IN. apply gf_mon. apply LEgf. apply LEclo. contradiction. contradiction.
Qed.

Lemma gupaco7_mon_gen (gf' clo clo': rel -> rel) x0 x1 x2 x3 x4 x5 x6 r r'
      (IN: @gupaco7 gf clo r x0 x1 x2 x3 x4 x5 x6)
      (gf_mon: monotone7 gf)
      (LEgf: gf <8= gf')
      (LEclo: clo <8= clo')
      (LEr: r <7= r'):
  @gupaco7 gf' clo' r' x0 x1 x2 x3 x4 x5 x6.
Proof.
  eapply gpaco7_mon_gen. apply IN. apply gf_mon. apply LEgf. apply LEclo. apply LEr. apply LEr.
Qed.

End GeneralMonotonicity.

Section Compatibility.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone7 gf.

Structure compatible7 (clo: rel -> rel) : Prop :=
  compat7_intro {
      compat7_mon: monotone7 clo;
      compat7_compat : forall r,
          clo (gf r) <7= gf (clo r);
    }.

Structure wcompatible7 clo : Prop :=
  wcompat7_intro {
      wcompat7_mon: monotone7 clo;
      wcompat7_wcompat : forall r,
          clo (gf r) <7= gf (gupaco7 gf clo r);
    }.

Lemma rclo7_dist clo
      (MON: monotone7 clo)
      (DIST: forall r1 r2, clo (r1 \7/ r2) <7= (clo r1 \7/ clo r2)):
  forall r1 r2, rclo7 clo (r1 \7/ r2) <7= (rclo7 clo r1 \7/ rclo7 clo r2).
Proof.
  intros. induction PR.
  + destruct IN; [left|right]; apply rclo7_base, H.
  + assert (REL: clo (rclo7 clo r1 \7/ rclo7 clo r2) x0 x1 x2 x3 x4 x5 x6).
    { eapply MON. apply IN. apply H. }
    apply DIST in REL. destruct REL; [left|right]; apply rclo7_clo, H0.
Qed.

Lemma rclo7_compat clo
      (COM: compatible7 clo):
  compatible7 (rclo7 clo).
Proof.
  econstructor.
  - apply rclo7_mon.
  - intros. induction PR.
    + eapply gf_mon. apply IN.
      intros. eapply rclo7_base. apply PR.
    + eapply gf_mon.
      * eapply COM. eapply COM. apply IN. apply H.
      * intros. eapply rclo7_clo. apply PR.
Qed.

Lemma rclo7_wcompat clo
      (COM: wcompatible7 clo):
  wcompatible7 (rclo7 clo).
Proof.
  econstructor.
  - apply rclo7_mon.
  - intros. induction PR.
    + eapply gf_mon. apply IN.
      intros. apply gpaco7_base. apply PR.
    + eapply gf_mon.
      * eapply COM. eapply COM. apply IN. apply H.
      * intros. eapply gpaco7_gupaco. apply gf_mon.
        eapply gupaco7_mon_gen; intros; [apply PR|apply gf_mon|apply PR0| |apply PR0].
        apply rclo7_clo_base, PR0.
Qed.

Lemma compat7_wcompat clo
      (CMP: compatible7 clo):
  wcompatible7 clo.
Proof.
  econstructor. apply CMP.
  intros. apply CMP in PR.
  eapply gf_mon. apply PR.
  intros. apply gpaco7_clo, PR0.
Qed.

Lemma wcompat7_compat clo
      (WCMP: wcompatible7 clo) :
  compatible7 (gupaco7 gf clo).
Proof.
  econstructor.
  { red; intros. eapply gpaco7_mon. apply IN. apply LE. apply LE. }

  intros. apply gpaco7_unfold in PR; [|apply gf_mon].
  induction PR.
  - destruct IN; cycle 1.
    + eapply gf_mon. apply H.
      intros. apply gpaco7_base, PR.
    + eapply gf_mon. apply H.
      intros. apply gpaco7_gupaco. apply gf_mon.
      eapply gupaco7_mon. apply PR.
      intros. apply gpaco7_step. apply gf_mon.
      eapply gf_mon. destruct PR0 as [X|X]; apply X.
      intros. apply gpaco7_base, PR1.
  - eapply gf_mon, gpaco7_gupaco, gf_mon.
    apply WCMP. eapply WCMP. apply IN.
    intros. apply H, PR.
Qed.

Lemma wcompat7_union clo1 clo2
      (WCMP1: wcompatible7 clo1)
      (WCMP2: wcompatible7 clo2):
  wcompatible7 (clo1 \8/ clo2).
Proof.
  econstructor.
  - apply monotone7_union. apply WCMP1. apply WCMP2.
  - intros. destruct PR.
    + apply WCMP1 in H. eapply gf_mon. apply H.
      intros. eapply gupaco7_mon_gen. apply PR. apply gf_mon.
      intros; apply PR0. left; apply PR0. intros; apply PR0.
    + apply WCMP2 in H. eapply gf_mon. apply H.
      intros. eapply gupaco7_mon_gen. apply PR. apply gf_mon.
      intros; apply PR0. right; apply PR0. intros; apply PR0.
Qed.

End Compatibility.

Section Soundness.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone7 gf.

Lemma gpaco7_compat_init clo
      (CMP: compatible7 gf clo):
  gpaco7 gf clo bot7 bot7 <7= paco7 gf bot7.
Proof.
  intros. destruct PR. revert x0 x1 x2 x3 x4 x5 x6 IN.
  pcofix CIH. intros.
  pstep. eapply gf_mon; [| right; apply CIH, rclo7_rclo, PR].
  apply compat7_compat with (gf:=gf). apply rclo7_compat. apply gf_mon. apply CMP.
  eapply rclo7_mon. apply IN.
  intros. destruct PR; [|contradiction]. _punfold H; [..|apply gpaco7_def_mon, gf_mon].
  eapply gpaco7_def_mon. apply gf_mon. apply H.
  intros. destruct PR; [|destruct H0; contradiction]. left. apply H0.
Qed.

Lemma gpaco7_init clo
      (WCMP: wcompatible7 gf clo):
  gpaco7 gf clo bot7 bot7 <7= paco7 gf bot7.
Proof.
  intros. eapply gpaco7_compat_init.
  - apply wcompat7_compat, WCMP. apply gf_mon.
  - eapply gpaco7_mon_bot. apply PR. apply gf_mon. intros; apply PR0.
    intros. apply gpaco7_clo, PR0.
Qed.

Lemma gpaco7_unfold_bot clo
      (WCMP: wcompatible7 gf clo):
  gpaco7 gf clo bot7 bot7 <7= gf (gpaco7 gf clo bot7 bot7).
Proof.
  intros. apply gpaco7_init in PR; [|apply WCMP].
  _punfold PR; [..|apply gf_mon].
  eapply gf_mon. apply PR.
  intros. destruct PR0; [|contradiction]. apply gpaco7_final. apply gf_mon. right. apply H.
Qed.

End Soundness.

Section Distributivity.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone7 gf.

Lemma gpaco7_dist clo r rg
      (CMP: wcompatible7 gf clo)
      (DIST: forall r1 r2, clo (r1 \7/ r2) <7= (clo r1 \7/ clo r2)):
  gpaco7 gf clo r rg <7= (paco7 gf (rclo7 clo (rg \7/ r)) \7/ rclo7 clo r).
Proof.
  intros. apply gpaco7_unfold in PR; [|apply gf_mon].
  apply rclo7_dist in PR; [|apply CMP|apply DIST].
  destruct PR; [|right; apply H].
  left. revert x0 x1 x2 x3 x4 x5 x6 H.
  pcofix CIH; intros.
  apply rclo7_wcompat in H0; [|apply gf_mon|apply CMP].
  pstep. eapply gf_mon. apply H0. clear  x0 x1 x2 x3 x4 x5 x6 H0. intros.
  apply gpaco7_unfold in PR; [|apply gf_mon].
  apply rclo7_compose in PR.
  apply rclo7_dist in PR; [|apply CMP|apply DIST].
  destruct PR.
  - right. apply CIH.
    eapply rclo7_mon. apply H. intros.
    eapply gf_mon. apply PR. intros.
    apply gpaco7_gupaco. apply gf_mon.
    apply gpaco7_gen_rclo. apply gf_mon.
    eapply gupaco7_mon. apply PR0. intros.
    destruct PR1; apply H0.
  - assert (REL: @rclo7 clo (rclo7 clo (gf (gupaco7 gf clo ((rg \7/ r) \7/ (rg \7/ r))) \7/ (rg \7/ r))) x0 x1 x2 x3 x4 x5 x6).
    { eapply rclo7_mon. apply H. intros. apply gpaco7_unfold in PR. apply PR. apply gf_mon. }
    apply rclo7_rclo in REL.
    apply rclo7_dist in REL; [|apply CMP|apply DIST].
    right. destruct REL; cycle 1.
    + apply CIH0, H0.
    + apply CIH.
      eapply rclo7_mon. apply H0. intros.
      eapply gf_mon. apply PR. intros.
      eapply gupaco7_mon. apply PR0. intros.
      destruct PR1; apply H1.
Qed.

Lemma gpaco7_dist_reverse clo r rg:
  (paco7 gf (rclo7 clo (rg \7/ r)) \7/ rclo7 clo r) <7= gpaco7 gf clo r rg.
Proof.
  intros. destruct PR; cycle 1.
  - eapply gpaco7_rclo. apply H.
  - econstructor. apply rclo7_base. left.
    revert x0 x1 x2 x3 x4 x5 x6 H. pcofix CIH; intros.
    _punfold H0; [|apply gf_mon]. pstep.
    eapply gf_mon. apply H0. intros.
    destruct PR.
    + apply rclo7_base. right. apply CIH, H.
    + eapply rclo7_mon. apply H. intros.
      right. apply CIH0. apply PR.
Qed.

End Distributivity.

Section Companion.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone7 gf.

Inductive cpn7 (r: rel) x0 x1 x2 x3 x4 x5 x6 : Prop :=
| cpn7_intro
    clo
    (COM: compatible7 gf clo)
    (CLO: clo r x0 x1 x2 x3 x4 x5 x6)
.

Lemma cpn7_mon: monotone7 cpn7.
Proof.
  red. intros.
  destruct IN. exists clo.
  - apply COM.
  - eapply compat7_mon; [apply COM|apply CLO|apply LE].
Qed.

Lemma cpn7_greatest: forall clo (COM: compatible7 gf clo), clo <8= cpn7.
Proof. intros. econstructor;[apply COM|apply PR]. Qed.

Lemma cpn7_compat: compatible7 gf cpn7.
Proof.
  econstructor; [apply cpn7_mon|intros].
  destruct PR; eapply gf_mon with (r:=clo r).
  - eapply (compat7_compat COM); apply CLO.
  - intros. econstructor; [apply COM|apply PR].
Qed.

Lemma cpn7_wcompat: wcompatible7 gf cpn7.
Proof. apply compat7_wcompat, cpn7_compat. apply gf_mon. Qed.

Lemma cpn7_gupaco:
  gupaco7 gf cpn7 <8= cpn7.
Proof.
  intros. eapply cpn7_greatest, PR. apply wcompat7_compat. apply gf_mon. apply cpn7_wcompat.
Qed.

Lemma cpn7_cpn r:
  cpn7 (cpn7 r) <7= cpn7 r.
Proof.
  intros. apply cpn7_gupaco, gpaco7_gupaco, gpaco7_clo. apply gf_mon.
  eapply cpn7_mon, gpaco7_clo. apply PR.
Qed.

Lemma cpn7_base r:
  r <7= cpn7 r.
Proof.
  intros. apply cpn7_gupaco. apply gpaco7_base, PR.
Qed.

Lemma cpn7_clo
      r clo (LE: clo <8= cpn7):
  clo (cpn7 r) <7= cpn7 r.
Proof.
  intros. apply cpn7_cpn, LE, PR.
Qed.

Lemma cpn7_step r:
  gf (cpn7 r) <7= cpn7 r.
Proof.
  intros. apply cpn7_gupaco. apply gpaco7_step. apply gf_mon.
  eapply gf_mon, gpaco7_clo. apply PR.
Qed.

Lemma cpn7_uclo uclo
      (MON: monotone7 uclo)
      (WCOM: forall r, uclo (gf r) <7= gf (gupaco7 gf (uclo \8/ cpn7) r)):
  uclo <8= gupaco7 gf cpn7.
Proof.
  intros. apply gpaco7_clo.
  exists (gupaco7 gf (uclo \8/ cpn7)).
  - apply wcompat7_compat. apply gf_mon.
    econstructor.
    + apply monotone7_union. apply MON. apply cpn7_mon.
    + intros. destruct PR0.
      * apply WCOM, H.
      * apply compat7_compat with (gf:=gf) in H; [| apply cpn7_compat].
        eapply gf_mon. apply H. intros.
        apply gpaco7_clo. right. apply PR0.
  - apply gpaco7_clo. left. apply PR.
Qed.

End Companion.

Section Respectful.

Variable gf: rel -> rel.
Hypothesis gf_mon: monotone7 gf.

Structure wrespectful7 (clo: rel -> rel) : Prop :=
  wrespect7_intro {
      wrespect7_mon: monotone7 clo;
      wrespect7_respect :
        forall l r
               (LE: l <7= r)
               (GF: l <7= gf r),
        clo l <7= gf (rclo7 clo r);
    }.

Structure prespectful7 (clo: rel -> rel) : Prop :=
  prespect7_intro {
      prespect7_mon: monotone7 clo;
      prespect7_respect :
        forall l r
               (LE: l <7= r)
               (GF: l <7= gf r),
        clo l <7= paco7 gf (r \7/ clo r);
    }.

Structure grespectful7 (clo: rel -> rel) : Prop :=
  grespect7_intro {
      grespect7_mon: monotone7 clo;
      grespect7_respect :
        forall l r
               (LE: l <7= r)
               (GF: l <7= gf r),
        clo l <7= rclo7 (cpn7 gf) (gf (rclo7 (clo \8/ gupaco7 gf (cpn7 gf)) r));
    }.

Definition gf'7 := id /8\ gf.

Definition compatible'7 := compatible7 gf'7.

Lemma wrespect7_compatible'
      clo (RES: wrespectful7 clo):
  compatible'7 (rclo7 clo).
Proof.
  intros. econstructor. apply rclo7_mon.
  intros. destruct RES. split.
  { eapply rclo7_mon. apply PR. intros. apply PR0. }
  induction PR; intros.
  - eapply gf_mon. apply IN.
    intros. apply rclo7_base, PR.
  - eapply gf_mon.
    + eapply wrespect7_respect0; [|apply H|apply IN].
      intros. eapply rclo7_mon; intros; [apply LE, PR|apply PR0].
    + intros. apply rclo7_rclo, PR.
Qed.

Lemma prespect7_compatible'
      clo (RES: prespectful7 clo):
  compatible'7 (fun r => upaco7 gf (r \7/ clo r)).
Proof.
  econstructor.
  { red; intros. eapply upaco7_mon. apply IN.
    intros. destruct PR.
    - left. apply LE, H.
    - right. eapply RES. apply H. intros. apply LE, PR. }

  intros r.
  assert (LEM: (gf'7 r \7/ clo (gf'7 r)) <7= (r \7/ clo r)).
  { intros. destruct PR.
    - left. apply H.
    - right. eapply RES. apply H. intros. apply PR.
  }

  intros. destruct PR.
  - split.
    + left. eapply paco7_mon. apply H. apply LEM.
    + apply paco7_unfold; [apply gf_mon|].
      eapply paco7_mon. apply H. apply LEM.
  - split.
    + right. apply LEM. apply H.
    + destruct H.
      * eapply gf_mon. apply H. intros. right. left. apply PR.
      * apply paco7_unfold; [apply gf_mon|].
        eapply RES, H; intros; apply PR.
Qed.

Lemma grespect7_compatible'
      clo (RES: grespectful7 clo):
  compatible'7 (rclo7 (clo \8/ cpn7 gf)).
Proof.
  apply wrespect7_compatible'.
  econstructor.
  { red; intros. destruct IN.
    - left. eapply RES; [apply H|]. apply LE.
    - right. eapply cpn7_mon; [apply H|]. apply LE. }
  intros. destruct PR.
  - eapply RES.(grespect7_respect) in H; [|apply LE|apply GF].
    apply (@compat7_compat gf (rclo7 (cpn7 gf))) in H.
    2: { apply rclo7_compat; [apply gf_mon|]. apply cpn7_compat. apply gf_mon. }
    eapply gf_mon; [apply H|].
    intros. apply rclo7_clo. right.
    exists (rclo7 (cpn7 gf)).
    { apply rclo7_compat; [apply gf_mon|]. apply cpn7_compat. apply gf_mon. }
    eapply rclo7_mon; [eapply PR|].
    intros. eapply rclo7_mon_gen; [eapply PR0|..].
    + intros. destruct PR1.
      * left. apply H0.
      * right. apply cpn7_gupaco; [apply gf_mon|apply H0].
    + intros. apply PR1.
  - eapply gf_mon.
    + apply (@compat7_compat gf (rclo7 (cpn7 gf))).
      { apply rclo7_compat; [apply gf_mon|]. apply cpn7_compat. apply gf_mon. }
      eapply rclo7_clo_base. eapply cpn7_mon; [apply H|apply GF].
    + intros. eapply rclo7_mon_gen; [eapply PR|..].
      * intros. right. apply PR0.
      * intros. apply PR0.
Qed.

Lemma compat7_compatible'
      clo (COM: compatible7 gf clo):
  compatible'7 clo.
Proof.
  destruct COM. econstructor; [apply compat7_mon0|].
  intros. split.
  - eapply compat7_mon0; intros; [apply PR| apply PR0].
  - apply compat7_compat0.
    eapply compat7_mon0; intros; [apply PR| apply PR0].
Qed.

Lemma compatible'7_companion
      clo (RES: compatible'7 clo):
  clo <8= cpn7 gf.
Proof.
  assert (MON: monotone7 gf'7).
  { econstructor. apply LE, IN.
    eapply gf_mon, LE. apply IN.
  }
  assert (CPN: clo <8= cpn7 gf'7).
  { intros. econstructor. apply RES. apply PR.
  }
  intros. apply CPN in PR.
  econstructor; [|apply PR].
  econstructor; [apply cpn7_mon|]; intros.
  assert (PR1: cpn7 gf'7 (gf r) <7= cpn7 gf'7 (gf'7 (cpn7 gf r))).
  { intros. eapply cpn7_mon. apply PR1.
    intros. assert (TMP: gf (cpn7 gf r) <7= (cpn7 gf r /7\ gf (cpn7 gf r))).
    { split; [apply cpn7_step; [apply gf_mon|]|]; assumption. }
    apply TMP.
    eapply gf_mon. apply PR2. intros. apply cpn7_base; assumption.
  }
  apply PR1 in PR0. clear PR1.
  eapply compat7_compat with (gf:=gf'7) in PR0; [|apply cpn7_compat, MON].
  eapply gf_mon; [apply PR0|].
  intros. eapply cpn7_cpn; [apply MON|].
  eapply cpn7_mon; [apply PR1|].
  intros. econstructor; [|apply PR2].
  apply compat7_compatible', cpn7_compat, gf_mon.
Qed.

Lemma wrespect7_companion
      clo (RES: wrespectful7 clo):
  clo <8= cpn7 gf.
Proof.
  intros. eapply wrespect7_compatible' in RES.
  eapply (@compatible'7_companion (rclo7 clo)) in RES; [apply RES|].
  eapply rclo7_clo_base, PR.
Qed.

Lemma prespect7_companion
      clo (RES: prespectful7 clo):
  clo <8= cpn7 gf.
Proof.
  intros. eapply compatible'7_companion. apply prespect7_compatible'. apply RES.
  right. right. apply PR.
Qed.

Lemma grespect7_companion
      clo (RES: grespectful7 clo):
  clo <8= cpn7 gf.
Proof.
  intros. eapply grespect7_compatible' in RES.
  eapply (@compatible'7_companion (rclo7 (clo \8/ cpn7 gf))); [apply RES|].
  apply rclo7_clo_base. left. apply PR.
Qed.

Lemma wrespect7_uclo
      clo (RES: wrespectful7 clo):
  clo <8= gupaco7 gf (cpn7 gf).
Proof.
  intros. eapply gpaco7_clo, wrespect7_companion, PR. apply RES.
Qed.

Lemma prespect7_uclo
      clo (RES: prespectful7 clo):
  clo <8= gupaco7 gf (cpn7 gf).
Proof.
  intros. eapply gpaco7_clo, prespect7_companion, PR. apply RES.
Qed.

Lemma grespect7_uclo
      clo (RES: grespectful7 clo):
  clo <8= gupaco7 gf (cpn7 gf).
Proof.
  intros. eapply gpaco7_clo, grespect7_companion, PR. apply RES.
Qed.

End Respectful.

End GeneralizedPaco7.

#[export] Hint Resolve gpaco7_def_mon : paco.
#[export] Hint Unfold gupaco7 : paco.
#[export] Hint Resolve gpaco7_base : paco.
#[export] Hint Resolve gpaco7_step : paco.
#[export] Hint Resolve gpaco7_final : paco.
#[export] Hint Resolve rclo7_base : paco.
#[export] Hint Constructors gpaco7 : paco.
#[export] Hint Resolve wrespect7_uclo : paco.
#[export] Hint Resolve prespect7_uclo : paco.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011-2013 Sylvie Boldo
#<br />#
Copyright (C) 2011-2013 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import ZArith.
Require Import Zquot.

Section Zmissing.

(** About Z *)
Theorem Zopp_le_cancel :
  forall x y : Z,
  (-y <= -x)%Z -> Zle x y.
Proof.
intros x y Hxy.
apply Zplus_le_reg_r with (-x - y)%Z.
now ring_simplify.
Qed.

Theorem Zgt_not_eq :
  forall x y : Z,
  (y < x)%Z -> (x <> y)%Z.
Proof.
intros x y H Hn.
apply Zlt_irrefl with x.
now rewrite Hn at 1.
Qed.

End Zmissing.

Section Proof_Irrelevance.

Scheme eq_dep_elim := Induction for eq Sort Type.

Definition eqbool_dep P (h1 : P true) b :=
  match b return P b -> Prop with
  | true => fun (h2 : P true) => h1 = h2
  | false => fun (h2 : P false) => False
  end.

Lemma eqbool_irrelevance : forall (b : bool) (h1 h2 : b = true), h1 = h2.
Proof.
assert (forall (h : true = true), refl_equal true = h).
apply (eq_dep_elim bool true (eqbool_dep _ _) (refl_equal _)).
intros b.
case b.
intros h1 h2.
now rewrite <- (H h1).
intros h.
discriminate h.
Qed.

End Proof_Irrelevance.

Section Even_Odd.

(** Zeven, used for rounding to nearest, ties to even *)
Definition Zeven (n : Z) :=
  match n with
  | Zpos (xO _) => true
  | Zneg (xO _) => true
  | Z0 => true
  | _ => false
  end.

Theorem Zeven_mult :
  forall x y, Zeven (x * y) = orb (Zeven x) (Zeven y).
Proof.
now intros [|[xp|xp|]|[xp|xp|]] [|[yp|yp|]|[yp|yp|]].
Qed.

Theorem Zeven_opp :
  forall x, Zeven (- x) = Zeven x.
Proof.
now intros [|[n|n|]|[n|n|]].
Qed.

Theorem Zeven_ex :
  forall x, exists p, x = (2 * p + if Zeven x then 0 else 1)%Z.
Proof.
intros [|[n|n|]|[n|n|]].
now exists Z0.
now exists (Zpos n).
now exists (Zpos n).
now exists Z0.
exists (Zneg n - 1)%Z.
change (2 * Zneg n - 1 = 2 * (Zneg n - 1) + 1)%Z.
ring.
now exists (Zneg n).
now exists (-1)%Z.
Qed.

Theorem Zeven_2xp1 :
  forall n, Zeven (2 * n + 1) = false.
Proof.
intros n.
destruct (Zeven_ex (2 * n + 1)) as (p, Hp).
revert Hp.
case (Zeven (2 * n + 1)) ; try easy.
intros H.
apply False_ind.
omega.
Qed.

Theorem Zeven_plus :
  forall x y, Zeven (x + y) = Bool.eqb (Zeven x) (Zeven y).
Proof.
intros x y.
destruct (Zeven_ex x) as (px, Hx).
rewrite Hx at 1.
destruct (Zeven_ex y) as (py, Hy).
rewrite Hy at 1.
replace (2 * px + (if Zeven x then 0 else 1) + (2 * py + (if Zeven y then 0 else 1)))%Z
  with (2 * (px + py) + ((if Zeven x then 0 else 1) + (if Zeven y then 0 else 1)))%Z by ring.
case (Zeven x) ; case (Zeven y).
rewrite Zplus_0_r.
now rewrite Zeven_mult.
apply Zeven_2xp1.
apply Zeven_2xp1.
replace (2 * (px + py) + (1 + 1))%Z with (2 * (px + py + 1))%Z by ring.
now rewrite Zeven_mult.
Qed.

End Even_Odd.

Section Zpower.

Theorem Zpower_plus :
  forall n k1 k2, (0 <= k1)%Z -> (0 <= k2)%Z ->
  Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z.
Proof.
intros n k1 k2 H1 H2.
now apply Zpower_exp ; apply Zle_ge.
Qed.

Theorem Zpower_Zpower_nat :
  forall b e, (0 <= e)%Z ->
  Zpower b e = Zpower_nat b (Zabs_nat e).
Proof.
intros b [|e|e] He.
apply refl_equal.
apply Zpower_pos_nat.
elim He.
apply refl_equal.
Qed.

Theorem Zpower_nat_S :
  forall b e,
  Zpower_nat b (S e) = (b * Zpower_nat b e)%Z.
Proof.
intros b e.
rewrite (Zpower_nat_is_exp 1 e).
apply (f_equal (fun x => x * _)%Z).
apply Zmult_1_r.
Qed.

Theorem Zpower_pos_gt_0 :
  forall b p, (0 < b)%Z ->
  (0 < Zpower_pos b p)%Z.
Proof.
intros b p Hb.
rewrite Zpower_pos_nat.
induction (nat_of_P p).
easy.
rewrite Zpower_nat_S.
now apply Zmult_lt_0_compat.
Qed.

Theorem Zeven_Zpower :
  forall b e, (0 < e)%Z ->
  Zeven (Zpower b e) = Zeven b.
Proof.
intros b e He.
case_eq (Zeven b) ; intros Hb.
(* b even *)
replace e with (e - 1 + 1)%Z by ring.
rewrite Zpower_exp.
rewrite Zeven_mult.
replace (Zeven (b ^ 1)) with true.
apply Bool.orb_true_r.
unfold Zpower, Zpower_pos. simpl.
now rewrite Zmult_1_r.
omega.
discriminate.
(* b odd *)
rewrite Zpower_Zpower_nat.
induction (Zabs_nat e).
easy.
unfold Zpower_nat. simpl.
rewrite Zeven_mult.
now rewrite Hb.
now apply Zlt_le_weak.
Qed.

Theorem Zeven_Zpower_odd :
  forall b e, (0 <= e)%Z -> Zeven b = false ->
  Zeven (Zpower b e) = false.
Proof.
intros b e He Hb.
destruct (Z_le_lt_eq_dec _ _ He) as [He'|He'].
rewrite <- Hb.
now apply Zeven_Zpower.
now rewrite <- He'.
Qed.

(** The radix must be greater than 1 *)
Record radix := { radix_val :> Z ; radix_prop : Zle_bool 2 radix_val = true }.

Theorem radix_val_inj :
  forall r1 r2, radix_val r1 = radix_val r2 -> r1 = r2.
Proof.
intros (r1, H1) (r2, H2) H.
simpl in H.
revert H1.
rewrite H.
intros H1.
apply f_equal.
apply eqbool_irrelevance.
Qed.

Definition radix2 := Build_radix 2 (refl_equal _).

Variable r : radix.

Theorem radix_gt_0 : (0 < r)%Z.
Proof.
apply Zlt_le_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply r.
Qed.

Theorem radix_gt_1 : (1 < r)%Z.
Proof.
destruct r as (v, Hr). simpl.
apply Zlt_le_trans with 2%Z.
easy.
now apply Zle_bool_imp_le.
Qed.

Theorem Zpower_gt_1 :
  forall p,
  (0 < p)%Z ->
  (1 < Zpower r p)%Z.
Proof.
intros [|p|p] Hp ; try easy.
simpl.
rewrite Zpower_pos_nat.
generalize (lt_O_nat_of_P p).
induction (nat_of_P p).
easy.
intros _.
rewrite Zpower_nat_S.
assert (0 < Zpower_nat r n)%Z.
clear.
induction n.
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
apply Zle_lt_trans with (1 * Zpower_nat r n)%Z.
rewrite Zmult_1_l.
now apply (Zlt_le_succ 0).
apply Zmult_lt_compat_r with (1 := H).
apply radix_gt_1.
Qed.

Theorem Zpower_gt_0 :
  forall p,
  (0 <= p)%Z ->
  (0 < Zpower r p)%Z.
Proof.
intros p Hp.
rewrite Zpower_Zpower_nat with (1 := Hp).
induction (Zabs_nat p).
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
Qed.

Theorem Zpower_ge_0 :
  forall e,
  (0 <= Zpower r e)%Z.
Proof.
intros [|e|e] ; try easy.
apply Zlt_le_weak.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_le :
  forall e1 e2, (e1 <= e2)%Z ->
  (Zpower r e1 <= Zpower r e2)%Z.
Proof.
intros e1 e2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite <- (Zmult_1_l (r ^ e1)) at 1.
apply Zmult_le_compat_r.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zpower_ge_0.
now apply Zle_minus_le_0.
clear He.
destruct e1 as [|e1|e1] ; try easy.
apply Zpower_ge_0.
Qed.

Theorem Zpower_lt :
  forall e1 e2, (0 <= e2)%Z -> (e1 < e2)%Z ->
  (Zpower r e1 < Zpower r e2)%Z.
Proof.
intros e1 e2 He2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite Zmult_comm.
rewrite <- (Zmult_1_r (r ^ e1)) at 1.
apply Zmult_lt_compat2.
split.
now apply Zpower_gt_0.
apply Zle_refl.
split.
easy.
apply Zpower_gt_1.
clear -He ; omega.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
revert H1.
clear -He2.
destruct e1 ; try easy.
intros _.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_lt_Zpower :
  forall e1 e2,
  (Zpower r (e1 - 1) < Zpower r e2)%Z ->
  (e1 <= e2)%Z.
Proof.
intros e1 e2 He.
apply Znot_gt_le.
intros H.
apply Zlt_not_le with (1 := He).
apply Zpower_le.
clear -H ; omega.
Qed.

End Zpower.

Section Div_Mod.

Theorem Zmod_mod_mult :
  forall n a b, (0 < a)%Z -> (0 <= b)%Z ->
  Zmod (Zmod n (a * b)) b = Zmod n b.
Proof.
intros n a [|b|b] Ha Hb.
now rewrite 2!Zmod_0_r.
rewrite (Zmod_eq n (a * Zpos b)).
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
apply Z_mod_plus.
easy.
apply Zmult_gt_0_compat.
now apply Zlt_gt.
easy.
now elim Hb.
Qed.

Theorem ZOmod_eq :
  forall a b,
  Z.rem a b = (a - Z.quot a b * b)%Z.
Proof.
intros a b.
rewrite (Z.quot_rem' a b) at 2.
ring.
Qed.

Theorem ZOmod_mod_mult :
  forall n a b,
  Z.rem (Z.rem n (a * b)) b = Z.rem n b.
Proof.
intros n a b.
assert (Z.rem n (a * b) = n + - (Z.quot n (a * b) * a) * b)%Z.
rewrite <- Zopp_mult_distr_l.
rewrite <- Zmult_assoc.
apply ZOmod_eq.
rewrite H.
apply Z_rem_plus.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem Zdiv_mod_mult :
  forall n a b, (0 <= a)%Z -> (0 <= b)%Z ->
  (Zdiv (Zmod n (a * b)) a) = Zmod (Zdiv n a) b.
Proof.
intros n a b Ha Hb.
destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha'].
destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|Hb'].
rewrite (Zmod_eq n (a * b)).
rewrite (Zmult_comm a b) at 2.
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
rewrite Z_div_plus by now apply Zlt_gt.
rewrite <- Zdiv_Zdiv by easy.
apply sym_eq.
apply Zmod_eq.
now apply Zlt_gt.
now apply Zmult_gt_0_compat ; apply Zlt_gt.
rewrite <- Hb'.
rewrite Zmult_0_r, 2!Zmod_0_r.
apply Zdiv_0_l.
rewrite <- Ha'.
now rewrite 2!Zdiv_0_r, Zmod_0_l.
Qed.

Theorem ZOdiv_mod_mult :
  forall n a b,
  (Z.quot (Z.rem n (a * b)) a) = Z.rem (Z.quot n a) b.
Proof.
intros n a b.
destruct (Z_eq_dec a 0) as [Za|Za].
rewrite Za.
now rewrite 2!Zquot_0_r, Zrem_0_l.
assert (Z.rem n (a * b) = n + - (Z.quot (Z.quot n a) b * b) * a)%Z.
rewrite (ZOmod_eq n (a * b)) at 1.
rewrite Zquot_Zquot.
ring.
rewrite H.
rewrite Z_quot_plus with (2 := Za).
apply sym_eq.
apply ZOmod_eq.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem ZOdiv_small_abs :
  forall a b,
  (Zabs a < b)%Z -> Z.quot a b = Z0.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Zquot_small.
split.
exact H.
now rewrite Zabs_eq in Ha.
apply Zopp_inj.
rewrite <- Zquot_opp_l, Zopp_0.
apply Zquot_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOmod_small_abs :
  forall a b,
  (Zabs a < b)%Z -> Z.rem a b = a.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Zrem_small.
split.
exact H.
now rewrite Zabs_eq in Ha.
apply Zopp_inj.
rewrite <- Zrem_opp_l.
apply Zrem_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOdiv_plus :
  forall a b c, (0 <= a * b)%Z ->
  (Z.quot (a + b) c = Z.quot a c + Z.quot b c + Z.quot (Z.rem a c + Z.rem b c) c)%Z.
Proof.
intros a b c Hab.
destruct (Z_eq_dec c 0) as [Zc|Zc].
now rewrite Zc, 4!Zquot_0_r.
apply Zmult_reg_r with (1 := Zc).
rewrite 2!Zmult_plus_distr_l.
assert (forall d, Z.quot d c * c = d - Z.rem d c)%Z.
intros d.
rewrite ZOmod_eq.
ring.
rewrite 4!H.
rewrite <- Zplus_rem with (1 := Hab).
ring.
Qed.

End Div_Mod.

Section Same_sign.

Theorem Zsame_sign_trans :
  forall v u w, v <> Z0 ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now elim Zv.
Qed.

Theorem Zsame_sign_trans_weak :
  forall v u w, (v = Z0 -> w = Z0) ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now discriminate Zv.
Qed.

Theorem Zsame_sign_imp :
  forall u v,
  (0 < u -> 0 <= v)%Z ->
  (0 < -u -> 0 <= -v)%Z ->
  (0 <= u * v)%Z.
Proof.
intros [|u|u] v Hp Hn.
easy.
apply Zmult_le_0_compat.
easy.
now apply Hp.
replace (Zneg u * v)%Z with (Zpos u * (-v))%Z.
apply Zmult_le_0_compat.
easy.
now apply Hn.
rewrite <- Zopp_mult_distr_r.
apply Zopp_mult_distr_l.
Qed.

Theorem Zsame_sign_odiv :
  forall u v, (0 <= v)%Z ->
  (0 <= u * Z.quot u v)%Z.
Proof.
intros u v Hv.
apply Zsame_sign_imp ; intros Hu.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
rewrite <- Zquot_opp_l.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
Qed.

End Same_sign.

(** Boolean comparisons *)

Section Zeq_bool.

Inductive Zeq_bool_prop (x y : Z) : bool -> Prop :=
  | Zeq_bool_true_ : x = y -> Zeq_bool_prop x y true
  | Zeq_bool_false_ : x <> y -> Zeq_bool_prop x y false.

Theorem Zeq_bool_spec :
  forall x y, Zeq_bool_prop x y (Zeq_bool x y).
Proof.
intros x y.
generalize (Zeq_is_eq_bool x y).
case (Zeq_bool x y) ; intros (H1, H2) ; constructor.
now apply H2.
intros H.
specialize (H1 H).
discriminate H1.
Qed.

Theorem Zeq_bool_true :
  forall x y, x = y -> Zeq_bool x y = true.
Proof.
intros x y.
apply -> Zeq_is_eq_bool.
Qed.

Theorem Zeq_bool_false :
  forall x y, x <> y -> Zeq_bool x y = false.
Proof.
intros x y.
generalize (proj2 (Zeq_is_eq_bool x y)).
case Zeq_bool.
intros He Hn.
elim Hn.
now apply He.
now intros _ _.
Qed.

End Zeq_bool.

Section Zle_bool.

Inductive Zle_bool_prop (x y : Z) : bool -> Prop :=
  | Zle_bool_true_ : (x <= y)%Z -> Zle_bool_prop x y true
  | Zle_bool_false_ : (y < x)%Z -> Zle_bool_prop x y false.

Theorem Zle_bool_spec :
  forall x y, Zle_bool_prop x y (Zle_bool x y).
Proof.
intros x y.
generalize (Zle_is_le_bool x y).
case Zle_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt x y) as [H|H].
now specialize (H1 H).
exact H.
Qed.

Theorem Zle_bool_true :
  forall x y : Z,
  (x <= y)%Z -> Zle_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zle_is_le_bool x y)).
Qed.

Theorem Zle_bool_false :
  forall x y : Z,
  (y < x)%Z -> Zle_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zle_cases x y).
case Zle_bool ; intros H.
elim (Zlt_irrefl x).
now apply Zle_lt_trans with y.
apply refl_equal.
Qed.

End Zle_bool.

Section Zlt_bool.

Inductive Zlt_bool_prop (x y : Z) : bool -> Prop :=
  | Zlt_bool_true_ : (x < y)%Z -> Zlt_bool_prop x y true
  | Zlt_bool_false_ : (y <= x)%Z -> Zlt_bool_prop x y false.

Theorem Zlt_bool_spec :
  forall x y, Zlt_bool_prop x y (Zlt_bool x y).
Proof.
intros x y.
generalize (Zlt_is_lt_bool x y).
case Zlt_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt y x) as [H|H].
exact H.
now specialize (H1 H).
Qed.

Theorem Zlt_bool_true :
  forall x y : Z,
  (x < y)%Z -> Zlt_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zlt_is_lt_bool x y)).
Qed.

Theorem Zlt_bool_false :
  forall x y : Z,
  (y <= x)%Z -> Zlt_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zlt_cases x y).
case Zlt_bool ; intros H.
elim (Zlt_irrefl x).
now apply Zlt_le_trans with y.
apply refl_equal.
Qed.

Theorem negb_Zle_bool :
  forall x y : Z,
  negb (Zle_bool x y) = Zlt_bool y x.
Proof.
intros x y.
case Zle_bool_spec ; intros H.
now rewrite Zlt_bool_false.
now rewrite Zlt_bool_true.
Qed.

Theorem negb_Zlt_bool :
  forall x y : Z,
  negb (Zlt_bool x y) = Zle_bool y x.
Proof.
intros x y.
case Zlt_bool_spec ; intros H.
now rewrite Zle_bool_false.
now rewrite Zle_bool_true.
Qed.

End Zlt_bool.

Section Zcompare.

Inductive Zcompare_prop (x y : Z) : comparison -> Prop :=
  | Zcompare_Lt_ : (x < y)%Z -> Zcompare_prop x y Lt
  | Zcompare_Eq_ : x = y -> Zcompare_prop x y Eq
  | Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt.

Theorem Zcompare_spec :
  forall x y, Zcompare_prop x y (Zcompare x y).
Proof.
intros x y.
destruct (Z_dec x y) as [[H|H]|H].
generalize (Zlt_compare _ _ H).
case (Zcompare x y) ; try easy.
now constructor.
generalize (Zgt_compare _ _ H).
case (Zcompare x y) ; try easy.
constructor.
now apply Zgt_lt.
generalize (proj2 (Zcompare_Eq_iff_eq _ _) H).
case (Zcompare x y) ; try easy.
now constructor.
Qed.

Theorem Zcompare_Lt :
  forall x y,
  (x < y)%Z -> Zcompare x y = Lt.
Proof.
easy.
Qed.

Theorem Zcompare_Eq :
  forall x y,
  (x = y)%Z -> Zcompare x y = Eq.
Proof.
intros x y.
apply <- Zcompare_Eq_iff_eq.
Qed.

Theorem Zcompare_Gt :
  forall x y,
  (y < x)%Z -> Zcompare x y = Gt.
Proof.
intros x y.
apply Zlt_gt.
Qed.

End Zcompare.

Section cond_Zopp.

Definition cond_Zopp (b : bool) m := if b then Zopp m else m.

Theorem abs_cond_Zopp :
  forall b m,
  Zabs (cond_Zopp b m) = Zabs m.
Proof.
intros [|] m.
apply Zabs_Zopp.
apply refl_equal.
Qed.

Theorem cond_Zopp_Zlt_bool :
  forall m,
  cond_Zopp (Zlt_bool m 0) m = Zabs m.
Proof.
intros m.
apply sym_eq.
case Zlt_bool_spec ; intros Hm.
apply Zabs_non_eq.
now apply Zlt_le_weak.
now apply Zabs_eq.
Qed.

End cond_Zopp.

Section fast_pow_pos.

Fixpoint Zfast_pow_pos (v : Z) (e : positive) : Z :=
  match e with
  | xH => v
  | xO e' => Z.square (Zfast_pow_pos v e')
  | xI e' => Zmult v (Z.square (Zfast_pow_pos v e'))
  end.

Theorem Zfast_pow_pos_correct :
  forall v e, Zfast_pow_pos v e = Zpower_pos v e.
Proof.
intros v e.
rewrite <- (Zmult_1_r (Zfast_pow_pos v e)).
unfold Z.pow_pos.
generalize 1%Z.
revert v.
induction e ; intros v f ; simpl.
- rewrite <- 2!IHe.
  rewrite Z.square_spec.
  ring.
- rewrite <- 2!IHe.
  rewrite Z.square_spec.
  apply eq_sym, Zmult_assoc.
- apply eq_refl.
Qed.

End fast_pow_pos.

Section faster_div.

Lemma Zdiv_eucl_unique :
  forall a b,
  Zdiv_eucl a b = (Zdiv a b, Zmod a b).
Proof.
intros a b.
unfold Zdiv, Zmod.
now case Zdiv_eucl.
Qed.

Fixpoint Zpos_div_eucl_aux1 (a b : positive) {struct b} :=
  match b with
  | xO b' =>
    match a with
    | xO a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r)%Z
    | xI a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r + 1)%Z
    | xH => (Z0, Zpos a)
    end
  | xH => (Zpos a, Z0)
  | xI _ => Z.pos_div_eucl a (Zpos b)
  end.

Lemma Zpos_div_eucl_aux1_correct :
  forall a b,
  Zpos_div_eucl_aux1 a b = Z.pos_div_eucl a (Zpos b).
Proof.
intros a b.
revert a.
induction b ; intros a.
- easy.
- change (Z.pos_div_eucl a (Zpos b~0)) with (Zdiv_eucl (Zpos a) (Zpos b~0)).
  rewrite Zdiv_eucl_unique.
  change (Zpos b~0) with (2 * Zpos b)%Z.
  rewrite Z.rem_mul_r by easy.
  rewrite <- Zdiv_Zdiv by easy.
  destruct a as [a|a|].
  + change (Zpos_div_eucl_aux1 a~1 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r + 1)%Z).
    rewrite IHb. clear IHb.
    change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)).
    rewrite Zdiv_eucl_unique.
    change (Zpos a~1) with (1 + 2 * Zpos a)%Z.
    rewrite (Zmult_comm 2 (Zpos a)).
    rewrite Z_div_plus_full by easy.
    apply f_equal.
    rewrite Z_mod_plus_full.
    apply Zplus_comm.
  + change (Zpos_div_eucl_aux1 a~0 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r)%Z).
    rewrite IHb. clear IHb.
    change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)).
    rewrite Zdiv_eucl_unique.
    change (Zpos a~0) with (2 * Zpos a)%Z.
    rewrite (Zmult_comm 2 (Zpos a)).
    rewrite Z_div_mult_full by easy.
    apply f_equal.
    now rewrite Z_mod_mult.
  + easy.
- change (Z.pos_div_eucl a 1) with (Zdiv_eucl (Zpos a) 1).
  rewrite Zdiv_eucl_unique.
  now rewrite Zdiv_1_r, Zmod_1_r.
Qed.

Definition Zpos_div_eucl_aux (a b : positive) :=
  match Pos.compare a b with
  | Lt => (Z0, Zpos a)
  | Eq => (1%Z, Z0)
  | Gt => Zpos_div_eucl_aux1 a b
  end.

Lemma Zpos_div_eucl_aux_correct :
  forall a b,
  Zpos_div_eucl_aux a b = Z.pos_div_eucl a (Zpos b).
Proof.
intros a b.
unfold Zpos_div_eucl_aux.
change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)).
rewrite Zdiv_eucl_unique.
case Pos.compare_spec ; intros H.
now rewrite H, Z_div_same, Z_mod_same.
now rewrite Zdiv_small, Zmod_small by (split ; easy).
rewrite Zpos_div_eucl_aux1_correct.
change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)).
apply Zdiv_eucl_unique.
Qed.

Definition Zfast_div_eucl (a b : Z) :=
  match a with
  | Z0 => (0, 0)%Z
  | Zpos a' =>
    match b with
    | Z0 => (0, 0)%Z
    | Zpos b' => Zpos_div_eucl_aux a' b'
    | Zneg b' =>
      let (q, r) := Zpos_div_eucl_aux a' b' in
      match r with
      | Z0 => (-q, 0)%Z
      | Zpos _ => (-(q + 1), (b + r))%Z
      | Zneg _ => (-(q + 1), (b + r))%Z
      end
    end
  | Zneg a' =>
    match b with
    | Z0 => (0, 0)%Z
    | Zpos b' =>
      let (q, r) := Zpos_div_eucl_aux a' b' in
      match r with
      | Z0 => (-q, 0)%Z
      | Zpos _ => (-(q + 1), (b - r))%Z
      | Zneg _ => (-(q + 1), (b - r))%Z
      end
    | Zneg b' => let (q, r) := Zpos_div_eucl_aux a' b' in (q, (-r)%Z)
    end
  end.

Theorem Zfast_div_eucl_correct :
  forall a b : Z,
  Zfast_div_eucl a b = Zdiv_eucl a b.
Proof.
unfold Zfast_div_eucl.
intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy.
Qed.

End faster_div.


From Coq Require Import Cyclic31.
From Coq Require Import List.
From Coq Require Import Znumtheory.
Require Import Blockchain.
Require Import BoardroomMath.
Require Import BoardroomVoting.
Require Import BoundedN.
Require Import Containers.
Require Import Extras.
Require Import LocalBlockchain.
Require Import Monads.
Require Import Serializable.

Import ListNotations.
Import BoardroomMathNotations.

Local Open Scope Z.
Local Open Scope broom.
(*
Definition modulus : bigZ := 1552518092300708935130918131258481755631334049434514313202351194902966239949102107258669453876591642442910007680288864229150803718918046342632727613031282983744380820890196288509170691316593175367469551763119843371637221007210577919.
Definition generator : bigZ := 2.
*)
Definition modulus : Z := 201697267445741585806196628073.
Definition generator : Z := 3.

Axiom modulus_prime : prime modulus.
Instance axioms : BoardroomAxioms Z := BigZp.boardroom_axioms modulus modulus_prime.

Lemma generator_nonzero : generator !== 0.
Proof. discriminate. Qed.

Axiom generator_is_generator :
  forall z,
    ~(z == 0) ->
    exists! (e : Z), (0 <= e < order - 1)%Z /\ pow generator e == z.

Instance generator_instance : Generator axioms :=
  {| BoardroomMath.generator := generator;
     BoardroomMath.generator_nonzero := generator_nonzero;
     generator_generates := generator_is_generator; |}.

Definition num_parties : nat := 7.
Definition votes_for : nat := 4.

(* a pseudo-random generator for secret keys *)
Definition sk n := (Z.of_nat n + 1234583932) * (modulus - 23241)^159338231.

(* Make a list of secret keys, here starting at i=7 *)
Definition sks : list Z :=
  Eval native_compute in map sk (seq 7 num_parties).

(* Make a list of votes for each party *)
Definition svs : list bool :=
  Eval compute in map (fun _ => true)
                      (seq 0 votes_for)
                  ++ map (fun _ => false)
                         (seq 0 (num_parties - votes_for)).

(* Compute the public keys for each party *)
Definition pks : list Z :=
  Eval native_compute in map compute_public_key sks.

Definition rks : list Z :=
  Eval native_compute in map (reconstructed_key pks) (seq 0 (length pks)).

(* In this example we just use xor for the hash function, which is
   obviously not cryptographically secure. *)
Definition hash_func (l : list positive) : positive :=
  N.succ_pos (fold_right (fun p a => N.lxor (Npos p) a) 1%N l).

(* Compute the signup messages that would be sent by each party.
   We just use the public key as the chosen randomness here. *)
Definition signups : list Msg :=
  Eval native_compute in map (fun '(sk, pk, i) => make_signup_msg hash_func sk 5 i)
                             (zip (zip sks pks) (seq 0 (length sks))).

(* Compute the submit_vote messages that would be sent by each party *)
(* Our functional correctness proof assumes that the votes were computed
   using the make_vote_msg function provided by the contract.
   In this example we just use the secret key as the random parameters. *)
Definition votes : list Msg :=
  Eval native_compute in map (fun '(i, sk, sv, rk) => make_vote_msg hash_func sk rk sv i sk sk sk)
                             (zip (zip (zip (seq 0 (length pks)) sks) svs) rks).

Definition AddrSize := (2^128)%N.
Instance Base : ChainBase := LocalChainBase AddrSize.
Instance ChainBuilder : ChainBuilderType := LocalChainBuilderDepthFirst AddrSize.

Definition A a :=
  BoundedN.of_Z_const AddrSize a.

Local Open Scope nat.
Definition addrs : list Address.
Proof.
  let rec add_addr z n :=
    match n with
    | O => constr:(@nil Address)
    | S ?n => let tail := add_addr (z + 1)%Z n in
              constr:(cons (A z) tail)
    end in
  let num := eval compute in num_parties in
  let tm := add_addr 11%Z num in
  let tm := eval vm_compute in tm in
  exact tm.
Defined.

Definition deploy_setup :=
  {| eligible_voters := FMap.of_list (map (fun a => (a, tt)) addrs);
     finish_registration_by := 3;
     finish_commit_by := None;
     finish_vote_by := 5;
     registration_deposit := 0; |}.

Local Open Scope list.
Definition boardroom_example :=
  let chain : ChainBuilder := builder_initial in
  let creator : Address := A 10 in
  let add_block (chain : ChainBuilder) (acts : list Action) :=
      let next_header :=
          {| block_height := S (chain_height chain);
             block_slot := S (current_slot chain);
             block_finalized_height := finalized_height chain;
             block_creator := creator;
             block_reward := 50; |} in
      builder_add_block chain next_header acts in
  do chain <- add_block chain [];
  let dep := build_act creator (create_deployment 0 (boardroom_voting hash_func) deploy_setup) in
  do chain <- add_block chain [dep];
  do caddr <- hd None (map Some (FMap.keys (lc_contracts (lcb_lc chain))));
  let send addr m := build_act addr (act_call caddr 0 (serialize m)) in
  let calls := map (fun '(addr, m) => send addr m) (zip addrs signups) in
  do chain <- add_block chain calls;
  let votes := map (fun '(addr, m) => send addr m) (zip addrs votes) in
  do chain <- add_block chain votes;
  let tally := build_act creator (act_call caddr 0 (serialize tally_votes)) in
  do chain <- add_block chain [tally];
  do state <- @contract_state _ (@State _ Z) _ (lcb_lc chain) caddr;
  result state.

Check (@eq_refl (option nat) (Some votes_for)) <<: boardroom_example = Some votes_for.


Require Import GraphBasics.Graphs.
Require Import Coq.Logic.Classical_Prop.
Require Import Verdi.Verdi.

Require Export StructTact.Fin.

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.

Require Import Verdi.ExtrOcamlBasicExt.
Require Import Verdi.ExtrOcamlList.

Load NetworkModelCommunication.

(* The user has to change this file to make it fit to their specific CDA *)

(* We assume a fixed connected graph g=(v,a). *)
Variable a : A_set.
Variable v : C_set.
Variable g : Connected v a.

(* In the general case, input and output are just some types. *)
Inductive inp: Type.
Inductive outp: Type.

(* Gives the distribution of each distribution-predicate used in the witness predicate *)
Inductive Predicate_distribution: Set:=
|and : Predicate_distribution
|or : Predicate_distribution.

(* A sub-certificate is an assigment of variables to values. *)
Inductive Var: Type.
Inductive Value: Type.
Inductive Assignment := assign_cons: Var ->  Value -> Assignment.
(* Modelling decision: For variables equality is decidable. *)
Axiom Var_eq_dec : forall x y : Var, {x = y} + {x <> y}.

(* Minimal input of a network is the network itself.
 * Hence, each component me knows its neighbors in the network graph
 *)
Definition init_neighbor_l (me : Name) := (neighbors v a g (name_component me)).

(* For each sub-checker of a component me, we have to define
 * a list of sub-inputs init_inp_l,
 * a list on how to the distribution predicates are distributable init_predicate_distribution_l,
 * a list of its variables init_var_l,
 * a list of sub-outputs init_outp_l,
 * and a sub-certificate init_certificate.
 *)
Variable init_inp_l : Name -> list inp.
Variable init_predicate_distribution_l : Name -> list Predicate_distribution.
Variable init_var_l : Name -> list Var.
Variable init_outp_l : Name -> list outp.
Variable init_certificate : Name -> list Assignment.

(* initialisation of a sub-checker;
 * knowledge a sub-checker has even befor the cda computed and terminated *)
Record Checkerknowledge: Set := mk_Checkerknowledge {
  inp_l : list inp;
  Predicate_distribution_l: list Predicate_distribution;
  var_l: list Var;
  neighbor_l: list Component
}.

Definition init_Checkerknowledge (me : Name) :=
  mk_Checkerknowledge (init_inp_l me) (init_predicate_distribution_l me) (init_var_l me) (init_neighbor_l me).

(* a sub-checker gets the sub-output and sub-certificate of its component after the cda computed and terminated *)
Record Checkerinput  := mk_Checkerinput {
  outp_l : list outp;
  certificate : list Assignment
}.

Definition init_Checkerinput (me : Name) :=
  mk_Checkerinput (init_outp_l me) (init_certificate me).

Record Checkerstartstate := mkCheckerstartstate{
 checkerknowledge: Checkerknowledge;
 checkerinput : Checkerinput ;
 }.

(* the complete state of a sub-checker of component me after termination of the cda*)
Definition set_checker_start_state (me: Name) := mkCheckerstartstate (init_Checkerknowledge me) (init_Checkerinput me).

(*
(***************************************************************)
(* User has to define this part for their algorithm themselves *)
Record Data := mkData{
  checkerstartstate: Checkerstartstate;
  distance : nat;   (* change stuff here appropriately *)
  queue : list Component (* change stuff here appropriately *)
}.

(* Verid initialization *)
Definition init_Data (me: Name) := mkData (set_checker_start_state me) 0 nil.

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


From Coq Require Export Morphisms RelationClasses Setoid Program.Equality.
From ITree Require Export ITree ITreeFacts.
From Paco Require Import paco.
From Coq Require Export Eqdep EqdepFacts.
Require Import Lia.
Require Export Refinement ConvergentRefinement.

Variant no_eventsF {E R} (F : itree E R -> Prop) : itree' E R -> Prop :=
  | no_events_Ret r : no_eventsF F (RetF r)
  | no_events_Tau t : F t -> no_eventsF F (TauF t).

Definition no_events_ {E R} F (t : itree E R) : Prop :=
  no_eventsF F (observe t).

Lemma monot_no_events E R : monotone1 (@no_events_ E R).
Proof.
  red. unfold no_events_. intros.
  induction IN; constructor; auto.
Qed.

Hint Resolve monot_no_events : paco.

Definition no_events {E R } : itree E R -> Prop := paco1 no_events_ bot1.

Global Instance proper_no_events_eutt {E R} : Proper (eutt eq ==> flip impl) (@no_events E R).
Proof.
  pcofix CIH.
  intros t1 t2 Ht Hno. pstep. red.
  punfold Hno. red in Hno. punfold Ht. red in Ht.
  hinduction Ht before r; intros.
  - constructor.
  - constructor. inv Hno. pclearbot. right. eauto.
  - inv Hno.
  - constructor. left. pstep. eapply IHHt; eauto.
  - inv Hno. pclearbot. eapply IHHt; eauto. pstep_reverse.
Qed.

Global Instance proper_isConcrete_eutt {E R} : Proper (eutt eq ==> flip impl) (@isConcrete E R).
Proof.
  pcofix CIH.
  intros t1 t2 Ht Hcon. pstep. red.
  punfold Hcon. red in Hcon. punfold Ht. red in Ht.
  hinduction Ht before r; intros.
  - constructor.
  - inv Hcon. pclearbot. constructor. eauto.
  - inv Hcon. inj_existT. subst. pclearbot. constructor.
    right. eapply CIH; eauto. apply REL. apply H0.
  - constructor. left. pstep. eapply IHHt; eauto.
  - inv Hcon. pclearbot. eapply IHHt; auto. pstep_reverse.
Qed.
(*should it be refines or padded refines? lifting to padded_refines is actually simple
   because each other predicate respects eutt *)
Theorem concrete_conv_ref_to_no_ev E1 E2 R1 R2 RE REAns RR :
  forall (t : itree_spec E1 R1) (phi : itree_spec E2 R2), isConcrete t -> conv_ref phi ->
                                                     refines RE REAns RR t phi ->
                                                     no_events t.
Proof.
  pcofix CIH.
  intros t phi Hcon Hconv Href.
  punfold Hcon. red in Hcon.
  punfold Hconv. red in Hconv.
  punfold Href. red in Href.
  pstep. red. hinduction Href before r; intros.
  - constructor.
  - constructor. right. inv Hcon. inv Hconv. pclearbot. eauto.
  - inv Hcon. pclearbot. constructor. right. eapply CIH; eauto.
    Unshelve. 3 : (apply (go ophi)). pstep. auto. pstep. auto.
  - inv Hconv. pclearbot. eapply IHHref; eauto. pstep_reverse.
  - inv Hconv.
  - inv Hconv. inj_existT. subst. pclearbot. eapply H0; eauto.
    pstep_reverse.
  - inv Hcon.
  - inv Hconv. inj_existT. subst. pclearbot. eapply IHHref; eauto. pstep_reverse.
  - inv Hcon.
    Unshelve. auto.
Qed.

Theorem concrete_conv_ref_padded_to_no_ev E1 E2 R1 R2 RE REAns RR :
  forall (t : itree_spec E1 R1) (phi : itree_spec E2 R2), isConcrete t -> conv_ref phi ->
                                                     padded_refines RE REAns RR t phi ->
                                                     no_events t.
Proof.
  intros t phi Hcon Hconv Href. red in Href. rewrite  pad_eutt.
  eapply concrete_conv_ref_to_no_ev with (phi := pad phi); eauto.
  - rewrite <- pad_eutt. auto.
  - rewrite <- pad_eutt. auto.
Qed.

(*relies on lem*)
Theorem no_ev_to_dec E R : forall (t : itree E R), no_events t ->
                                              (exists r, t ≈ Ret r) \/ t ≈ ITree.spin.
Admitted.


Require Import bigstep.
Require Import coinduction.
Require Import datatypes.
Require Import MminusNoo.
Require Import Ndiv2oo.
Require Import streams_vs_lists.
Require Import UndefNoo.

(* Function undef(n) = undefined for any n

   Example machine:
      1 1 -> 1 R
      1 B -> 2 1
      2 1 -> 2 L
      2 B -> 1 1

Definition undef: Spec := (1, one, 1,     R) ::
                          (1, B  , 2, W one) ::
                          (2, one, 2,     L) ::
                          (2, B  , 1, W one) :: nil.
*)

(****************** Unuarded Divergence, via BI *********************)

Lemma undef_loops_unguarded: forall n,
      bi undef (pair Bs (app_ls (ones (S n)) Bs)) 1.
cofix co_hp.
intro.

Lemma undef_scan_right2: forall m l,
      bi undef (pair (app_ls (ones m) l) (Cons one Bs)) 2 ->
      bi undef (pair l (app_ls (ones m) Bs)) 1.
induction m; simpl; intros.

apply biW with 2 one.
auto. simpl. assumption.

apply biR with 1.
auto. simpl.
apply IHm.
rewrite ones_comm. assumption.
Qed.

apply undef_scan_right2.

Lemma undef_scan_left2: forall m r,
      bi undef (pair Bs (app_ls (ones (S (S m))) r)) 1 ->
      bi undef (pair (app_ls (ones m) Bs) (Cons one r)) 2.
induction m; simpl; intros.

apply biL with 2.
auto. simpl.
apply biW with 1 one.
auto. simpl. assumption.

apply biL with 2.
auto. simpl.
apply IHm.
rewrite ones_comm. do 2 rewrite <- ones_step2. assumption.
Qed.

apply undef_scan_left2.
apply co_hp.

(* The proof is not accepted by Coq (try to apply Qed.)
Qed.
*)

Abort.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall Qprime Cprime P Q Aprime C A X Y : Universe, ((wd_ Qprime Cprime /\ (wd_ Cprime P /\ (wd_ P Q /\ (wd_ Qprime Q /\ (wd_ Qprime P /\ (wd_ Cprime Q /\ (wd_ Aprime P /\ (wd_ Q Aprime /\ (wd_ Aprime A /\ (wd_ Cprime C /\ (wd_ P A /\ (wd_ P C /\ (wd_ Q C /\ (wd_ C A /\ (wd_ Cprime Aprime /\ (wd_ X Y /\ (wd_ A Q /\ (wd_ P Y /\ (wd_ X P /\ (col_ P Q Y /\ (col_ Aprime P A /\ (col_ Cprime P C /\ (col_ P C Y /\ col_ P A X))))))))))))))))))))))) -> col_ P Q C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C D U Bu Xu Du Bprime Dprime : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ U Eprime /\ (wd_ A Eprime /\ (wd_ Xu O /\ (wd_ D Du /\ (wd_ Bu Xu /\ (wd_ B Bu /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ O Eprime Bu /\ (col_ O E Xu /\ (col_ O Eprime Du /\ (col_ O Eprime Bprime /\ (col_ O Eprime Dprime /\ (col_ Eprime O D /\ (col_ A O D /\ col_ O Eprime O)))))))))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype order.

From deriving Require Import base ind tactics infer.

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

Open Scope deriving_scope.

Module DerEqType.

Section EqType.

Variable T : indDef.
Notation n := (Ind.Def.n T).
Local Notation arg_class := (@arg_class n _ Equality.sort).
Local Notation arg_inst := (arg_inst n Equality.sort).
Local Notation arity_inst := (arity_inst n Equality.sort).
Local Notation sig_inst := (sig_inst n Equality.sort).
Local Notation decl_inst := (decl_inst n Equality.sort n).
Variable (sT : forall i, sig_class Equality.sort (Ind.Def.decl T i)).

Import IndF.

Definition eq_op_branch As (cAs : hlist' arg_class As) :
  hlist' (type_of_arg (T *F (fun i => T i -> bool))) As ->
  hlist' (type_of_arg T)                             As ->
  bool                                                  ->
  bool :=
  arity_rec _ (fun As => hlist' _ As -> hlist' _ As -> bool -> bool)
    (fun _ _ b => b)
    (fun R As rec x y b => rec x.(tl) y.(tl) (b && (x.(hd) == y.(hd))))
    (fun j As rec x y b => rec x.(tl) y.(tl) (b &&  x.(hd).2 y.(hd)))
    As cAs.

(* FIXME: Do we really need these annotations? *)
Definition eq_op : forall i, T i -> T i -> bool :=
  rec  (fun i args1 =>
  case (fun   args2 =>
     match leq_fin (constr args2) (constr args1) with
      | inl e =>
        eq_op_branch
          (hnth (sT i) (constr args1))
          (args args1)
          (cast (hlist' (type_of_arg T) \o @nth_fin _ _) e (args args2))
          true
      | inr _ => false
      end)).

Lemma eq_opP i : Equality.axiom (@eq_op i).
Proof.
elim/indP: i / => i [xC xargs] y.
rewrite /eq_op recE /= -/eq_op /=.
rewrite -[y]unrollK caseE; move: {y} (unroll y)=> [yC yargs] /=.
case le: (leq_fin yC xC)=> [e|b]; last first.
  constructor=> /Roll_inj /= [] e _.
  by move: le; rewrite e leq_finii.
case: xC / e xargs {le} => /= xargs.
apply/(@iffP (hmap' (type_of_arg_map (fun=> tag)) xargs = yargs)); first last.
- by move=> /Roll_inj /IndF.inj.
- by move=> <-.
apply/(iffP idP)=> [H|<-]; last first.
  elim/arity_ind: {yC} _ / (hnth _ _) xargs {yargs}=> //= [|j] S As cAs.
    move=> /= IH [x xargs]; rewrite /= eqxx; exact: IH.
  move=> [[x xP] xargs] /=; rewrite (introT (xP _)) //; exact: cAs.
suffices [//]: true /\ hmap' (type_of_arg_map (fun=> tag)) xargs = yargs.
elim/arity_ind: {yC} _ / (hnth _ _) xargs yargs true H.
- by move=> [] [].
- move=> S As cAs IH /= [x xargs] [y yargs] /= b /IH.
  by case=> /andP [-> /eqP <-] <-.
- move=> j As cAs /= IH [[x xP] xargs] [y yargs] /= b /IH.
  by case=> /andP [-> /xP <-] <-.
Qed.

End EqType.

Definition pack T :=
  [infer indType of T with Equality.sort as sT n sorts D cD in
   cast Equality.mixin_of (Ind.idxE sT)^-1
    (@EqMixin _ _ (@eq_opP sT cD (Ind.idx sT)))].

End DerEqType.

Notation "[ 'derive' 'nored' 'eqMixin' 'for' T ]" :=
  (@DerEqType.pack T _ id _ _ _ _ _ _ id _ id _ id)
  (at level 0) : form_scope.

Ltac derive_eqMixin T :=
  match eval hnf in [derive nored eqMixin for T] with
  | @EqMixin _ ?op ?opP =>
    let op := eval unfold DerEqType.eq_op, DerEqType.eq_op_branch in op in
    let op := eval deriving_compute in op in
    exact (@EqMixin T op opP)
  end.

Notation "[ 'derive' 'eqMixin' 'for' T ]" :=
  (ltac:(derive_eqMixin T))
  (at level 0) : form_scope.

Ltac derive_lazy_eqMixin T :=
  match eval hnf in [derive nored eqMixin for T] with
  | @EqMixin _ ?op ?opP =>
    let op := eval unfold DerEqType.eq_op, DerEqType.eq_op_branch in op in
    let op := eval deriving_lazy in op in
    exact (@EqMixin T op opP)
  end.

Notation "[ 'derive' 'lazy' 'eqMixin' 'for' T ]" :=
  (ltac:(derive_lazy_eqMixin T))
  (at level 0) : form_scope.