Section Stream.

  Context {A : Set}.

  CoInductive stream : Set :=
  | Nil : stream
  | Cons : A -> stream -> stream.

  Definition helper (s : stream) : stream :=
    match s with
    | Nil => Nil
    | Cons h t => Cons h t
    end.

  Lemma helper_eq
        (s : stream) :
        s = helper s.
  Proof. destruct s; reflexivity. Qed.

  CoInductive equal_streams : stream -> stream -> Prop :=
  | eqsNil  :                    equal_streams Nil Nil
  | eqsCons : forall h1 h2 t1 t2 (EQH : h1 = h2)
                                 (EQT : equal_streams t1 t2),
                                 equal_streams (Cons h1 t1) (Cons h2 t2).

  Lemma equal_streams_symmetry
        (s1 s2 : stream)
        (EQS : equal_streams s1 s2) :
        equal_streams s2 s1.
  Proof.
    revert EQS. revert s1 s2.
    cofix CIH. intros. inversion EQS; subst.
    { constructor. }
    { constructor. reflexivity. auto. }
  Qed.

  Inductive in_stream : A -> stream -> Prop :=
  | inHead : forall x t,  in_stream x (Cons x t)
  | inTail : forall x h t (IN : in_stream x t),
                          in_stream x (Cons h t).

  Hint Constructors in_stream : core.

  Lemma in_equal_streams
        (s1 s2 : stream)
        (EQS : equal_streams s1 s2)
        (x : A)
        (X_IN : in_stream x s1) :
        in_stream x s2.
  Proof.
    revert EQS. revert s2.
    induction X_IN; intros; inversion_clear EQS; subst.
    { constructor. }
    { constructor. eapply IHX_IN. assumption. }
  Qed.

  Inductive finite : stream -> Prop :=
  | fNil  :            finite Nil
  | fCons : forall h t (FIN : finite t),
                       finite (Cons h t).

  Hint Constructors finite : core.

  CoInductive interleave : stream -> stream -> stream -> Prop :=
  | interNil  : forall s s'     (EQS : equal_streams s s'),
                                interleave Nil s s'
  | interCons : forall h t s rs (INTER : interleave s t rs),
                                interleave (Cons h t) s (Cons h rs).

  Lemma interleave_in_1
        (s1 s2 s : stream)
        (INTER : interleave s1 s2 s)
        (x : A)
        (X_IN : in_stream x s) :
        in_stream x s1 \/ in_stream x s2.
  Proof.
    revert INTER. revert s1 s2. induction X_IN; intros.
    { inversion INTER.
      { right. inversion EQS. subst. constructor. }
      { left. constructor. } }
    { inversion INTER; subst.
      { right. inversion EQS; subst. constructor.
        apply equal_streams_symmetry in EQT.
        eapply in_equal_streams; eauto. }
      { specialize (IHX_IN _ _ INTER0). destruct IHX_IN.
        { auto. }
        { left. constructor. auto. } } }
  Qed.

  Lemma interleave_in_2
        (s1 s2 s : stream)
        (INTER : interleave s1 s2 s)
        (x : A)
        (X_IN_12 : in_stream x s1 \/ in_stream x s2) :
        in_stream x s.
  Proof.
    destruct X_IN_12.
    { revert INTER. revert s2 s. induction H.
      { intros. inversion_clear INTER; subst. constructor. }
      { intros. inversion_clear INTER; subst. constructor.
        inversion_clear INTER0; subst.
        { eapply in_equal_streams; eauto. }
        { constructor. eauto. } } }
    { revert INTER. revert s1 s. induction H.
      { intros. inversion INTER; subst.
        { eapply in_equal_streams; eauto. }
        { constructor. inversion INTER0; subst. auto. } }
      { intros. inversion INTER; subst.
        { eapply in_equal_streams; eauto. }
        { inversion INTER0; subst. constructor. constructor. eapply IHin_stream. eauto. } } }
  Qed.

  Lemma interleave_in
        (s1 s2 s : stream)
        (INTER : interleave s1 s2 s)
        (x : A) :
        in_stream x s <-> in_stream x s1 \/ in_stream x s2.
  Proof.
    intros. split.
    { apply interleave_in_1. auto. }
    { apply interleave_in_2. auto. }
  Qed.

  Lemma equal_streams_finite
        (s1 s2 : stream)
        (EQS : equal_streams s1 s2)
        (FIN_1 : finite s1) :
        finite s2.
  Proof.
    revert EQS. revert s2.
    induction FIN_1; intros; inversion EQS; subst; auto.
  Qed.

  Lemma interleave_finite_1
        (s s1 s2 : stream)
        (INTER : interleave s1 s2 s)
        (FIN : finite s) :
        finite s1 /\ finite s2.
  Proof.
    revert INTER. revert s1 s2. induction FIN.
    { intros. inversion INTER; subst. inversion EQS. auto. }
    { intros. inversion INTER; subst.
      { inversion EQS; subst. split; auto. constructor.
        apply equal_streams_symmetry in EQT. eapply equal_streams_finite; eauto. }
      { apply IHFIN in INTER0. destruct INTER0. auto. } }
  Qed.

  Lemma interleave_finite_2
        (s s1 s2 : stream)
        (INTER : interleave s1 s2 s)
        (FIN_1 : finite s1)
        (FIN_2 : finite s2) :
        finite s.
  Proof.
    revert INTER FIN_2. revert s s2. induction FIN_1.
    { intros. inversion INTER. eapply equal_streams_finite; eauto. }
    { intros. inversion INTER; subst. constructor. inversion INTER0; subst.
      { eapply equal_streams_finite; eauto. }
      { inversion FIN_2; subst. constructor. eapply IHFIN_1; eauto. } }
  Qed.

  Lemma interleave_finite
        (s1 s2 s : stream)
        (INTER : interleave s1 s2 s) :
        finite s <-> finite s1 /\ finite s2.
  Proof.
    intros. split.
    { intro. eapply interleave_finite_1; eauto. }
    { intro. destruct H. eapply interleave_finite_2; eauto. }
  Qed.

End Stream.

Section Test.

  CoFixpoint nats (n : nat) : stream := Cons n (nats (S n)).

  Definition true_false : stream := Cons true (Cons false Nil).

  Lemma true_false_fin : finite true_false.
  Proof.
    repeat constructor.
  Qed.

  Lemma nats_not_fin
        (n : nat) :
        ~ finite (nats n).
  Proof.
    intro C. remember (nats n).
    revert Heqs. revert n.
    induction C.
    { intros. rewrite helper_eq in Heqs. simpl in Heqs. inversion Heqs. }
    { intros. apply IHC with (S n). rewrite helper_eq in Heqs. simpl in Heqs.
      inversion Heqs. reflexivity. }
  Qed.

  Lemma nats_contain_all_nats
        (n : nat) :
        in_stream n (nats 0).
  Proof.
    induction n.
    { rewrite helper_eq. constructor. }
    { remember (nats 0). remember 0. clear Heqn0.
      revert Heqs. revert n0. induction IHn.
      { intros. rewrite helper_eq in Heqs. inversion Heqs.
        constructor. rewrite helper_eq. constructor. }
      { intros. constructor. rewrite helper_eq in Heqs.
        inversion Heqs; subst. eapply IHIHn. reflexivity. } }
  Qed.

End Test.


Require Import List.
Require Import NPeano EqNat Compare_dec.

Fixpoint min (n : nat) (m : nat) : nat :=
  match n with
      | 0 => 0
      | (S n') =>
          match m with
            | 0 => 0
            | (S m') => (S (min n' m'))
          end
  end.

Eval compute in (min 8 4).

Definition some_to_num (n : option nat) : nat :=
  match n with
      | None => 0
      | Some n => n
end.

Fixpoint min_num_coins (b : nat) (m : nat) (vals : list nat) : option nat :=
  match b with
    | 0 => Some 0
    | S n' =>
        match m with
          | 0 => Some 0
          | S m' =>
              let fix make_change_choices (vals0 : list nat) (m0 : nat) : option nat :=
                  match vals0 with
                    | nil => None
                    | val :: vals' =>
                        let fix try_choice (m1 : nat) (val0: nat) : option nat :=
                            match val0 with
                              | 0 => (min_num_coins n' (m0 - val) vals)
                              | S val1 =>
                                  match m1 with
                                    | 0 => None
                                    | S m2 => (try_choice m2 val1)
                                  end
                            end
                        in match (make_change_choices vals' m0) with
                             | None =>
                                 match (try_choice m0 val) with
                                   | None => None
                                   | Some n0 => Some n0
                                 end
                             | Some n1 =>
                                 match (try_choice m0 val) with
                                   | None => None
                                   | Some n2 => Some (min n1 n2)
                                 end
                           end
                  end
              in
                Some (S (some_to_num (make_change_choices vals m)))
        end
  end.

Eval compute in (min_num_coins 16 16 (10 :: 8 :: 5 :: 1 :: nil)).

(*Fixpoint min_num_coins (n : nat) (vals : list nat) : nat :=
  match n with
    | 0 => 0
    | n' => let min_of_options :=
                (fix make_change_choices (n : nat) (vals : list nat) : nat :=
                 match vals with
                   | nil => 1000
                   | val :: vals' =>
                       if  (geb n val) then (min (min_num_coins (n - val) vals)
                                                 (make_change_choices n vals'))
                       else (make_change_choices n vals')
                 end)
            in
              (S min_of_options)
end.*)


From QuickChick Require Import QuickChick.
From Showtime Require Import Max ModuleTypes State Op.
Require Import Structures.Orders Structures.OrdersEx.

Inductive OpInst : Type :=
| MkOpInst : TID -> Time -> Op -> OpInst.

Derive Show for OpInst.

Module OpInst_as_OT <: OrderedType.
  Definition t := OpInst.

  Definition eq_ (oi1 oi2 : OpInst) : Prop :=
    match oi1, oi2 with
    | MkOpInst a1 b1 c1, MkOpInst a2 b2 c2 =>
        Nat_as_OT.eq a1 a2 /\ Max_as_OT.eq b1 b2 /\ Op_as_OT.eq c1 c2
    end.

  Definition eq := eq_.

  Instance eq_refl : Reflexive eq.
  Proof.
    unfold Reflexive. destruct x. simpl. repeat split; reflexivity.
  Qed.

  Instance eq_sym : Symmetric eq.
  Proof.
    unfold Symmetric. destruct x, y. simpl. intro H1.
    destruct H1 as [H1 H2]. destruct H2 as [H2 H3]. repeat split; symmetry; auto.
  Qed.

  Instance eq_trans : Transitive eq.
  Proof.
    unfold Transitive. destruct x, y, z. simpl. intros H1 H4.
    destruct H1 as [H1 H2]. destruct H2 as [H2 H3].
    destruct H4 as [H4 H5]. destruct H5 as [H5 H6]. repeat split.
    - rewrite H1. auto.
    - rewrite H2. auto.
    - rewrite H3. auto.
  Qed.

  Instance eq_equiv : Equivalence eq.
  Proof. split.
  - apply eq_refl.
  - apply eq_sym.
  - apply eq_trans.
  Qed.

  Theorem eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    destruct x, y. simpl.
    destruct (Nat_as_OT.eq_dec t0 t2);
    destruct (Max_as_OT.eq_dec t1 t3);
    destruct (Op_as_OT.eq_dec o o0); auto; right; intro;
    destruct H as [H1 H2]; destruct H2 as [H2 H3]; contradiction.
  Qed.

  Definition compare (oi1 oi2 : OpInst) : comparison :=
    match oi1, oi2 with
    | MkOpInst a1 b1 c1, MkOpInst a2 b2 c2 =>
        match Nat_as_OT.compare a1 a2 with
        | Eq =>
            match Max_as_OT.compare b1 b2 with
            | Eq => Op_as_OT.compare c1 c2
            | other => other
            end
        | other => other
        end
    end.

  Inductive lt_ : t -> t -> Prop :=
  | lt_1 : forall a1 a2 b1 b2 c1 c2,
           Nat_as_OT.lt a1 a2 ->
           lt_ (MkOpInst a1 b1 c1) (MkOpInst a2 b2 c2)
  | lt_2 : forall a1 a2 b1 b2 c1 c2,
           Nat_as_OT.eq a1 a2 ->
           Max_as_OT.lt b1 b2 ->
           lt_ (MkOpInst a1 b1 c1) (MkOpInst a2 b2 c2)
  | lt_3 : forall a1 a2 b1 b2 c1 c2,
           Nat_as_OT.eq a1 a2 ->
           Max_as_OT.eq b1 b2 ->
           Op_as_OT.lt  c1 c2 ->
           lt_ (MkOpInst a1 b1 c1) (MkOpInst a2 b2 c2).

  Definition lt := lt_.

  Instance lt_irrefl : Irreflexive lt.
  Proof.
    unfold Irreflexive, Reflexive, complement. intros.
    destruct x. inversion H; subst.
    - destruct Nat_as_OT.lt_strorder.
      apply StrictOrder_Irreflexive in H1. auto.
    - destruct Max_as_OT.lt_strorder.
      apply StrictOrder_Irreflexive in H7. auto.
    - destruct Op_as_OT.lt_strorder.
      apply StrictOrder_Irreflexive in H8. auto.
  Qed.

  Instance lt_trans : Transitive lt.
  Proof.
    unfold Transitive. destruct x, y, z. intros.
    inversion H; inversion H0; subst.
    - apply lt_1. rewrite H2. auto.
    - apply lt_1. rewrite <- H10. auto.
    - apply lt_1. rewrite <- H12. auto.
    - apply lt_1. rewrite H3. auto.
    - apply lt_2.
      + rewrite H3. auto.
      + rewrite H8. auto.
    - apply lt_2.
      + rewrite H3. auto.
      + rewrite <- H16. auto.
    - apply lt_1. rewrite H5. auto.
    - apply lt_2.
      + rewrite H5. auto.
      + rewrite H8. auto.
    - apply lt_3.
      + rewrite H5. auto.
      + rewrite H8. auto.
      + rewrite H9. auto.
  Qed.

  Instance lt_strorder : StrictOrder lt.
  Proof. split.
  - apply lt_irrefl.
  - apply lt_trans.
  Qed.

  Instance lt_compat : Proper (eq ==> eq ==> iff) lt.
  Proof.
    unfold Proper, respectful. destruct x, y. simpl.
    intro H1. destruct H1 as [H1 H2]. destruct H2 as [H2 H3].
    destruct x, y. simpl.
    intro H4. destruct H4 as [H4 H5]. destruct H5 as [H5 H6].
    split; intro Assump; inversion Assump; subst.
    - apply lt_1. rewrite <- H1, <- H4. auto.
    - apply lt_2.
      + rewrite <- H1, <- H4. auto.
      + rewrite <- H2, <- H5. auto.
    - apply lt_3.
      + rewrite <- H1, <- H4. auto.
      + rewrite <- H2, <- H5. auto.
      + rewrite <- H3, <- H6. auto.
    - apply lt_1. rewrite H1, H4. auto.
    - apply lt_2.
      + rewrite H1, H4. auto.
      + rewrite H2, H5. auto.
    - apply lt_3.
      + rewrite H1, H4. auto.
      + rewrite H2, H5. auto.
      + rewrite H3, H6. auto.
  Qed.

  Theorem compare_spec : forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
  Proof.
    destruct x, y. simpl.
    destruct (Nat_as_OT.compare_spec t0 t2);
    try (constructor; apply lt_1; auto; fail).
    destruct (Max_as_OT.compare_spec t1 t3);
    try (constructor; apply lt_2; try (symmetry; auto; fail); auto; fail).
    destruct (Op_as_OT.compare_spec o o0);
    try (constructor; apply lt_3; try (symmetry; auto; fail); auto; fail).
    constructor. auto.
  Qed.
End OpInst_as_OT.

Module OpInst_as_OST <: OrderedShowType.
  Include OpInst_as_OT.
  Instance show_t : Show OpInst := ShowOpInst.
End OpInst_as_OST.


(** The HoTT Book formalization, cauchy reals section. *)

Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTTClasses.cauchy_reals
  HoTTClasses.dedekind
  HoTTClasses.cauchy_dedekind.

(* END OF PREAMBLE *)
(* ================================================== lem:opp *)
(** Lemma 2.1.1 *)

Definition Book_2_1_1 := @HoTT.Basics.Overture.inverse.

(* ================================================== lem:concat *)
(** Lemma 2.1.2 *)

Definition Book_2_1_2 := @HoTT.Basics.Overture.transitive_paths.

(* ================================================== thm:omg *)
(** Lemma 2.1.4 *)

Definition Book_2_1_4_item_i := @HoTT.Basics.PathGroupoids.concat_p1.
Definition Book_2_1_4_item_i' := @HoTT.Basics.PathGroupoids.concat_1p.
Definition Book_2_1_4_item_ii := @HoTT.Basics.PathGroupoids.concat_Vp.
Definition Book_2_1_4_item_ii' := @HoTT.Basics.PathGroupoids.concat_pV.
Definition Book_2_1_4_item_iii := @HoTT.Basics.PathGroupoids.inv_V.
Definition Book_2_1_4_item_iv := @HoTT.Basics.PathGroupoids.concat_p_pp.

(* ================================================== defn:dedekind-reals *)
(** Definition 11.2.1 *)

Definition Book_11_2_1 := @HoTTClasses.dedekind.Cut.

(* ================================================== dedekind-in-cut-as-le *)
(** Lemma 11.2.2 *)

Definition Book_11_2_2_item_i := @HoTTClasses.dedekind.cut_lt_lower.
Definition Book_11_2_2_item_ii := @HoTTClasses.dedekind.cut_lt_upper.

(* ================================================== RD-inverse-apart-0 *)
(** Theorem 11.2.4 *)

(* ================================================== RD-archimedean *)
(** Theorem 11.2.6 *)

Definition Book_11_2_6 := @HoTTClasses.dedekind.Cut_archimedean.

(* ================================================== ordered-field *)
(** Definition 11.2.7 *)

Definition Book_11_2_7 := @HoTT.Classes.interfaces.abstract_algebra.Field.
Definition Book_11_2_7' := @HoTT.Classes.interfaces.orders.FullPseudoSemiRingOrder.

(* ================================================== RD-archimedean-ordered-field *)
(** Theorem 11.2.8 *)

(* ================================================== defn:cauchy-approximation *)
(** Definition 11.2.10 *)

Definition Book_11_2_10 := @HoTT.Classes.theory.premetric.Approximation.

(* ================================================== RD-cauchy-complete *)
(** Theorem 11.2.12 *)

Definition Book_11_2_12 := @HoTTClasses.dedekind.Cut_cauchy_complete.

(* ================================================== RD-final-field *)
(** Theorem 11.2.14 *)

(* ================================================== lem:cuts-preserve-admissibility *)
(** Lemma 11.2.15 *)

(* ================================================== RD-dedekind-complete *)
(** Corollary 11.2.16 *)

(* ================================================== defn:cauchy-reals *)
(** Definition 11.3.2 *)

Definition Book_11_3_2 := @HoTTClasses.cauchy_completion.Cauchy.C.

(* ================================================== thm:Cauchy-reals-are-a-set *)
(** Theorem 11.3.9 *)

Definition Book_11_3_9 := @HoTTClasses.cauchy_completion.C_isset.

(* ================================================== RC-lim-onto *)
(** Lemma 11.3.10 *)

Definition Book_11_3_10 := @HoTTClasses.cauchy_completion.lim_issurj.

(* ================================================== RC-lim-factor *)
(** Lemma 11.3.11 *)

(* ================================================== thm:RCsim-symmetric *)
(** Lemma 11.3.12 *)

Definition Book_11_3_12 := @HoTTClasses.cauchy_completion.equiv_symm.

(* ================================================== defn:lipschitz *)
(** Definition 11.3.14 *)

Definition Book_11_3_14 := @HoTT.Classes.theory.premetric.Lipschitz.

(* ================================================== RC-extend-Q-Lipschitz *)
(** Lemma 11.3.15 *)

Definition Book_11_3_15 := @HoTTClasses.cauchy_completion.lipschitz_extend.

(* ================================================== defn:RC-approx *)
(** Theorem 11.3.16 *)

Definition Book_11_3_16 := @HoTTClasses.cauchy_completion.equiv_alt.

(* ================================================== thm:RC-sim-characterization *)
(** Theorem 11.3.32 *)

Definition Book_11_3_32 := @HoTTClasses.cauchy_completion.equiv_alt_rw.

(* ================================================== thm:RC-sim-lim *)
(** Lemma 11.3.36 *)

Definition Book_11_3_36 := @HoTTClasses.cauchy_completion.C_equiv_through_approx.

(* ================================================== thm:RC-sim-lim-term *)
(** Lemma 11.3.37 *)

Definition Book_11_3_37 := @HoTTClasses.cauchy_completion.equiv_lim.

(* ================================================== RC-continuous-eq *)
(** Lemma 11.3.39 *)

Definition Book_11_3_39 := @HoTTClasses.cauchy_completion.unique_continuous_extension.

(* ================================================== RC-binary-nonexpanding-extension *)
(** Lemma 11.3.40 *)

Definition Book_11_3_40 := @HoTTClasses.cauchy_completion.lipschitz_extend_binary.

(* ================================================== RC-archimedean *)
(** Theorem 11.3.41 *)

Definition Book_11_3_41 := @HoTTClasses.cauchy_reals.base.R_archimedean.

(* ================================================== thm:RC-le-grow *)
(** Lemma 11.3.42 *)

Definition Book_11_3_42 := @HoTTClasses.cauchy_reals.order.Rle_close_rat.

(* ================================================== thm:RC-lt-open *)
(** Lemma 11.3.43 *)

Definition Book_11_3_43_item_i := @HoTTClasses.cauchy_reals.order.Rlt_close_rat_plus.

(* ================================================== RC-sim-eqv-le *)
(** Theorem 11.3.44 *)

Definition Book_11_3_44 := @HoTTClasses.cauchy_reals.metric.equiv_metric_applied_rw.

(* ================================================== RC-squaring *)
(** Theorem 11.3.46 *)

(* ================================================== RC-archimedean-ordered-field *)
(** Theorem 11.3.48 *)

Definition Book_11_3_48_item_i := @HoTTClasses.cauchy_reals.base.R_archimedean.
Definition Book_11_3_48_item_ii := @HoTTClasses.cauchy_reals.full_ring.real_full_pseudo_srorder.
Definition Book_11_3_48_item_iii := @HoTTClasses.cauchy_reals.field.real_field.

(* ================================================== RC-initial-Cauchy-complete *)
(** Theorem 11.3.50 *)

Definition Book_11_3_50 := @HoTTClasses.cauchy_reals.initial.real_embed.

(* ================================================== lem:untruncated-linearity-reals-coincide *)
(** Lemma 11.4.1 *)

(* ================================================== when-reals-coincide *)
(** Corollary 11.4.3 *)

(* ================================================== defn:metric-space *)
(** Definition 11.5.1 *)

(* ================================================== defn:complete-metric-space *)
(** Definition 11.5.2 *)

(* ================================================== defn:total-bounded-metric-space *)
(** Definition 11.5.3 *)

(* ================================================== defn:uniformly-continuous *)
(** Definition 11.5.5 *)

(* ================================================== analysis-interval-ctb *)
(** Theorem 11.5.6 *)

(* ================================================== ctb-uniformly-continuous-sup *)
(** Theorem 11.5.7 *)

(* ================================================== analysis-bw-lpo *)
(** Theorem 11.5.9 *)

(* ================================================== classical-Heine-Borel *)
(** Theorem 11.5.11 *)

(* ================================================== defn:inductive-cover *)
(** Definition 11.5.13 *)

(* ================================================== reals-formal-topology-locally-compact *)
(** Lemma 11.5.14 *)

(* ================================================== interval-Heine-Borel *)
(** Corollary 11.5.15 *)

(* ================================================== inductive-cover-classical *)
(** Theorem 11.5.16 *)


(*********************************************************************

 Cores in a bicategory

 The core of a category is the subgroupoid consisting of only the
 isomorphisms. This construction can be specified in arbitrary
 bicategories.
 The definition we use here, is inspired by

 https://ncatlab.org/nlab/show/core+in+a+2-category

 Contents
 1. Groupoidal objects
 2. Pseudofunctor from groupoids
 3. Having cores

 *********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Eso.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.BicatOfInvertibles.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.UniversalArrow.

Local Open Scope cat.

(**
 1. Groupoidal objects
 *)
Definition groupoidal
           {B : bicat}
           (x : B)
  : UU
  := ∏ (w : B)
       (f g : w --> x)
       (α : f ==> g),
     is_invertible_2cell α.

Definition isaprop_groupoidal
           {B : bicat}
           (x : B)
  : isaprop (groupoidal x).
Proof.
  do 4 (use impred ; intro).
  apply isaprop_is_invertible_2cell.
Qed.

Definition bicat_of_groupoidal
           (B : bicat)
  : bicat
  := fullsubbicat B groupoidal.

Definition is_univalent_2_1_bicat_of_groupoidal
           {B : bicat}
           (HB_2_1 : is_univalent_2_1 B)
  : is_univalent_2_1 (bicat_of_groupoidal B).
Proof.
  apply is_univalent_2_1_fullsubbicat.
  exact HB_2_1.
Defined.

Definition is_univalent_2_0_bicat_of_groupoidal
           {B : bicat}
           (HB_2 : is_univalent_2 B)
  : is_univalent_2_0 (bicat_of_groupoidal B).
Proof.
  apply is_univalent_2_0_fullsubbicat.
  - exact HB_2.
  - exact isaprop_groupoidal.
Defined.

Definition is_univalent_2_bicat_of_groupoidal
           {B : bicat}
           (HB_2 : is_univalent_2 B)
  : is_univalent_2 (bicat_of_groupoidal B).
Proof.
  apply is_univalent_2_fullsubbicat.
  - exact HB_2.
  - exact isaprop_groupoidal.
Defined.

(**
 2. Pseudofunctor from groupoids
 *)
Definition groupoidal_to_inv2cells_data
           (B : bicat)
  : psfunctor_data (bicat_of_groupoidal B) (bicat_of_inv2cells B).
Proof.
  use make_psfunctor_data.
  - exact (λ x, pr1 x ,, tt).
  - exact (λ _ _ f, f).
  - simple refine (λ x y f g α, pr1 α ,, _).
    exact (pr2 y (pr1 x) (pr1 f) (pr1 g) (pr1 α)).
  - refine (λ x, id2 _ ,, _) ; cbn.
    is_iso.
  - refine (λ _ _ _ f g, id2 _ ,, _) ; cbn.
    is_iso.
Defined.

Definition groupoidal_to_inv2cells_laws
           (B : bicat)
  : psfunctor_laws (groupoidal_to_inv2cells_data B).
Proof.
  repeat split ;
    intro ; intros ;
    (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ]) ;
    cbn in *.
  - apply idpath.
  - apply idpath.
  - rewrite id2_rwhisker.
    rewrite !id2_left.
    apply idpath.
  - rewrite lwhisker_id2.
    rewrite !id2_left.
    apply idpath.
  - rewrite id2_rwhisker, lwhisker_id2.
    rewrite !id2_left, !id2_right.
    apply idpath.
  - rewrite id2_left, id2_right.
    apply idpath.
  - rewrite id2_left, id2_right.
    apply idpath.
Qed.

Definition groupoidal_to_inv2cells
           (B : bicat)
  : psfunctor (bicat_of_groupoidal B) (bicat_of_inv2cells B).
Proof.
  use make_psfunctor.
  - exact (groupoidal_to_inv2cells_data B).
  - exact (groupoidal_to_inv2cells_laws B).
  - split ; intros ; apply is_invertible_2cell_bicat_of_inv2cells.
Defined.

(**
 3. Having cores
 *)
Definition has_cores
           (B : bicat)
  : UU
  := ∑ (R : right_universal_arrow
              (groupoidal_to_inv2cells B)),
     ∏ (x : B),
     let ε := pr1 (pr12 R (x ,, tt)) in
     is_eso ε × pseudomonic_1cell ε.


Require Import Omega.

Module RegFileArray.

  Fixpoint leb (m:nat) : nat -> bool :=
    match m with
    | O => fun _:nat => true
    | S m' =>
      fun n:nat => match n with
              | O => false
              | S n' => leb m' n'
              end
    end.

Eval compute in (leb 2).


Require Import List.
Require MSetProperties.
Require FMapFacts.
Require Import NArith.
Require Import ZArith.
Require Import QArith.
Require Import Qpower.
Require Import divsteps_base.
Require Import divsteps_def.
Require Import divsteps_convexhull.

Lemma Dred_eq : forall x, Deq (Dred x) x.
Proof.
intros x.
unfold Deq.
rewrite Dcompare_Q.
rewrite <- Qeq_alt.
destruct x as [[|m|m] e]; try reflexivity; simpl;
(revert e; induction m; try reflexivity;
 intros e; simpl;
 rewrite IHm;
 unfold inject_D; simpl;
 rewrite <- Z.add_1_l, Qpower_plus by discriminate; simpl;
 change 2 with (inject_Z 2);
 rewrite Qmult_assoc, <- inject_Z_mult, Z.mul_comm;
 reflexivity).
Qed.

Module DDSetProperties := MSetProperties.OrdProperties DDSet.

Lemma Qsum_map_partition : forall {A} f l (g : A -> Q),
 Qsum (map g l) == Qsum (map g (fst (partition f l))) + Qsum (map g (snd (partition f l))).
Proof.
intros A f l g.
induction l;[reflexivity|].
assert (Hl := surjective_pairing (partition f l)).
simpl (Qsum (map g (a :: l))).
rewrite IHl.
case (f a) eqn:H;
[rewrite (partition_cons1 f a l Hl H)
|rewrite (partition_cons2 f a l Hl H)
];simpl;ring.
Qed.

Lemma Qcombine_partition : forall f l,
 QQeq (Qcombine l) (QQplus (Qcombine (fst (partition f l))) (Qcombine (snd (partition f l)))).
Proof.
intros f l.
induction l;[split;reflexivity|].
assert (Hl := surjective_pairing (partition f l)).
simpl (Qcombine (a :: l)).
unfold QQeq.
destruct IHl as [-> ->].
cbn -[partition].
case (f a) eqn:H;
[rewrite (partition_cons1 f a l Hl H)
|rewrite (partition_cons2 f a l Hl H)
];simpl;split;ring.
Qed.

Lemma in_fst_partition : forall {A} f l (x : A),
  In x (fst (partition f l)) -> f x = true.
Proof.
intros A f l x.
induction l;[intros []|].
simpl.
destruct (partition f l) as [l1 l2].
case (f a) eqn:H;[intros [Hx|Hx]|]; auto.
congruence.
Qed.

Lemma in_snd_partition : forall {A} f l (x : A),
  In x (snd (partition f l)) -> f x = false.
Proof.
intros A f l x.
induction l;[intros []|].
simpl.
destruct (partition f l) as [l1 l2].
case (f a) eqn:H;[|intros [Hx|Hx]]; auto.
congruence.
Qed.

Lemma in_nonempty_convex_hull : forall a s (p : QQ),
  in_convex_hull p (DDSet.add a s) ->
  QQeq p (inject_DD a) \/ (exists c, exists q, 0 <= c <= 1 /\ in_convex_hull q s
                           /\ QQeq p (QQavg c (inject_DD a) q)).
Proof.
intros a s p [l [H0 [H1 H2]]].
pose (f := (fun p:Q * DD => if DDOrder.eq_dec (snd p) a then true else false)).
rewrite (Qsum_map_partition f) in H1.
assert (H2' : QQeq
        (QQplus (Qcombine (fst (partition f l)))
           (Qcombine (snd (partition f l)))) p)
 by (unfold QQeq;destruct (Qcombine_partition f l) as [<- <-]; auto).
set (l1 := fst (partition f l)) in *.
set (l2 := snd (partition f l)) in *.
set (c := Qsum (map fst l1)) in *.
set (d := Qsum (map fst l2)) in *.
assert (Hl := elements_in_partition f l (surjective_pairing (partition f l))).
assert (H0' : forall q, In q (map fst l2) -> 0 <= q).
 intros q.
 rewrite in_map_iff.
 intros [[x y] [Hx Hx0]].
 eapply or_intror in Hx0.
 apply Hl in Hx0.
 simpl in Hx.
 rewrite Hx in Hx0.
 specialize (H0 _ _ Hx0).
 tauto.
assert (Hl1 : QQeq (Qcombine l1) (QQscale c (inject_DD a))).
 unfold QQeq, QQscale.
 clear.
 assert (Hl1 := in_fst_partition f l).
 fold l1 in Hl1.
 induction l1 as [|[d p] l1 IHl1];[split;reflexivity|].
 unfold c.
 simpl.
 rewrite (Qplus_comm d), !Qmult_plus_distr_l.
 destruct (IHl1 (fun x H => Hl1 x (or_intror H))) as [-> ->].
 specialize (Hl1 _ (or_introl (refl_equal _))).
 unfold f in Hl1.
 destruct (DDOrder.eq_dec _) as [[He Hf]|];[|discriminate].
 apply Deq_Q in He.
 apply Deq_Q in Hf.
 rewrite He, Hf.
 split; reflexivity.

case (Qeq_dec d 0);intros Hd;[left|right].
* unfold QQeq.
  destruct H2' as [<- <-].
  simpl.
  rewrite Hd, Qplus_0_r in H1.
  assert (Hl1' : QQeq (Qcombine l1) (inject_DD a)).
   unfold QQeq.
   setoid_replace (fst (inject_DD a)) with (1 * fst (inject_DD a)) by ring.
   setoid_replace (snd (inject_DD a)) with (1 * snd (inject_DD a)) by ring.
   rewrite <- H1.
   apply Hl1.
  fold l1 l2 in Hl.
  assert (Hl2 : QQeq (Qcombine l2) (0,0)).
   clear -H0' Hd.
   induction l2;[split;reflexivity|].
   unfold QQeq.
   unfold d in Hd; simpl in *.
   assert (H1 : 0 <= fst a0) by firstorder.
   assert (H2 : 0 <= Qsum (map fst l2)) by firstorder using Qsum_pos.
   setoid_replace (fst a0) with 0;
    [rewrite !Qmult_0_l, !Qplus_0_r;
     apply IHl2; try firstorder|];
   apply Qle_antisym;try assumption;
   rewrite <- Hd;
   apply Qle_minus_iff;
   ring_simplify;
   assumption.
   unfold QQeq.
   destruct Hl1' as [-> ->].
   destruct Hl2 as [-> ->].
   simpl; split; ring.
* exists c.
  exists (QQscale (/d) (Qcombine l2)).
  assert (Hd0 : 0 <= d).
   apply Qsum_pos.
   intros z.
   rewrite in_map_iff.
   intros [[z1 z2] [<- Hz]].
   specialize (H0 z1 z2).
   rewrite (elements_in_partition f _ (surjective_pairing (partition f l))) in H0.
   tauto.
  split;[split|split].
+ apply Qsum_pos.
  intros z.
  rewrite in_map_iff.
  intros [[z1 z2] [<- Hz]].
  specialize (H0 z1 z2).
  rewrite (elements_in_partition f _ (surjective_pairing (partition f l))) in H0.
  tauto.
+ rewrite <- H1.
  setoid_replace c with (c + 0) at 1 by ring.
  apply Qplus_le_r.
  assumption.
+ pose (g := fun x => (/ d * fst x, snd x : DD)).
  exists (map g l2).
  apply Qle_lt_or_eq in Hd0.
  destruct Hd0 as [Hd0|Hd0];[|symmetry in Hd0;contradiction].
  split;[|split].
  - clear - H0 Hd0.
    intros q p.
    rewrite in_map_iff.
    intros [[x y] [Hxy Hqp]].
    injection Hxy; intros <- <-; clear Hxy.

    specialize (H0 x y).
    rewrite (elements_in_partition f _ (surjective_pairing (partition f l))) in H0.
    specialize (H0 (or_intror Hqp)).
    split;
     [rewrite Qmult_comm; apply Qle_shift_div_l; auto;
      ring_simplify; tauto|].
    destruct H0 as [_ H0].
    rewrite DDSet.add_spec in H0.
    destruct H0 as [H0|H0];[|assumption].
    apply in_snd_partition in Hqp.
    unfold f in Hqp.
    destruct (DDOrder.eq_dec _) as [Hy|Hy];[discriminate|].
    elim Hy.
    assumption.
  - clearbody l2; clear - Hd.
    rewrite map_map.
    pose (f := fun x => / d * x).
    change (fun x => _) with (fun x : Q * DD => f (fst x)).
    rewrite <- map_map.
    setoid_replace 1 with (d/d) by field;auto.
    unfold d at 1.
    clearbody d; clear - Hd.
    unfold f.
    rewrite Qsum_mult.
    rewrite Qmult_comm.
    reflexivity.
  - clearbody l2 d; clear.
    induction l2;[split;simpl;ring|].
    unfold QQeq; simpl.
    destruct IHl2 as [-> ->];simpl.
    unfold Qdiv.
    split; ring.
+ cut (QQeq (QQplus (Qcombine l1) (Qcombine l2))
       (QQavg c (inject_DD a) (QQscale (/ d) (Qcombine l2)))).
   destruct H2' as [H2'1 H2'2].
   symmetry in H2'1.
   symmetry in H2'2.
   intros [Ha Hb].
   split; eauto using Qeq_trans.
  unfold QQavg, QQeq.
  simpl.
  destruct Hl1 as [-> ->]; simpl.
  rewrite <- H1.
  split;field;auto.
Qed.

Lemma in_nested_convex_hull : forall s1 s2 (p : QQ),
  in_convex_hull p s1 ->
  (forall (q :DD) q', QQeq q q' -> DDSet.In q s1 -> in_convex_hull q' s2) ->
  in_convex_hull p s2.
Proof.
intros s1.
induction s1 as [H|s0 s1 IH a _ Hadd] using DDSetProperties.P.set_induction;
[intros;
 eelim in_convex_hull_Empty;
 eapply in_convex_hull_morph2;[|eassumption];
 firstorder using DDSet.empty_spec
|].
intros s2 p H1 H2.
apply DDSetProperties.P.Add_Equal in Hadd.
assert (Hp : in_convex_hull p (DDSet.add a s0)) by
 (eapply in_convex_hull_morph2;[apply Hadd|apply H1]).
apply in_nonempty_convex_hull in Hp.
destruct Hp as [Hp|[c [q [Hc [Hq Hp]]]]].
* apply H2 with a;
   [destruct Hp;split;symmetry;assumption|].
  rewrite Hadd.
  apply DDSet.add_spec; left; reflexivity.
* assert (H2' : forall (q : DD) (q' : QQ),
     QQeq q q' -> DDSet.In q s0 -> in_convex_hull q' s2).
   intros q0 q' Hq0 Hq0s.
   apply H2 with q0; auto.
   rewrite Hadd.
   apply DDSet.add_spec;right; assumption.
  specialize (IH s2 _ Hq H2').
  assert (Ha : in_convex_hull (inject_DD a) s2).
   apply H2 with a;[split;reflexivity|].
   rewrite Hadd.
   apply DDSet.add_spec; left; reflexivity.
  apply in_convex_hull_morph1 with (QQavg c (inject_DD a) q);
   [unfold QQeq in *; split; symmetry; tauto|].
  apply QQavg_in_convex_hull; auto.
Qed.

Lemma in_convex_hull_convexHull : forall s q p,
  in_convex_hull p (DDSet.add q s) ->
  in_convex_hull p (DDSet.add q (convexHull s)).
Proof.
intros s q p H.
apply in_nonempty_convex_hull in H.
destruct H as [H|[c [r [Hc [Hr Hp]]]]].
* apply QQeq_sym in H.
  eapply in_convex_hull_morph1;[apply H|].
  apply in_in_convex_hull;apply DDSet.add_spec;left;reflexivity.
* assert (H : in_convex_hull r (convexHull s)).
   apply in_nested_convex_hull with s;auto.
   intros t0 t1 Ht H.
   eapply in_convex_hull_morph1;[apply Ht|].
   auto using convexHull_sound.
  change DD in q.
  assert (Hp' : QQeq (QQavg c (q:QQ) r) p) by
   (destruct Hp;split;symmetry;assumption).
  eapply in_convex_hull_morph1;[apply Hp'|].
  apply QQavg_in_convex_hull;auto.
  + apply in_in_convex_hull;apply DDSet.add_spec;left;reflexivity.
  + apply in_convex_hull_subset with (convexHull s); auto.
    apply DDSetProperties.P.subset_add_2.
    apply DDSetProperties.P.subset_refl.
Qed.

Definition State_lookup (i : Z) (m : State) :=
  match (ZMap.find i m) with
  | None => DDSet.empty
  | Some s => s
  end.

Lemma State_lookup_join2 : forall p delta i q m,
DDSet.In p (State_lookup delta m) ->
DDSet.In p
  (State_lookup delta (State_join i q m)).
Proof.
intros p delta i q m.
unfold State_lookup.
case (ZMap.find _ _) as [t|] eqn:Hi;
[|intros H; apply DDSet.empty_spec in H; contradiction].
unfold State_join.
destruct (OrdersEx.Z_as_DT.eq_decidable i delta) as [->|Hdelta].
+ rewrite Hi,
          (ZMap.find_1 (ZMap.add_1 _ _ (refl_equal delta))),
          DDSet.union_spec.
  auto.
+ apply ZMap.find_2 in Hi.
  eapply (ZMap.add_2 _ Hdelta) in Hi.
  rewrite (ZMap.find_1 Hi).
  auto.
Qed.

Lemma State_lookup_fromList : forall l q p delta s,
 DDSet.In p (DDSet.add q s) ->
 In (delta, s) l ->
 DDSet.In p (DDSet.add q (State_lookup delta (State_fromList l))).
Proof.
intros l q p delta s Hps Hsl.
rewrite DDSet.add_spec in *.
destruct Hps as [Hps|Hps];[left;assumption|right].
unfold State_fromList.
rewrite <- fold_left_rev_right.
rewrite in_rev in Hsl.
induction (rev l);[contradiction|].
simpl.
destruct Hsl as [->|Hsl];[|auto using State_lookup_join2].
simpl.
unfold State_lookup, State_join.
rewrite (ZMap.find_1 (ZMap.add_1 _ _ (refl_equal delta))).
destruct (ZMap.find _ _);[rewrite DDSet.union_spec|];auto.
Qed.

Lemma State_in_convex_hull_fromList1 : forall l q p delta s,
 in_convex_hull p (DDSet.add q s) ->
 In (delta, s) l ->
 in_convex_hull p (DDSet.add q (State_lookup delta (State_fromList l))).
Proof.
intros l q p delta s [c [Hps1 [Hps2 [Hps3 Hps4]]]] Hsl.
exists c;split;[|repeat split;auto].
intros q' p' Hqp'.
destruct (Hps1 q' p' Hqp') as [Hps11 Hps12].
split; eauto using State_lookup_fromList.
Qed.

Definition Matrix : Set := D * D * D * D.
Definition even_matrix : Matrix :=
  (Dhalf 1, 0:D, 0:D, 1:D)%Z.
Definition odd_pos_matrix : Matrix :=
  (Dhalf 1, Dhalf (-1), 1:D, 0:D)%Z.
Definition odd_nonpos_matrix : Matrix :=
  (Dhalf 1, Dhalf 1, 0:D, 1:D)%Z.
Definition linearD_of (m : Matrix) (p : DD) : DD :=
  let '(a,b,c,d) := m in
  (Dadd (Dmult a (fst p)) (Dmult b (snd p))
  ,Dadd (Dmult c (fst p)) (Dmult d (snd p))).
Definition linearQ_of (m : Matrix) (p : QQ) : QQ :=
  let '(a,b,c,d) := m in
  (a * (fst p) + b * (snd p), c * (fst p) + d * (snd p)).

Lemma even_trans_matrix : forall p,
  DDeq (even_trans p) (linearD_of even_matrix p).
Proof.
intros [x y].
unfold DDeq; simpl.
rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, !Dhalf_Q.
change (inject_D 1%Z:Q) with 1.
change (inject_D 0%Z:Q) with 0.
split;field.
Qed.

Lemma odd_pos_trans_matrix : forall p,
  DDeq (odd_pos_trans p) (linearD_of odd_pos_matrix p).
Proof.
intros [x y].
unfold DDeq, odd_pos_trans.
rewrite Dred_eq; simpl.
rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, !Dhalf_Q, Dsub_Q.
change (inject_D (-1)%Z:Q) with (-1).
change (inject_D 1%Z:Q) with 1.
change (inject_D 0%Z:Q) with 0.
split;field.
Qed.

Lemma odd_nonpos_trans_matrix : forall p,
  DDeq (odd_nonpos_trans p) (linearD_of odd_nonpos_matrix p).
Proof.
intros [x y].
unfold DDeq, odd_nonpos_trans.
rewrite Dred_eq; simpl.
rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, !Dhalf_Q, Dadd_Q.
change (inject_D 1%Z:Q) with 1.
change (inject_D 0%Z:Q) with 0.
split;field.
Qed.

Lemma linearD_of_morph : forall m q1 q2,
  DDeq q1 q2 -> DDeq (linearD_of m q1) (linearD_of m q2).
Proof.
intros [[[a b] c] d] [x1 y1] [x2 y2] [Hx Hy].
unfold DDeq.
simpl in *.
rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, Hx, Hy in *.
split;reflexivity.
Qed.

Lemma in_DDSet_map : forall trans p s,
 (forall q1 q2, DDeq q1 q2 -> DDeq (trans q1) (trans q2)) ->
 DDSet.In p s ->
 DDSet.In (trans p) (DDSet_map trans s).
Proof.
intros trans [x y] s trans_morph Hps.
unfold DDSet_map.
rewrite DDSet.fold_spec, <- fold_left_rev_right.
rewrite <- DDSet.elements_spec1, <- SetoidList.InA_rev in Hps.
fold DDSet.elt in Hps.
induction (rev (DDSet.elements s));
 [rewrite SetoidList.InA_nil in Hps;elim Hps|simpl].
rewrite DDSet.add_spec.
rewrite SetoidList.InA_cons in Hps.
destruct Hps as [Hps|Hps];[|right;auto].
left.
apply trans_morph.
assumption.
Qed.

Lemma in_convex_hull_map_ext : forall trans m p q s,
 (forall p, DDeq (trans p) (linearD_of m p)) ->
 QQeq (linearQ_of m p) q ->
 in_convex_hull p (DDSet.add (0:D,0:D)%Z s) ->
 in_convex_hull q (DDSet.add (0:D,0:D)%Z (DDSet_map trans s)).
Proof.
intros trans m p p' s trans_ext Hp [l [Hl1 [Hl2 [Hl3 Hl4]]]].
assert (trans_morph : forall q1 q2, DDeq q1 q2 -> DDeq (trans q1) (trans q2)).
 intros q1 q2 Hq.
 destruct (trans_ext q1) as [trans_ext11 trans_ext12].
 destruct (trans_ext q2) as [trans_ext21 trans_ext22].
 unfold DDeq.
 rewrite !Deq_Q in *.
 rewrite trans_ext11, trans_ext21, trans_ext12, trans_ext22.
 rewrite <-!Deq_Q.
 apply (linearD_of_morph m _ _ Hq).
exists (map (fun cp => (fst cp, linearD_of m (snd cp))) l);split;[|split].
* intros q [f g] H.
  apply in_map_iff in H.
  destruct H as [[x y] [Hx1 Hx2]].
  simpl in Hx1.
  injection Hx1; intros <- <-.
  destruct (Hl1 _ _ Hx2).
  specialize (trans_ext y).
  change (DDOrder.eq (trans y) (linearD_of m y)) in trans_ext.
  rewrite <- trans_ext.
  split;auto.
  rewrite DDSet.add_spec in *.
  destruct H0 as [[H0l H0r]|H0];[left|right;auto using in_DDSet_map].
  destruct y as [yl yr].
  apply Deq_Q in H0l; apply Deq_Q in H0r.
  simpl in *.
  rewrite trans_ext.
  set (trans' := linearD_of m).
  change (Deq (fst (trans' (yl, yr))) 0%Z /\ Deq (snd (trans' (yl, yr))) 0%Z).
  destruct m as [[[ma mb] mc] md].
  simpl.
  rewrite !Deq_Q, !Dadd_Q, !Dmult_Q, H0l, H0r.
  change (0%Z:Q) with 0.
  split; ring.
* rewrite <- Hl2.
  clear - l.
  induction l;[reflexivity|].
  simpl.
  rewrite IHl.
  reflexivity.
* clear - Hl3 Hl4 Hp.
  destruct p as [x y].
  destruct Hp as [Hp1 Hp2].
  destruct m as [[[a b] c] d].
  unfold QQeq.
  simpl in *.
  rewrite <- Hp1, <- Hp2, <- Hl3, <- Hl4; clear Hp1 Hp2 Hl3 Hl4.
  induction l;simpl;[split; ring|].
  destruct IHl as [-> ->].
  rewrite !Dadd_Q, !Dmult_Q.
  split; ring.
Qed.

Lemma inject_Z_half : forall a : Z, Z.Even a -> inject_Z (a / 2)%Z == inject_Z a / 2.
Proof.
intros a Ha.
rewrite <- Zeven_equiv in Ha.
rewrite (Zeven_div2 _ Ha) at 2.
rewrite inject_Z_mult.
change (inject_Z 2) with 2.
rewrite <- Qmult_comm, Qdiv_mult_l, Z.div2_div by discriminate.
reflexivity.
Qed.

Lemma inject_Z_D_Q : forall a : Z, (a:D) == inject_Z a.
intros a.
unfold inject_D.
simpl.
ring.
Qed.

Lemma Zodd_opp : forall a : Z, Zodd a -> Zodd (-a).
Proof.
intros.
rewrite Zodd_ex_iff in *.
destruct H as [m ->].
exists (-m-1)%Z.
ring.
Qed.

Lemma in_narrow : forall (M g f : Z) s,
 (0 < M)%Z ->
 narrow M s = true ->
 in_convex_hull (g / M, f / M) (DDSet.add (0:D,0:D)%Z s) ->
 g = 0%Z.
Proof.
intros M g f s HM Hs Hg.
rewrite Zlt_Qlt, <- !inject_Z_D_Q in HM.
change (0%Z:Q) with 0 in HM.
cut (-1 < M * (g / M) /\ M * (g / M) < 1).
  rewrite Qmult_div_r by auto with *.
  change (-1) with ((-1)%Z:Q).
  change 1 with (1%Z:Q).
  rewrite !inject_Z_D_Q, <- !Zlt_Qlt.
  auto with *.
set (zero := (0:D,0:D)%Z).
assert (Hnarrow : forall x y, DDSet.In (x, y) (DDSet.add zero s) -> -1 < M*x /\ M*x < 1).
 apply Qlt_le_weak in HM.
 intros x y Hxy.
 apply DDSet.add_spec in Hxy.
 destruct Hxy as [[Hxyl Hxyr]|Hxy].
  apply Deq_Q in Hxyl, Hxyr; simpl in *.
  rewrite Hxyl.
  change (0%Z:Q) with 0.
  rewrite Qmult_0_r, !Qlt_alt.
  split;reflexivity.
 unfold narrow in Hs.
 case (DDSet.min_elt s) as [[l l0]|] eqn:Hmin;
  [|apply DDSet.min_elt_spec3 in Hmin;elim (Hmin _ Hxy)].
 case (DDSet.max_elt s) as [[h h0]|] eqn:Hmax;
  [|apply DDSet.max_elt_spec3 in Hmax;elim (Hmax _ Hxy)].
 apply (fun H => DDSet.min_elt_spec2 H Hxy) in Hmin.
 apply (fun H => DDSet.max_elt_spec2 H Hxy) in Hmax.
 apply andb_prop in Hs.
 destruct Hs as [Hs1 Hs2].
 change (~(Dcompare x l = Lt \/ (Dcompare x l = Eq /\ Dcompare y l0 = Lt))) in Hmin.
 change (~(Dcompare h x = Lt \/ (Dcompare h x = Eq /\ Dcompare h0 y = Lt))) in Hmax.
 apply Dltb_Q in Hs1.
 apply Dltb_Q in Hs2.
 change ((-1)%Z:Q) with (-1) in Hs1.
 change ((1)%Z:Q) with 1 in Hs2.
 rewrite Dmult_Q, !Dcompare_Q, <- Qeq_alt, <- !Qlt_alt in *.
 assert (Hmin' : l <= x) by (apply Qnot_lt_le; tauto).
 assert (Hmax' : x <= h) by (apply Qnot_lt_le; tauto).
 apply (fun H => Qmult_le_compat_r _ _ _ H HM) in Hmin'.
 apply (fun H => Qmult_le_compat_r _ _ _ H HM) in Hmax'.
 rewrite (Qmult_comm M) in *.
 split; eauto using Qle_lt_trans, Qlt_le_trans.
clear Hs.
destruct Hg as [l [Hl1 [Hl2 [Hl3 _]]]].
simpl in Hl3.
rewrite <- Hl3.
pose (l' := filter (fun x => negb (Qle_bool (fst x) 0)) l).
assert (Hl1' : forall (q : Q) (p : DD), In (q, p) l' -> 0 < q /\ q <= 1 /\ DDSet.In p (DDSet.add zero s)).
 intros q p Hqp.
 unfold l' in Hqp.
 rewrite filter_In in Hqp.
 destruct Hqp as [Hqp Hfilter].
 destruct (Hl1 _ _ Hqp).
 repeat split; try tauto;
 [apply in_split in Hqp;
  case (Qlt_le_dec 0 q); auto;
  intros H1;
  rewrite <- Qle_bool_iff in H1;
  simpl in Hfilter;
  rewrite H1 in Hfilter;
  discriminate
 |].
 rewrite <- Hl2.
 clear -Hl1 Hqp.
 apply in_split in Hqp.
 destruct Hqp as [l1 [l2 ->]].
 rewrite map_app, Qsum_app; simpl.
 setoid_replace q with (0 + (q + 0)) at 1 by ring.
 repeat apply Qplus_le_compat; auto with *;
 apply Qsum_pos;
 intros x Hx;
 rewrite in_map_iff in Hx;
 destruct Hx as [[y1 y2] [<- Hy]];
 specialize (Hl1 y1 y2);
 assert (H := in_or_app l1 ((q,p)::l2) (y1, y2));
 simpl in H;
 tauto.
assert (Hl2' : Qsum (map fst l') == 1 /\ fst (Qcombine l') == fst (Qcombine l)).
 rewrite <- Hl2.
 clear -Hl1.
 induction l;[split;reflexivity|].
 unfold l'; simpl.
 destruct IHl as [<- <-];[firstorder|].
 specialize (Hl1 (fst a) (snd a)).
 rewrite <-surjective_pairing in Hl1.
 specialize (Hl1 (or_introl (refl_equal _))).
 destruct Hl1 as [Hl1 _].
 case (Qle_bool (fst a) 0) eqn:Ha;[|split;reflexivity].
 rewrite Qle_bool_iff in Ha.
 simpl.
 rewrite (Qle_antisym _ _ Ha Hl1).
 split;ring.
change (-1) with (Qopp 1).
destruct Hl2' as [Hl2' <-].
rewrite <- Hl2'.
case l' as [|a' l'];[discriminate|].
clear Hl1 Hl2 Hl3 Hl2'.
simpl.
rewrite Qopp_plus, Qmult_plus_distr_r, (Qplus_comm (M*_)).
cut (- Qsum (map fst l') <= M * fst (Qcombine l') <= Qsum (map fst l')).
 intros [H1 H2].
 rewrite (Qmult_comm (fst a')).
 setoid_replace (-fst a') with (-1 * fst a') by ring.
 setoid_replace (fst a') with (1 * fst a') at 4 by ring.
 rewrite Qmult_assoc.
 specialize (Hl1' (fst a') (snd a')).
 rewrite <- surjective_pairing in Hl1'.
 destruct Hl1' as [Ha1 [_ Ha2]];auto with *.
 rewrite (surjective_pairing (snd a')) in Ha2.
 specialize (Hnarrow _ _ Ha2).
 split;
 apply Qplus_lt_le_compat; auto;
 apply Qmult_lt_compat_r; tauto.
assert (Hl1 : forall (q : Q) (p : DD),
       In (q, p) l' -> 0 < q /\ q <= 1 /\ DDSet.In p (DDSet.add zero s)) by firstorder.
clear -Hnarrow Hl1.
induction l' as [|[c p] l IHl];simpl;[rewrite Qmult_0_r;auto with *|].
rewrite (Qplus_comm c), Qopp_plus, Qmult_plus_distr_r.
specialize (IHl (fun q p H => Hl1 q p (or_intror H))).
rewrite (Qmult_comm c).
setoid_replace (-c) with (-1 * c) by ring.
setoid_replace c with (1 * c) at 4 by ring.
rewrite Qmult_assoc.
specialize (Hl1 c p (or_introl (refl_equal _))).
destruct Hl1 as [Hc0 [Hc1 Hp]].
rewrite (surjective_pairing p) in Hp.
specialize (Hnarrow _ _ Hp).
split;
apply Qplus_le_compat; try tauto;
apply Qmult_le_compat_r; auto with *;
apply Qlt_le_weak; tauto.
Qed.

Definition in_State (M : Z) (ds : divsteps.State) (s : State) : Prop :=
  divsteps.g ds = 0%Z \/
  in_convex_hull (divsteps.g ds / M, divsteps.f ds / M)
   (DDSet.add (0:D,0:D)%Z (State_lookup (divsteps.delta ds) s)).

Lemma in_State_step : forall M ds st, (0 < M)%Z -> Z.Odd (divsteps.f ds) ->
 in_State M ds st -> in_State M (divsteps.step ds) (processDivstep M st).
Proof.
intros M [delta f g] st HM Hf [Hst|Hst];[left; auto using divsteps.zero_step|].
rewrite <- Zodd_equiv in Hf.
simpl in *.
set (ds' := divsteps.step _).
pose (delta' := divsteps.delta ds').
pose (f' := divsteps.f ds').
pose (g' := divsteps.g ds').
unfold processDivstep.
set (fm2 := fun kv => _).
set (fm1 := fun kv => _).
set (st1 := State_fromList (flat_map fm1 _)).
set (st2 := State_fromList (flat_map fm2 _)).
case (Z.eq_dec g 0) as [Hg0|Hg0];
 [left;unfold ds'; auto using divsteps.zero_step|].
case (Z.eq_dec g' 0) as [Hg'0|Hg'0];
 [left;auto|].
assert (H : {s | ZMap.MapsTo delta s st}).
  clear - Hst Hg0 HM.
  unfold State_lookup in Hst.
  case (ZMap.find delta st) as [s|] eqn:Hfind;
    [exists s; auto using ZMap.find_2|].
  apply in_convex_hull_singleton in Hst.
  destruct Hst as [Hst _].
  simpl in Hst.
  rewrite <- inject_Z_injective in Hg0.
  rewrite Zlt_Qlt in HM.
  rewrite <- !inject_Z_D_Q in *.
  apply Qinv_lt_0_compat in HM.
  apply Qmult_integral_l in Hst; auto.
  rewrite Hst in HM.
  discriminate.
destruct H as [s Hs].
pose (divstep_trans :=
  if Z.even g then even_trans
              else if (0 <? delta)%Z then odd_pos_trans else odd_nonpos_trans).
pose (divstep_matrix :=
  if Z.even g then even_matrix
              else if (0 <? delta)%Z then odd_pos_matrix else odd_nonpos_matrix).
set (zero := (0%Z:D,0%Z:D)) in *.
assert (Hst' : in_convex_hull (g' / M, f' / M) (DDSet.add zero (State_lookup delta' st1))).
  assert (Hx := ZMap.elements_1 Hs).
  apply SetoidList.InA_altdef in Hx.
  apply Exists_exists in Hx.
  destruct Hx as [x [Hx1 Hx2]].
  apply State_in_convex_hull_fromList1 with (DDSet_map divstep_trans (snd x)).
  * apply in_convex_hull_map_ext with divstep_matrix (g / M, f / M).
    - intros p. clear.
      case (Z.even g) in *;[apply even_trans_matrix|].
      case (0 <? delta)%Z in *;[apply odd_pos_trans_matrix|].
      apply odd_nonpos_trans_matrix.
    - clear -Hf.
      unfold QQeq, g', f', ds', divsteps.step; simpl.
      case (Z.even g) eqn:Hg in *;[apply Zeven_bool_iff in Hg
                                  |apply (f_equal negb) in Hg;
                                   rewrite Z.negb_even in Hg;
                                   apply Zodd_bool_iff in Hg;
                                   case (0 <? delta)%Z in *];simpl;
        rewrite !Dhalf_Q;
        change (inject_D (-1)%Z:Q) with (-1);
        change (inject_D 1%Z:Q) with 1;
        change (inject_D 0%Z:Q) with 0;
        split; try ring;
        unfold Z.sub;
        rewrite !inject_Z_D_Q, inject_Z_half, ?inject_Z_plus, ?inject_Z_opp;
        try (unfold Qdiv; ring);
        apply Zeven_equiv;
        auto using Zodd_plus_Zodd, Zodd_opp.
    - clear -Hst Hs Hx2.
      destruct Hx2 as [_ Hx2].
      replace (snd x) with s.
      unfold State_lookup in Hst.
      rewrite (ZMap.find_1 Hs) in Hst.
      assumption.
  * apply in_flat_map.
    exists x; split; auto.
    clear -Hx2; destruct x; destruct Hx2 as [Hx1 Hx2].
    unfold divsteps.step in ds'; cbn -[Z.ltb Z.add Z.sub] in *.
    rewrite <- Hx1.
    case (Z.even g) in *;[left;reflexivity|].
    right;left.
    case (0 <? delta)%Z in *;
    reflexivity.
* clear s Hs.
  assert (H : {s | ZMap.MapsTo delta' s st1}).
   clear - Hst' Hg'0 HM.
   unfold State_lookup in Hst'.
   case (ZMap.find delta' st1) as [s|] eqn:Hfind;
     [exists s; auto using ZMap.find_2|].
   apply in_convex_hull_singleton in Hst'.
   destruct Hst' as [Hst' _].
   simpl in Hst'.
   rewrite <- inject_Z_injective in Hg'0.
   rewrite Zlt_Qlt in HM.
   rewrite <- !inject_Z_D_Q in *.
   apply Qinv_lt_0_compat in HM.
   apply Qmult_integral_l in Hst'; auto.
   rewrite Hst' in HM.
   discriminate.
  destruct H as [s Hs].
  assert (Hx := ZMap.elements_1 Hs).
  apply SetoidList.InA_altdef in Hx.
  apply Exists_exists in Hx.
  destruct Hx as [x [Hx1 Hx2]].
  unfold State_lookup in Hst'.
  rewrite (ZMap.find_1 Hs) in Hst'.
  case (narrow M s) eqn:Hnarrow;
  [left;
   apply (in_narrow _ _ _ _ HM Hnarrow Hst')
  |].
  right.
  fold g' f' delta'.
  apply State_in_convex_hull_fromList1 with (convexHull s).
    auto using in_convex_hull_convexHull.
  apply in_flat_map.
  exists x.
  split; try tauto.
  destruct x as [x0 x1].
  destruct Hx2 as [Hx2 Hx3]; simpl in *.
  rewrite <- Hx2, <- Hx3, Hnarrow.
  auto with *.
Qed.

Module ZMapProperties := FMapFacts.OrdProperties ZMap.

Theorem processDivstep_correct : forall N M f g,
  Z.Odd f ->
  (f <= M)%Z -> (0 <= g <= f)%Z ->
  ZMap.Empty (N.iter N (processDivstep M) state0) ->
  divsteps.g (N.iter N divsteps.step (divsteps.init f g)) = 0%Z.
Proof.
intros N M f g HM Hf Hg H.
rewrite N2Nat.inj_iter.
rewrite <- N2Nat.inj_iter.
assert (HM0 : (0 < M)%Z).
 eapply Z.lt_le_trans;[|apply Hf].
 apply Z.le_neq.
 split; auto with *.
 intros <-.
 rewrite <- Zodd_equiv in HM.
 contradiction.
assert (HM2 : 0 < M).
 rewrite inject_Z_D_Q.
 change 0 with (inject_Z 0).
 rewrite <- Zlt_Qlt.
 assumption.
cut (in_State M (N.iter N divsteps.step (divsteps.init f g)) (N.iter N (processDivstep M) state0)).
 intros [H0|H0];auto.
 set (p := (_,_)) in *.
 set (st' := N.iter N divsteps.step _) in *.
 unfold State_lookup in H0.
 case (ZMap.find _ _) eqn:Hfind.
  apply ZMap.find_2 in Hfind.
  apply ZMap.elements_1 in Hfind.
  apply ZMapProperties.P.elements_Empty in H.
  rewrite H in Hfind.
  apply SetoidList.InA_nil in Hfind.
  contradiction.
 apply in_convex_hull_singleton in H0.
 destruct H0 as [H0 _].
 simpl in *.
 apply inject_Z_injective.
 rewrite <- !inject_Z_D_Q.
 change (0%Z:Q) with 0 in *.
 apply Qmult_integral in H0.
 destruct H0 as [H0|H0]; auto.
 apply Qinv_lt_0_compat in HM2.
 rewrite H0 in HM2.
 discriminate.
clear H.
cut (in_State M (divsteps.init f g) state0).
 intros H.
 apply proj2 with (Z.Odd (divsteps.f (N.iter N divsteps.step (divsteps.init f g)))).
 elim N using N.induction;[intros x y ->| |];try tauto.
 intros n.
 intros H0.
 rewrite !N.iter_succ.
 split;[apply divsteps.odd_step;tauto|].
 apply in_State_step;auto with *; try tauto.
right.
unfold State_lookup; simpl.
pose (l := ((1-f/M),(0:D,0:D)%Z)
         ::(g / M,(1:D,1:D)%Z)
         ::((f - g)/M,(0:D,1:D)%Z)
         ::nil : list (Q*DD)).
exists l.
do 2 (try split).
* destruct H as [H|[H|[H|[]]]];inversion H.
  + apply -> Qle_minus_iff.
    apply Qle_shift_div_r; auto with *.
    ring_simplify.
    rewrite !inject_Z_D_Q.
    change 0 with (inject_Z 0).
    rewrite <- Zle_Qle.
    auto with *.
  + apply Qle_shift_div_l;auto with *.
    ring_simplify.
    rewrite inject_Z_D_Q.
    change 0 with (inject_Z 0).
    rewrite <- Zle_Qle.
    auto with *.
  + apply Qle_shift_div_l;auto with *.
    ring_simplify (0 * M).
    apply -> Qle_minus_iff.
    rewrite !inject_Z_D_Q.
    rewrite <- Zle_Qle.
    auto with *.
* destruct H as [H|[H|[H|[]]]];
    inversion H;
    apply DDSet.mem_spec;
    reflexivity.
* simpl; field.
  auto with *.
* simpl.
  change (0%Z:Q) with 0.
  change (1%Z:Q) with 1.
  split; simpl; try ring.
  field.
  auto with *.
Qed.

Corollary processDivstep_gcd : forall N M f g,
  Z.Odd f ->
  (f <= M)%Z -> (0 <= g <= f)%Z ->
  ZMap.Empty (N.iter N (processDivstep M) state0) ->
  Znumtheory.Zis_gcd f g
   (divsteps.f (N.iter N divsteps.step (divsteps.init f g))).
Proof.
intros N M f g HM Hf Hg H.
rewrite N2Nat.inj_iter.
apply (divsteps.gcd_spec _ (divsteps.init f g)); auto.
rewrite <- N2Nat.inj_iter.
eapply processDivstep_correct; eauto.
Qed.

Corollary processDivstep_inverse : forall N M f g,
  Z.Odd f ->
  (f <= M)%Z -> (0 <= g <= f)%Z ->
  Znumtheory.rel_prime f g ->
  ZMap.Empty (N.iter N (processDivstep M) state0) ->
  let st' := N.iter N divsteps.step (divsteps.init f g) in
  Z.abs (divsteps.f st') = 1%Z /\
  eqm f ((divsteps.d st' * divsteps.f st') * g) 1.
Proof.
intros N M f g Hodd HM Hgf Hprime Hempty st'.
unfold st'; clear st'.
rewrite N2Nat.inj_iter.
apply divsteps.modulo_spec; auto using divsteps.modulo_init.
rewrite <- N2Nat.inj_iter.
eapply processDivstep_correct; eauto.
Qed.

Corollary processDivstep_prime_inverse : forall N M f g,
  Z.Odd f ->
  (g < f <= M)%Z ->
  Znumtheory.prime f ->
  ZMap.Empty (N.iter N (processDivstep M) state0) ->
  let st' := N.iter N divsteps.step (divsteps.init f g) in
  (g = 0 -> divsteps.d st' = 0)%Z /\
  (0 < g -> Z.abs (divsteps.f st') = 1 /\
            eqm f ((divsteps.d st' * divsteps.f st') * g) 1)%Z.
Proof.
intros N M f g Hodd Hgf Hprime Hempty st'.
split.
* intros Hg.
  rewrite Hg in *.
  unfold st'.
  rewrite N2Nat.inj_iter, divsteps.d_zero_spec; rewrite Hg; reflexivity.
* intros Hg.
  eapply (processDivstep_inverse N M); eauto with *.
  apply Znumtheory.prime_rel_prime; auto.
  intros Hfg.
  apply Z.divide_pos_le in Hfg; auto with *.
Qed.


Require Export prosa.model.task.arrival.curves.
Require Export prosa.model.priority.classes.

(** The following definitions assume ideal uni-processor schedules.
    This restriction exists for historic reasons; the defined concepts
    could be generalized in future work. *)
Require Import prosa.analysis.facts.model.ideal_schedule.

(** * Request Bound Function (RBF) *)

(** We define the notion of a task's request-bound function (RBF), as well as
    the total request bound function of a set of tasks. *)

Section TaskWorkloadBoundedByArrivalCurves.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (** ... and any type of jobs associated with these tasks, where each task has
      a cost. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobCost Job}.

  (** Consider any ideal uni-processor schedule of these jobs... *)
  Variable sched : schedule (ideal.processor_state Job).

  (** ... and an FP policy that indicates a higher-or-equal priority
      relation. *)
  Context `{FP_policy Task}.

  (** Let [MaxArrivals] denote any function that takes a task and an interval length
      and returns the associated number of job arrivals of the task. *)
  Context `{MaxArrivals Task}.

  (** ** RBF of a Single Task *)

  (** In this section, we define a bound for the workload of a single task
      under uni-processor FP scheduling. *)
  Section SingleTask.

    (** Consider any task [tsk] that is to be scheduled in an interval of length delta. *)
    Variable tsk : Task.
    Variable delta : duration.

    (** We define the following workload bound for the task. *)
    Definition task_request_bound_function :=
      task_cost tsk * max_arrivals tsk delta.

  End SingleTask.

  (** ** Total RBF of Multiple Tasks *)

  (** In this section, we define a bound for the workload of multiple tasks. *)
  Section AllTasks.

    (** Consider a task set ts... *)
    Variable ts : list Task.

    (** ...and let [tsk] be any task in task set. *)
    Variable tsk : Task.

    (** Let delta be the length of the interval of interest. *)
    Variable delta : duration.

    (** Recall the definition of higher-or-equal-priority task and the per-task
        workload bound for FP scheduling. *)
    Let is_hep_task tsk_other := hep_task tsk_other tsk.
    Let is_other_hep_task tsk_other := hep_task tsk_other tsk && (tsk_other != tsk).

    (** Using the sum of individual workload bounds, we define the following
        bound for the total workload of tasks in any interval of length
        delta. *)
    Definition total_request_bound_function :=
      \sum_(tsk <- ts) task_request_bound_function tsk delta.

    (** Similarly, we define the following bound for the total workload of
        tasks of higher-or-equal priority (with respect to [tsk]) in any interval
        of length delta. *)
    Definition total_hep_request_bound_function_FP :=
      \sum_(tsk_other <- ts | is_hep_task tsk_other)
       task_request_bound_function tsk_other delta.

    (** We also define a bound for the total workload of higher-or-equal
        priority tasks other than [tsk] in any interval of length delta. *)
    Definition total_ohep_request_bound_function_FP :=
      \sum_(tsk_other <- ts | is_other_hep_task tsk_other)
       task_request_bound_function tsk_other delta.

  End AllTasks.

End TaskWorkloadBoundedByArrivalCurves.


Require Export RelationClasses.
Require Export SetoidClass.
Require Export Utils.
Require Import Program.

(** * Definition and properties *)

Class JoinSemiLattice (Lab: Type) :=
{ bot : Lab
; join : Lab -> Lab -> Lab
; flows : Lab -> Lab -> bool
; bot_flows : forall l, flows bot l  = true
; flows_refl : forall l, flows l l  = true
; flows_trans : forall l1 l2 l3,  flows l1 l2  = true -> flows l2 l3  = true -> flows l1 l3  = true
; flows_antisymm : forall l1 l2,  flows l1 l2  = true -> flows l2 l1 = true -> l1 = l2
; flows_join_right : forall l1 l2, flows l1 (join l1 l2) = true
; flows_join_left : forall l1 l2, flows l2 (join l1 l2) = true
; join_minimal : forall l1 l2 l, flows l1 l  = true -> flows l2 l  = true -> flows (join l1 l2) l = true
}.

Notation "l1 \_/ l2" := (join l1 l2) (at level 40) : type_scope.
Notation "l1 <: l2" := (flows l1 l2) (at level 50, no associativity) : type_scope.

(* Might be used at some point as the default for clearance
Parameter top : Lab.
Hypothesis flows_top : forall l, l <: top. *)

Hint Resolve
  flows_refl
  flows_trans
  flows_join_left
  flows_join_right
  flows_antisymm
  join_minimal: lat.

(** Immediate properties from the semi-lattice structure. *)
Section JoinSemiLattice_properties.

Context {T: Type}.

(* AAA: used to be assumption, not used *)
(* Lemma flows_join {L:JoinSemiLattice T} : forall l1 l2, l1 <: l2 = true <-> l1 \_/ l2 = l2. *)
(* Proof. *)
(*   intros. *)
(*   split. *)
(*   - intros H. *)
(*     apply flows_antisymm. *)
(*     + apply join_minimal; auto with lat. *)
(*     + apply flows_join_left. *)
(*   - intros H. *)
(*     rewrite <- H. *)
(*     auto with lat. *)
(* Qed. *)

Lemma join_1_rev {L: JoinSemiLattice T} : forall l1 l2 l,
  l1 \_/ l2 <: l = true -> l1 <: l = true.
Proof. eauto with lat. Qed.

Lemma join_2_rev {L: JoinSemiLattice T} : forall l1 l2 l,
  l1 \_/ l2 <: l  = true -> l2 <: l  = true.
Proof. eauto with lat. Qed.

Lemma join_1 {L: JoinSemiLattice T} : forall l l1 l2,
  l <: l1  = true -> l <: l1 \_/ l2  = true.
Proof. eauto with lat. Qed.

Lemma join_2 {L: JoinSemiLattice T}: forall l l1 l2,
  l <: l2 = true -> l <: l1 \_/ l2 = true.
Proof. eauto with lat. Qed.

Lemma join_bot_right {L: JoinSemiLattice T} : forall l,
  l \_/ bot = l.
Proof.
  eauto using bot_flows with lat.
Qed.

Lemma join_bot_left {L: JoinSemiLattice T} : forall l,
  bot \_/ l = l.
Proof. eauto using bot_flows with lat.
Qed.

Lemma not_flows_not_join_flows_left {L: JoinSemiLattice T}: forall l l1 l2,
  l1 <: l = false ->
  (l1 \_/ l2) <: l = false.
Proof.
  intros.
  destruct (flows (l1 \_/ l2) l) eqn:E.
  exploit join_1_rev; eauto.
  auto.
Qed.

Lemma not_flows_not_join_flows_right {L: JoinSemiLattice T}: forall l l1 l2,
  l2 <: l = false ->
  (l1 \_/ l2) <: l = false.
Proof.
  intros.
  destruct (flows (l1 \_/ l2) l) eqn:E.
  exploit join_2_rev; eauto.
  auto.
Qed.

End JoinSemiLattice_properties.

Hint Resolve
  join_1
  join_2
  bot_flows
  not_flows_not_join_flows_right
  not_flows_not_join_flows_left : lat.

(** * The two point lattice *)
Inductive Lab : Set :=
  | L : Lab
  | H : Lab.

#[refine]
Instance HL : JoinSemiLattice Lab :=
{  bot := L
;  join l1 l2 :=
     match l1, l2 with
       | H, _ => H
       | _, H => H
       | L, L => L
     end
; flows l1 l2 :=
    match l1, l2 with
      | L, _ => true
      | _, H => true
      | _, _ => false
    end
}.

Proof.
auto.
intros l; destruct l; auto.
intros l1 l2 l3; destruct l1, l2, l3; auto.
intros l1 l2; destruct l1, l2; auto.
intuition.
intuition.
intros l1 l2; destruct l1, l2; auto.
intros l1 l2; destruct l1, l2; auto.
intros l1 l2 l; destruct l1, l2, l; auto.
Defined.


Require Import vcfloat.VCFloat vcfloat.FPLib.
From mathcomp Require Import all_ssreflect ssralg  ssrnat all_algebra seq matrix .
From mathcomp.analysis Require Import Rstruct.
Require Import fma_is_finite dotprod_model.
Require Import fma_real_func_model fma_floating_point_model.
Require Import inf_norm_properties common.
Set Bullet Behavior "Strict Subproofs".

Require Import fma_jacobi_forward_error.

Section WITH_NANS.

Context {NANS: Nans}.

(** Computable definition of rho in reals **)
Definition rho_def_alt  {t: type} {n:nat} (A: 'M[ftype t]_n.+1) (b: 'cV[ftype t]_n.+1) :=
  let A_real := FT2R_mat A in
  let b_real := FT2R_mat b in
  let A1_inv_real := FT2R_mat (A1_inv_J A) in
  let A2_real := FT2R_mat (A2_J A) in
  let R := (((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) *
              matrix_inf_norm (A2_real))%Re in
  let delta := default_rel t in
  ((((1 + g t n.+1) * (1 + delta) *
                  g t n.+1 + delta * (1 + g t n.+1) +
                  g t n.+1) * (1 + delta) + delta) * R +
                (((1 + g t n.+1) * (1 + delta) *
                  g t n.+1 + delta * (1 + g t n.+1) +
                  g t n.+1) * default_abs t +
                 default_abs t) *
                matrix_inf_norm (A2_real) + R)%Re.

(** Computable definition of d_mag in reals **)
Definition d_mag_def_alt {t: type} {n:nat} (A: 'M[ftype t]_n.+1)
  (b: 'cV[ftype t]_n.+1) :=
  let A_real := FT2R_mat A in
  let b_real := FT2R_mat b in
  let A1_inv_real := FT2R_mat (A1_inv_J A) in
  let A2_real := FT2R_mat (A2_J A) in
  let R := (((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) *
            matrix_inf_norm (A2_real))%Re in
  let delta := default_rel t in
  ((g t n.+1 * (1 + delta) + delta) *
                    (( ((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) *
                      (1 + delta) + default_abs t) *
                     vec_inf_norm b_real) +
                    (1 + g t n.+1) * g1 t n.+1 (n.+1 - 1) *
                    (1 + delta) *
                    (((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) *
                     (1 + delta) + default_abs t) +
                    g1 t n.+1 (n.+1 - 1) +
                    (((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) * delta +
                     default_abs t) * vec_inf_norm b_real +
                    ((((1 + g t n.+1) * (1 + delta) *
                       g t n.+1 + delta * (1 + g t n.+1) +
                       g t n.+1) * (1 + delta) + delta) * R +
                     (((1 + g t n.+1) * (1 + delta) *
                       g t n.+1 + delta * (1 + g t n.+1) +
                       g t n.+1) * default_abs t +
                      default_abs t) *
                     matrix_inf_norm (A2_real)) *
                     ( ((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) *
                       vec_inf_norm b_real * (/ (1 - R))))%Re.

Definition A1_J {ty} {n:nat} (A: 'M[ftype ty]_n.+1) : 'cV[ftype ty]_n.+1 :=
  \col_i (A i i).

Definition k_min {NANS: Nans} {t: type} {n:nat} (A : 'M[ftype t]_n.+1)
  (b : 'cV[ftype t]_n.+1) (acc : ftype t) :=
  let rho := rho_def A b in
  let d_mag := d_mag_def A b in
  let x0 := \col_(j < n.+1) (Zconst t 0) in
  let A_real := FT2R_mat A in
  let b_real := FT2R_mat b in
  let x:= mulmx (A_real^-1) b_real in
  let e_0 := @f_error _ _ _ 0 b x0 x A in
  let Gamma := FT2R (BMULT acc acc) in
  let delta := default_rel t in
  Z.to_nat (Zceil (Rlog (1 / rho)%Re
             ((e_0 - d_mag / (1 - rho)) * (1 + rho) /
                ((sqrt
                    ((Gamma - g1 t n.+1 (n.+1 - 1)%coq_nat) /
                     INR n.+1 / (1 + g t n.+1)) -
                  g1 t n.+1 (n.+1 - 1)%coq_nat) /
                 (1 + g t n.+1) /
                 vec_inf_norm (FT2R_mat (A1_J A)) /
                 (1 + delta) -
                 2 * d_mag / (1 - rho)))%Re)).

Definition jacobi_preconditions_math {t: type} {n:nat}
  (A: 'M[ftype t]_n.+1) (b: 'cV[ftype t]_n.+1) (accuracy: ftype t) (k: nat) : Prop :=
  (* some property of A,b,accuracy holds such that
    jacobi_n will indeed converge within k iterations to this accuracy,
   without ever overflowing *)
  let A_real := FT2R_mat A in
  let b_real := FT2R_mat b in
  let x:= mulmx (A_real^-1) b_real in
  let rho := rho_def A b in
  let d_mag := d_mag_def A b in
  let x0 := \col_(j < n.+1) (Zconst t 0) in
  (** Finiteness of A **)
  (forall i j, finite (A i j)) /\
  (** constant for the contraction mapping **)
  (rho < 1)%Re /\
  (** Invertibility of A **)
  A_real \in unitmx /\
  (** Finiteness of the inverse of diagonal elements of A **)
  (forall i : 'I_n.+1, finite (BDIV (Zconst t 1) (A i i))) /\
(** Constraint on Gamma **)
  (FT2R (BMULT accuracy accuracy) >
     g1 t n.+1 (n.+1 - 1)%coq_nat +
     INR n.+1 * (1 + g t n.+1) *
     (g1 t n.+1 (n.+1 - 1)%coq_nat +
      2 * (1 + g t n.+1) * (1 + default_rel t) *
      vec_inf_norm (FT2R_mat (A1_J A)) *
      d_mag_def A b * / (1 - rho_def A b))²)%Re /\
  (** Gamma is finite **)
  finite (BMULT accuracy accuracy) /\
  (** constraint on k **)
  ((k_min A b accuracy < k)%coq_nat /\ (0 < k)%coq_nat) /\
  (** lower bound on the initial error **)
  (0 < f_error 0 b x0 x A - d_mag / (1 - rho))%Re /\
  (** finiteness of x0 **)
  (forall i : 'I_n.+1, finite (x0 i ord0)) /\
  (** finitenes of A1^{-} **)
  (forall i, finite (A1_inv_J A i ord0)) /\
  (** finiteness of A2 **)
  (forall i j, finite (A2_J A i j)) /\
  (** finitenes of b **)
  (forall i, finite (b i ord0)) /\
  (** constraint on the dimension **)
  @size_constraint t n /\
  (** constraint on bounds for input **)
  input_bound A x0 b.

Definition k_min_alt {NANS: Nans} {t: type} {n:nat} (A : 'M[ftype t]_n.+1)
  (b : 'cV[ftype t]_n.+1) (acc : ftype t) :=
  let rho := rho_def_alt A b in
  let d_mag := d_mag_def_alt A b in
  let x0 := \col_(j < n.+1) (Zconst t 0) in
  let A_real := FT2R_mat A in
  let b_real := FT2R_mat b in
  let A1_inv_real := FT2R_mat (A1_inv_J A) in
  let A2_real := FT2R_mat (A2_J A) in
  let R_def :=  (((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) *
                      matrix_inf_norm (A2_real))%Re in
  let e_0 := (vec_inf_norm (FT2R_mat x0) +
              (((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t))
                  * vec_inf_norm (b_real)) / (1 - R_def))%Re in
  let Gamma := FT2R (BMULT acc acc) in
  let delta := default_rel t in
  Z.to_nat (Zceil (Rlog (1 / rho)%Re
             ((e_0 - 0) * (1 + rho) /
                ((sqrt
                    ((Gamma - g1 t n.+1 (n.+1 - 1)%coq_nat) /
                     INR n.+1 / (1 + g t n.+1)) -
                  g1 t n.+1 (n.+1 - 1)%coq_nat) /
                 (1 + g t n.+1) /
                 vec_inf_norm (FT2R_mat (A1_J A)) /
                 (1 + delta) -
                 2 * d_mag / (1 - rho)))%Re)).

Definition input_bound_Rcompute {t} {n:nat}
  (A: 'M[ftype t]_n.+1) (x0 b: 'cV[ftype t]_n.+1):=
  let A_real := FT2R_mat A in
  let b_real := FT2R_mat b in
  let A1_inv_real := FT2R_mat (A1_inv_J A) in
  let A2_real := FT2R_mat (A2_J A) in
  let R_def :=  (((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) *
                      matrix_inf_norm (A2_real))%Re in
  let x_bound :=
  ((((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) *
        vec_inf_norm (b_real)) / (1 - R_def))%Re in
  let rho := rho_def_alt A b in
  let d_mag := d_mag_def_alt A b in
  let e_0 := (vec_inf_norm (FT2R_mat x0) +
              (((vec_inf_norm (FT2R_mat (A1_inv_J A)) + default_abs t) / (1 - default_rel t)) *
                       vec_inf_norm (b_real)) / (1 - R_def))%Re in
  (forall i,
    (Rabs (FT2R (A i i)) *
     (1 * (1 + rho) *
      (e_0 - 0) + 2 * d_mag * / (1 - rho) + 2 * x_bound ) <
     (sqrt (fun_bnd t n.+1) - default_abs t) /
     (1 + default_rel t) /
     (1 + default_rel t))%Re) /\
  (x_bound +
       1 * e_0 + 1 / (1 - rho) *
       d_mag < sqrt (fun_bnd t n.+1))%Re /\
  (forall i j,
      (Rabs (FT2R (A2_J A i j )) <
        sqrt (fun_bnd t n.+1))%Re) /\
  (forall i,
     (Rabs (FT2R (b i ord0)) +
     (1 + g t n.+1) *
     (( x_bound + 1 * e_0 + 1 / (1 - rho) * d_mag) *
      (\sum_j
          Rabs (FT2R (A2_J A i j)))) +
     g1 t n.+1 (n.+1 - 1)%coq_nat <
     (bpow Zaux.radix2 (femax t) -
      default_abs t) / (1 + default_rel t))%Re) /\
  (forall i,
    (Rabs (FT2R (A1_inv_J A (inord i) ord0)) *
     (Rabs (FT2R (b (inord i) ord0)) +
      (1 + g t n.+1) *
      (( x_bound + 1 * e_0 + 1 / (1 - rho) * d_mag) *
       (\sum_j
           Rabs (FT2R (A2_J A (inord i) j)))) +
      g1 t n.+1 (n.+1 - 1)%coq_nat) <
     (bpow Zaux.radix2 (femax t) -
      default_abs t) / (1 + default_rel t) /
     (1 + default_rel t))%Re) /\
  (1 * (1 + rho) *
     (e_0 - 0) + 2 * d_mag * / (1 - rho) +
     2 * x_bound <
     (bpow Zaux.radix2 (femax t) -
      default_abs t) / (1 + default_rel t))%Re.

Definition strict_diagonal_dominance {t} {n:nat}
  (A: 'M[ftype t]_n.+1):=
    forall i,
     (Rabs (FT2R_mat A i i ) >
      \sum_(j < n.+1 | j != i) Rabs (FT2R_mat A i j))%Re.

Definition input_bound_at_N_0_Rcompute {t: type} {n:nat}
  (A: 'M[ftype t]_n.+1) (b: 'cV[ftype t]_n.+1) :=
  (forall i j,
    (Rabs (FT2R (A2_J A i j)) <
          sqrt (fun_bnd t n.+1))%Re) /\
  (forall i,
      (Rabs (FT2R (b i ord0)) <
         (bpow Zaux.radix2 (femax t) -
          default_abs t) /
         (1 + default_rel t))%Re) /\
  (forall i,
    (Rabs (FT2R (A1_inv_J A i ord0)) *
       Rabs (FT2R (b i ord0)) <
       (bpow Zaux.radix2 (femax t) -
        default_abs t) /
       (1 + default_rel t))%Re) /\
  (forall i,
      (Rabs (FT2R (A1_inv_J A i ord0)) *
       Rabs (FT2R (b i ord0)) *
       (1 + default_rel t) + default_abs t <
       (bpow Zaux.radix2 (femax t) - default_abs t) /
       (1 + default_rel t))%Re) /\
  (forall i,
      (Rabs (FT2R (A i i)) *
       (Rabs
          (FT2R
             (A1_inv_J A i ord0)) *
        Rabs (FT2R (b i ord0)) *
        (1 + default_rel t) +
        default_abs t) <
       (sqrt (fun_bnd t n.+1) -
        default_abs t) /
       (1 + default_rel t))%Re).

(** Rcompute **)
Definition jacobi_preconditions_Rcompute {t: type} {n:nat}
  (A: 'M[ftype t]_n.+1) (b: 'cV[ftype t]_n.+1) (accuracy: ftype t) (k: nat) : Prop :=
  (* some property of A,b,accuracy holds such that
    jacobi_n will indeed converge within k iterations to this accuracy,
   without ever overflowing *)
  let A_real := FT2R_mat A in
  let b_real := FT2R_mat b in
  let rho_hat := rho_def_alt A b in
  let d_mag := d_mag_def_alt A b in
  let x0 := \col_(j < n.+1) (Zconst t 0) in
  (** Finiteness of A **)
  (forall i j, finite (A i j)) /\
  (** contraction constant **)
  ( rho_hat < 1)%Re /\
  (** diagonal dominance of A **)
  strict_diagonal_dominance A /\
  (** Finiteness of the inverse of diagonal elements of A **)
  (forall i : 'I_n.+1,
    finite (BDIV (Zconst t 1) (A i i))) /\
  (** Constraint on Gamma **)
  ((FT2R (BMULT accuracy accuracy) >
     g1 t n.+1 (n.+1 - 1)%coq_nat +
     INR n.+1 * (1 + g t n.+1) *
     (g1 t n.+1 (n.+1 - 1)%coq_nat +
      2 * (1 + g t n.+1) * (1 + default_rel t) *
      vec_inf_norm (FT2R_mat (A1_J A)) *
      d_mag * / (1 - rho_hat))²)%Re /\
     (INR n.+1 *
       (vec_inf_norm (FT2R_mat (A1_J A)) *
        ((vec_inf_norm (FT2R_mat (A1_inv_J A)) *
          ((matrix_inf_norm (FT2R_mat A) *
            (d_mag_def_alt A b /
             (1 - rho_def_alt A b)) +
            g1 t n.+1 (n.+1 - 1)) *
           (1 + default_rel t)) *
          (1 + g t n.+1) + g1 t n.+1 (n.+1 - 1)) *
         (1 + default_rel t)) * (1 + g t n.+1) +
        g1 t n.+1 (n.+1 - 1)%coq_nat)² *
       (1 + g t n.+1) +
       g1 t n.+1
         (n.+1 - 1)%coq_nat < FT2R (BMULT accuracy accuracy))%Re) /\
  (** Gamma is finite **)
  finite (BMULT accuracy accuracy) /\
  (** constraint on k **)
  (k_min_alt A b accuracy < k)%coq_nat /\
  (** finiteness of x0 **)
  (forall i : 'I_n.+1, finite (x0 i ord0)) /\
  (** finiteness of A2 **)
  (forall i j, finite (A2_J A i j)) /\
  (** finitenes of b **)
  (forall i, finite (b i ord0)) /\
  (** constraint on the dimension **)
  @size_constraint t n /\
  (** constraint on bounds for input **)
  input_bound_Rcompute A x0 b /\ input_bound_at_N_0_Rcompute A b .

End WITH_NANS.


Require FSets.
Require FSetFacts.
Require RelationClasses.
Require FSetAddEq.
Require FoldEqual.
Require Import Morphisms.
Require Import OrderedTypeEquiv.

Module Make (F:FSetInterface.S).

  Module Facts  := FSetFacts.Facts F.
  Module AddEQ := FSetAddEq.Make F.
  Module Props := AddEQ.Properties.
  Module Dep := FSetBridge.DepOfNodep F.
  Module FEq := FoldEqual.Make F.
  Module FEquiv := OT_Equiv F.
  Module EEquiv := OT_Equiv F.E.

  Section fold_order.

    Variable A:Type.
    Variable eqA : Relation_Definitions.relation A.
    Variable A_EQ: RelationClasses.Equivalence eqA.
    Variable leA: Relation_Definitions.relation A.
    Variable A_PreOrd: RelationClasses.PreOrder leA.
    Variable A_PartOrd: RelationClasses.PartialOrder eqA leA.

    Definition F_EQ := FEquiv.Equiv.
    Definition E_EQ := EEquiv.Equiv.

    (* the reason we claim foldEqual f f and f' f' is because we need
      f and f' to be respectful morphisms over set and A.  At least, I think so,
      and I want to leverage current libraries, even though they are a bit outdated. *)

    Require SetoidList.

    Definition subset_leA_comm f f' := forall a a' e e', leA a a' -> F.E.eq e e' -> leA (f e a) (f' e' a').

    Definition leA_incremental (f: F.E.t -> A -> A) := forall a e, leA a (f e a).

    Definition foldPartialOrder (f f': F.E.t -> A -> A) :=
      Proper (F.E.eq ==> eqA ==> eqA) f  /\ Proper (F.E.eq ==> eqA ==> eqA) f' /\
     SetoidList.transpose eqA f' /\ subset_leA_comm f f'.

      Theorem Morphism_is_compat_op: forall (C D:Type)
        (eqC : Relation_Definitions.relation C)
        (eqD : Relation_Definitions.relation D)
        (C_EQ: RelationClasses.Equivalence eqC)
        (D_EQ: RelationClasses.Equivalence eqD)
        (f: C -> D -> D),
       Proper (eqC ==> eqD ==> eqD) f -> SetoidList.compat_op eqC eqD f.
      Proof.
      unfold SetoidList.compat_op;      intros.
      assumption.
      Qed.

      Implicit Arguments Morphism_is_compat_op [C D eqC eqD f].

    Theorem fold_foldPartialOrder : forall (f f': F.E.t -> A -> A), foldPartialOrder f f' ->
      forall (acc acc': A), leA acc acc' -> forall (s s' : F.t), F.Equal s s' ->
      leA (F.fold f s acc) (F.fold f' s' acc').
    Proof.
      intros f f' [Hfm [Hfm' [Htr Hco]]] acc acc' Hle s.
      eapply Props.fold_rec_bis with (i:=acc) (s:=s).
      (* compat *)
      intros.
      eapply H0; auto.
      setoid_rewrite H; auto.
      (* base *)
      intros.
      eapply Props.fold_rec_nodep; intros; eauto.
      eapply F.eq_sym in H.
      eapply Props.empty_is_empty_2 in H.
      eapply H in H0.
      contradiction.
      (* step *)
      intros x a s0 Hin Hnin IH s' Heq.
      assert (F.In x s') as Hin'; [setoid_rewrite <- Heq; eapply F.add_1; eauto|].
      generalize (@Props.remove_fold_1 A eqA A_EQ f'
        (Morphism_is_compat_op E_EQ A_EQ Hfm') Htr acc' _ _ Hin'); intros Hfeq.
      setoid_symmetry in Hfeq.
      eapply A_PartOrd in Hfeq.
      repeat progress (red in Hfeq; simpl in Hfeq; try unfold Basics.flip in Hfeq).
      destruct Hfeq as [HleA HleA'].
      destruct A_PreOrd as [A_refl A_trans].
      eapply A_trans;[|eapply HleA'].
      eapply Hco; eauto.
      eapply IH.
      setoid_rewrite <- Heq.
      rewrite Props.remove_add; [apply F.eq_refl|eauto].
    Qed.

  (* The above holds if s [<=] s', provided f is incremental.  The following convenince theorem handles
     most of the base case *)

    Theorem fold_partialOrder_incremental : forall (f : F.E.t -> A -> A), leA_incremental f ->
      forall (acc acc': A), leA acc acc' -> forall (s : F.t), leA acc (F.fold f s acc').
    Proof.
      intros.
      apply Props.fold_rec with
        (f:=f) (i:=acc') (s:=s); intros; auto.
      unfold leA_incremental in *.
      destruct A_PreOrd as [A_refl A_trans].
      eapply A_trans;[apply H4|apply H].
    Qed.

    Theorem fold_foldpartialOrder_incremental: forall (f f': F.E.t -> A -> A), foldPartialOrder f f' ->
      leA_incremental f' -> forall (acc acc': A), leA acc acc' -> forall (s s' : F.t), F.Subset s s' ->
      leA (F.fold f s acc) (F.fold f' s' acc').
    Proof.
      intros f f' Hpo Hinc acc acc' Hle s s' Hsub.
      generalize Hpo; intros [Hfm [Hfm' [Htr Hco]]].
      destruct A_PreOrd as [leA_refl leA_trans].
      eapply leA_trans.
      (* by Props.inter_subset Props.inter_sym and Hsub we know that (F.inter s' s) [=] s,
         we may therefore apply fold_foldPartialOrder. *)
      eapply fold_foldPartialOrder;
        [apply Hpo | apply Hle|
          eapply F.eq_trans;
            [eapply F.eq_sym; eapply Props.inter_subset_equal; apply Hsub | eapply Props.inter_sym]].
     (* this is now the correct form to continue *)
      generalize (Props.fold_diff_inter A_EQ (Morphism_is_compat_op E_EQ A_EQ Hfm') Htr acc' s' s); intros Hfeq.
      eapply A_PartOrd in Hfeq.
      repeat progress (red in Hfeq; simpl in Hfeq; try unfold Basics.flip in Hfeq).
      destruct Hfeq as [HleA HleA'].
      eapply leA_trans; [| eapply HleA].
      eapply fold_partialOrder_incremental; auto.
   Qed.
  End fold_order.

End Make.


Require Import List Relation_Operators.

Definition Symbol : Set := nat * option nat.

(* rules ab -> cd *)
Definition Srs := list ((Symbol * Symbol) * (Symbol * Symbol)).

Inductive step (srs: Srs) : list Symbol -> list Symbol -> Prop :=
  | step_intro {u v a b c d} :
      In ((a, b), (c, d)) srs -> step srs (u ++ a :: b :: v) (u ++ c :: d :: v).

Definition multi_step (srs: Srs) : list Symbol -> list Symbol -> Prop :=
  clos_refl_trans (list Symbol) (step srs).

(* given a Srs and Symbols a b, is there a length n such that a^(1+n) ->> b^(1+n) *)
Definition SR2ab : Srs * Symbol * Symbol -> Prop :=
  fun '(srs, a, b) => exists n, multi_step srs (repeat a (1+n)) (repeat b (1+n)).


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint eqn (m n : natural) : bool :=
  match m , n with
  | Zero , Zero => true
  | Succ m' , Succ n' => eqn m' n'
  | _, _ => false
  end.

Definition leq (m n : natural) : bool :=
  orb (eqn m n) (less m n).

Fixpoint insort (insort_arg0 : natural) (insort_arg1 : lst) : lst
           := match insort_arg0, insort_arg1 with
              | i, Nil => Cons i Nil
              | i, Cons x y => if less i x then Cons i (Cons x y) else Cons x (insort i y)
              end.

Fixpoint sorted (sorted_arg0 : lst) : bool
           := match sorted_arg0 with
              | Nil => true
              | Cons x l =>
                let s := sorted l in
                match l with
                | Nil => true
                | Cons y _ => andb s (leq x y)
                end
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort x (sort y)
              end.

(*
Lemma lem2: forall m n, less m n = false -> leq n m = true.
(* Proof.
  induction m.
  - intros. unfold leq. unfold orb. remember (eqn n (Succ m)).
    destruct b.
    * reflexivity.
    * destruct n.
      + simpl. simpl in H.  *)
Admitted.

Lemma lem3: forall n0 n l, sorted (Cons n l) = true -> leq n0 n = true ->
    sorted (Cons n0 (Cons n l)) = true.
Admitted.
*)

Lemma lem: forall n l, sorted l = true -> sorted (insort n l) = true.
(* Proof.
 intros. induction l.
  - simpl. remember (less n n0) as lt. destruct lt.
    * remember (Cons n0 l) as l0. simpl. rewrite Heql0 in H. rewrite Heql0.
      rewrite H. simpl. unfold leq. rewrite <- Heqlt. destruct (eqn n n0).
      + auto.
      + auto.
    * assert (sorted l = true).
      + destruct l.
        ** simpl in H. unfold andb in H. remember (match l with | Cons y _ => if sorted l then leq n1 y else false
      | Nil => true end). destruct b.
          *** simpl. unfold andb. rewrite <- Heqb. reflexivity.
          *** inversion H.
        ** reflexivity.
      + remember (insort n l) as li. destruct li.
lfind.  apply IHl.  assumption.
Admitted.

Theorem theorem0 : forall (x : lst), eq (sorted (sort x)) true.
Proof.
induction x.
  - simpl. apply lem. apply IHx.
  - reflexivity.
Qed.

From QuickChick Require Import QuickChick.

Lemma synth: forall l n,  sorted (insort n l) = true.
(* Lemma synth:  sort ((Cons (Succ Zero) (Cons Zero Nil))). *)
Admitted.

Derive Show for natural.

Derive Arbitrary for natural.

Instance Dec_Eq_natural : Dec_Eq natural.

Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Compute (sorted (Cons (Succ Zero) (Cons Zero Nil))).

QuickChick synth.


(************************************************************************)
(* This file introduces the decidable equality type class, and associated results *)
(************************************************************************)

Set Polymorphic Inductive Cumulativity.

Set Universe Polymorphism.
Unset Universe Minimization ToSet.

Require Import HoTT CanonicalEq UnivalentParametricity.theories.Transportable UnivalentParametricity.theories.UR UnivalentParametricity.theories.FP Coq.Program.Tactics.

(* HSet and Hedberg *)

Class DecidableEq A := { dec_paths : forall a b : A, (a = b) + (a = b -> False)}.

(**
Hedberg theorem is a standard theorem of HoTT: it states that if a
type [A] has decidable equality, then it is a hSet, i.e. its equality
is proof-irrelevant. See the proof at [https://github.com/HoTT] in
[HoTT/theories/Basics/Decidable.v] *)

Instance Hedberg A `{DecidableEq A} : HSet A.
Proof.
  econstructor.
  intros a b.
  assert (lemma: forall p: a = b,
             match dec_paths a a, dec_paths a b with
             | inl r, inl s => p = r^ @ s
             | _, _ => False
             end).
  {
    destruct p.
    destruct (dec_paths a a) as [pr | f].
    - apply inverse_left_inverse.
    - exact (f eq_refl).
  }
  intros p q.
  assert (p_given_by_dec := lemma p).
  assert (q_given_by_dec := lemma q).
  destruct (dec_paths a b); try contradiction.
  destruct (dec_paths a a); try contradiction.
  apply (p_given_by_dec @ q_given_by_dec ^).
Defined.

Instance IsHSet_compare : HSet comparison.
  apply Hedberg.
  econstructor. destruct a, b; try solve [now left]; solve [now right].
Defined.

Definition DecidableEq_equiv A B (eB : A ≃ B) `{DecidableEq A} : DecidableEq B.
Proof.
  constructor. pose (eB' := Equiv_inverse eB).
  intros x y. destruct (dec_paths (↑ x) (↑ y)).
  - left. apply (@isequiv_ap _ _ eB'). exact e.
  - right. intro e. apply f. exact (ap _ e).
Defined.

Instance DecidableEq_Sigma A (B : A -> Type) `{DecidableEq A} `{forall a, DecidableEq (B a)} :
  DecidableEq {a : A & B a}.
Proof.
  constructor. intros [a b] [a' b' ].
  destruct (dec_paths a a').
  - destruct e. destruct (dec_paths b b').
    + apply inl. apply path_sigma_uncurried. exists eq_refl. exact e.
    + apply inr; intro Hf; apply f. pose (Hf..2).
      assert (Hf..1 = eq_refl). apply is_hset. rewrite X in e. exact e.
  - apply inr; intro Hf; apply f. exact (Hf..1).
Defined.

Instance Transportable_decidable {A} (P:A -> Type) `{DecidableEq A} : Transportable P.
Proof.
  unshelve econstructor.
  - intros x y e. destruct (dec_paths x y) as [e0 | n0].
    destruct e0. apply Equiv_id.
    destruct (n0 e).
  - intro x. cbn. destruct (dec_paths x x); cbn.
    assert (e = eq_refl) by (eapply is_hset).
    rewrite X. reflexivity.
    destruct (f eq_refl).
Defined.

Definition Canonical_eq_decidable_ A `{DecidableEq A} :
  forall x y:A , x = y -> x = y :=
  fun x y e => match (dec_paths x y) with
               | inl e0 => e0
               | inr n => match (n e) with end
               end.

Instance Canonical_eq_decidable A `{DecidableEq A} : Canonical_eq A.
Proof.
  refine {| can_eq := @Canonical_eq_decidable_ A H |}.
  - unfold Canonical_eq_decidable_. intro x. cbn. destruct (dec_paths x x); cbn.
    assert (e = eq_refl) by (eapply is_hset).
    rewrite X. reflexivity.
    destruct (f eq_refl).
Defined.

(*! Establishing FP for Type with a decidable equality !*)

Definition URType_Refl_decidable A (dec:DecidableEq A)
  : A ⋈ A :=
  URType_Refl_can A (@Canonical_eq_decidable  _ dec).

Structure DType@{i} :=
  { carrier :> Type@{i} ;
    dec : DecidableEq@{i} carrier }.

Instance DTypeDec (A : DType) : DecidableEq A.(carrier) := A.(dec).

Instance UR_DType_def@{i j} : UR@{j j j} DType@{i} DType@{i} :=
  Build_UR@{j j j} _ _ (fun A B => UR_Type@{i i i} A.(carrier) B.(carrier)).

Program Definition URDType_Refl : URRefl DType DType (Equiv_id _) _ :=
   {| ur_refl_ := fun a : DType => URType_Refl_decidable a.(carrier) (DTypeDec a) |}.

Definition path_DType (A B : DType)
           (pq : {p : A.(carrier) = B.(carrier) & A.(dec) = p^ # B.(dec)})
: A = B.
Proof.
  destruct pq as [p q]. destruct A, B. simpl in *. destruct p.
  simpl in q; destruct q; reflexivity.
Defined.

Definition path_DecidableEq A (dec dec': DecidableEq A) : dec.(@dec_paths A) = dec'.(@dec_paths A) -> dec = dec'.
  destruct dec, dec'. cbn. destruct 1. reflexivity.
Defined.

Definition path_sum {A B : Type} (z z' : A + B)
           (pq : match z, z' with
                   | inl z0, inl z'0 => z0 = z'0
                   | inr z0, inr z'0 => z0 = z'0
                   | _, _ => False
                 end)
: z = z'.
  destruct z, z'.
  all:try apply ap, pq.
  all:elim pq.
Defined.

Definition dec_hprop A : IsIrr (DecidableEq A).
  intros decA decA'. apply path_DecidableEq. apply funext. intro a. apply funext. intro a'.
  apply path_sum. destruct (dec_paths a a'); destruct (dec_paths a a'); auto.
  apply is_hset. apply funext. intro e. destruct (f e).
Defined.

Definition path_DType_simple A B (decA : DecidableEq A) (decB : DecidableEq B) (e : A = B) :
  {| carrier := A; dec := decA |} = {| carrier := B; dec := decB |}.
  apply path_DType. exists e. destruct e. apply dec_hprop.
Defined.

Definition dec_hprop_hprop A (decA : DecidableEq A) :
  dec_hprop A decA decA = eq_refl.
  apply IsIrr_IsHprop'. apply dec_hprop.
Defined.

Definition path_DType_simple_refl A (decA : DecidableEq A) :
  path_DType_simple A A decA decA eq_refl = eq_refl.
Proof.
  unfold path_DType_simple. cbn. rewrite dec_hprop_hprop.
  reflexivity.
Defined.

Definition path_DType_proj {A B : DType} :
  A = B -> carrier A = carrier B.
  destruct 1. reflexivity.
Defined.

Definition path_DType_eq (A B:DType)
           (e : @eq DType A B) :
  match A,B return forall (e:A = B), Type with (Build_DType A decA),(Build_DType B decB)
=> fun e =>
     path_DType_simple A B decA decB (path_DType_proj e) = e end e.
  destruct e, A. cbn. rewrite dec_hprop_hprop. reflexivity.
Defined.

Definition path_DType_eq' A B (decA : DecidableEq A) (decB : DecidableEq B)
           (e : {| carrier := A; dec := decA |} = {| carrier := B; dec := decB |}) :
  path_DType_simple _ _ _ _ (path_DType_proj e) = e := path_DType_eq _ _ e.

Opaque path_DType_simple.

Definition can_eq_eq_dec {A} {decA : DecidableEq A} (e : Canonical_eq A) : e.(can_eq) = Canonical_eq_decidable_ A.
Proof.
  apply funext; intros x. apply funext; intros y. apply funext; intro E.
  apply is_hset.
Defined.

Definition Canonical_contr_dec A (ecanA : Canonical_eq A) (e : DecidableEq A) :
  ecanA = Canonical_eq_decidable A.
Proof.
  unshelve eapply Canonical_eq_eq. cbn.
  apply can_eq_eq_dec. apply IsIrr_IsHprop'.
  repeat (apply IsIrr_forall; intro).
  intros E E'. apply is_hset.
Defined.

Instance URDType_IsEq : URIsEq DType DType (Equiv_id _) _ URDType_Refl.
Proof.
  intros A B. destruct A as [A decA], B as [B decB]. cbn.
  unshelve refine (isequiv_adjointify _ _ _ _).
  - intros e. cbn in *. apply path_DType_simple. apply univalence. typeclasses eauto.
  - intros e.  cbn.
    refine (transport_eq (fun (E: {| carrier := A; dec := decA |} = {| carrier := B; dec := decB |}) => path_DType_simple A B decA decB
    (e_inv (eq_to_equiv A B)
           (equiv (transport_eq (fun X : DType => A ⋈ X) E (URType_Refl_decidable A decA)))) = E)
                         (path_DType_eq _ _ e) _).
    set (path_DType_proj e). cbn in *. apply ap. destruct e0. clear e.
    assert (decA = decB). apply dec_hprop. destruct X. cbn.
    rewrite path_DType_simple_refl.
    exact (@e_sect _ _ _ (univalence _ _) eq_refl).
  - intro e; cbn.
    destruct e as [e eur ecoh ecanA ecanB].
    revert eur ecoh ecanA ecanB. rewrite <- (@e_retr _ _ _ (univalence _ _) _).
    set (eeq := (e_inv _ e)).
    clearbody eeq;clear e.
    destruct eeq. intros eur ecoh ecanA ecanB.
    simpl.
    destruct eur as [eur].
    destruct ecoh as [ecoh].
    simpl in *.
    change (Equiv_id A) with (eq_to_equiv A A eq_refl).
    rewrite (@e_sect _ _ _ (univalence _ _) _). simpl.
    assert (decA = decB). apply dec_hprop. destruct X. cbn.
    rewrite path_DType_simple_refl. cbn.
    unfold URType_Refl_decidable, URType_Refl_can, UR_gen. cbn.
    rewrite <- (@e_retr _ _ (e_fun (equiv_relation_equiv_fun _ _ _ _)) _ ecoh).
    set (p := (e_inv _ ecoh)).
    clearbody p. clear ecoh.
    destruct p. cbn.
    assert (ecanA = Canonical_eq_decidable A) by apply Canonical_contr_dec.
    assert (ecanB = Canonical_eq_decidable A) by apply Canonical_contr_dec.
    destruct X, X0.
    reflexivity.
Defined.

Instance Canonical_eq_DType : Canonical_eq DType := Canonical_eq_gen _.

Instance FP_DType : DType ⋈ DType.
Proof.
  econstructor; try typeclasses eauto.
Defined.

Instance Transportable_DType : Transportable (fun A:DType => A) :=
  Transportable_default _.

(* nat *)

Instance DecidableEq_eq_nat : DecidableEq@{Type} nat.
constructor. intros x y; revert y.
induction x.
- destruct y.
 + left ;reflexivity.
 + right; intro H; inversion H.
- induction y.
  + right; intro H; inversion H.
  + case (IHx y). intro H. left. exact (ap S H).
    intro H; right. intro e. inversion e. apply (H (logic_eq_is_eq H1)).
Defined.

Canonical Structure Dnat : DType := Build_DType nat _.

Instance DecidableEq_eq_datatypes_nat : DecidableEq Datatypes.nat.
constructor. intros x y; revert y.
induction x.
- destruct y.
 + left ;reflexivity.
 + right; intro H; inversion H.
- induction y.
  + right; intro H; inversion H.
  + case (IHx y). intro H. left. exact (ap Datatypes.S H).
    intro H; right. intro e. inversion e. apply (H (logic_eq_is_eq H1)).
Defined.

(*! bool !*)

Instance DecidableEq_eq_bool : DecidableEq bool.
constructor. intros x y; revert y. induction x.
- destruct y.
 + left ;reflexivity.
 + right; intro H; inversion H.
- destruct y.
 + right; intro H; inversion H.
 + left ;reflexivity.
Defined.

Canonical Structure Dbool : DType := Build_DType bool _.

Instance Decidable_leq n m : DecidableEq (n <= m).
constructor. revert m n. intros n m.
assert (forall n n'
(e : n = n'), forall (le_mn1 : m <= n) (le_mn2 : m <= n'), Logic.eq (e # le_mn1) le_mn2).
clear.
intros. revert n' e le_mn2.
induction le_mn1 using le_rect; intros.
- destruct le_mn2 using le_rect.
  + assert (e = eq_refl). apply is_hset. rewrite X. reflexivity.
  + assert False. clear - e le_mn2. rewrite e in le_mn2. apply (inv_leq _ O le_mn2). destruct H.
- destruct le_mn2 using le_rect; try clear IHle_mn2.
  + assert False. clear - e le_mn1. rewrite <- e in le_mn1. apply (inv_leq _ O le_mn1). destruct H.
  + assert (m0 = m1). clear - e. inversion e. reflexivity.
    specialize (IHle_mn1 _ X le_mn2). rewrite <- IHle_mn1.
    assert (e = ap S X). apply is_hset. rewrite X0 in *. clear e X0.
    destruct X. reflexivity.
- intros a b; apply inl. destruct (H _ _ eq_refl a b). reflexivity.
Defined.

Require Import Arith.

Definition Peano_le_rect : forall (n : Datatypes.nat) (P : forall n0 , Nat.le n n0 -> Prop),
       P n (Peano.le_n n) ->
       (forall m (l : Peano.le n m), P m l -> P (Datatypes.S m) (Peano.le_S n m l)) -> forall n0 (l : Peano.le n n0), P n0 l :=
fun n (P : forall n0 , Peano.le n n0 -> Prop) (f : P n (Peano.le_n n))
  (f0 : forall m (l : Peano.le n m), P m l -> P (Datatypes.S m) (Peano.le_S n m l)) =>
fix F n0 (l : Peano.le n n0) {struct l} : P n0 l :=
  match l as l0 in (Peano.le _ n1) return (P n1 l0) with
  | Peano.le_n _ => f
  | Peano.le_S _ m l0 => f0 m l0 (F m l0)
  end.

Fixpoint Peano_apply_S_n (n:Datatypes.nat) m : Datatypes.nat :=
  match n with 0 => Datatypes.S m
          | Datatypes.S n => Datatypes.S (Peano_apply_S_n n m)
  end.

Definition Peano_apply_prop n m : Logic.eq (Peano_apply_S_n n (Datatypes.S m)) (Datatypes.S (Peano_apply_S_n n m)).
Proof.
  induction n. reflexivity. cbn. f_equal; auto.
Defined.

Definition Peano_inv_eq_gen m : forall n, Logic.eq (Peano_apply_S_n n m) m -> False.
Proof.
  induction m. destruct n; cbn; intro; inversion H.
  - intros. rewrite Peano_apply_prop in H. inversion H. apply (IHm _ H1).
Defined.

Definition Peano_inv_leq m : forall n, (Peano_apply_S_n n m <= m)%nat -> False.
  induction m.
  - destruct n; cbn; intro; inversion H.
  - intros n e. rewrite Peano_apply_prop in e. inversion e.
    + apply (Peano_inv_eq_gen _ _ H0).
    + apply (IHm (Datatypes.S n) H0).
Defined.

Instance Decidable_datatypes_leq n m : DecidableEq (n <= m)%nat.
constructor. revert m n. intros n m.
assert (forall n n'
(e : n = n'), forall (le_mn1 : (m <= n)%nat) (le_mn2 : (m <= n')%nat), Logic.eq (e # le_mn1) le_mn2).
clear.
intros. revert n' e le_mn2.
induction le_mn1 using Peano_le_rect; intros.
- destruct le_mn2 using Peano_le_rect.
  + assert (e = eq_refl). apply is_hset. rewrite X. reflexivity.
  + assert False. clear - e le_mn2. rewrite e in le_mn2. apply (Peano_inv_leq _ 0 le_mn2). destruct H.
- destruct le_mn2 using Peano_le_rect; try clear IHle_mn2.
  + assert False. clear - e le_mn1. rewrite <- e in le_mn1. apply (Peano_inv_leq _ 0 le_mn1). destruct H.
  + assert (m0 = m1). clear - e. inversion e. reflexivity.
    specialize (IHle_mn1 _ X le_mn2). rewrite <- IHle_mn1.
    assert (e = ap Datatypes.S X). apply is_hset. rewrite X0 in *. clear e X0.
    destruct X. reflexivity.
- intros a b; apply inl. destruct (H _ _ eq_refl a b). reflexivity.
Defined.

Definition DecidableEq_hprop : forall (A B : DType), A.(carrier) = B.(carrier) -> A = B.
  intros A B e. destruct A as [A decA], B as [B decB]. cbn in *. assert (HSet A). apply Hedberg. auto.
  apply path_DType. cbn in *. exists e. apply path_DecidableEq. apply funext. intro a. apply funext. intro b.
  destruct decA, decB. destruct e. cbn. apply path_sum. destruct (dec_paths0 a b), (dec_paths1 a b); auto.
  apply is_hset. apply funext. intro e. destruct (f e).
Defined.