Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.CategoryTheory.Categories.
Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.PartB.
Require Import UniMath.Foundations.PartC.
Require Import UniMath.Foundations.PartD.
Require Import UniMath.CategoryTheory.functor_categories.
Require Import UniMath.CategoryTheory.categories.category_hset.

Local Open Scope cat.

Lemma incl_eq A B (f g : incl A B) :  pr1incl _ _ f = pr1incl _ _ g -> f = g.
  intro e.
  apply subtypeEquality'.
  - exact e.
  - apply isapropisincl.
Defined.
Lemma isincl_idfun (A : UU) : isincl (idfun A).
Proof.
  intros a e e'.
  apply hlevelntosn.
  apply iscontrcoconustot.
Defined.
Definition names_ob : UU := nat.

Definition names_mor (p q : names_ob) := incl (stn p) (stn q).

Definition names_mor_ob_mor : precategory_ob_mor := (names_ob,,names_mor).

Definition id_mor_precat (c : names_mor_ob_mor) : c --> c :=
  (idfun _ ,, isincl_idfun _).

Definition names_precat_data : precategory_data :=
  precategory_data_pair _ id_mor_precat (fun a b c => inclcomp).

Lemma is_precategory_names_data  :
  is_precategory names_precat_data.
Proof.
  (repeat split);  now simpl; intros; apply incl_eq.
Qed.

Definition names_precat  : precategory :=
  (_,,is_precategory_names_data).

Lemma has_homsets_names_precat : has_homsets names_precat.
Proof.
  intros a b.
  apply isaset_total2.

  - apply impred_isaset.
    intros _.
    apply isasetstn.
  - intros.
    apply hlevelntosn.
    apply isapropisincl.
Qed.

Definition names_cat : category := (names_precat ,, has_homsets_names_precat).

Definition nominal_set_cat := [ names_cat, hset_category].

Section nameabstraction.
  Variable (X : nominal_set_cat).

End nameabstraction.


Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import
        Coq.QArith.QArith CoRN.model.totalorder.QposMinMax
        CoRN.model.metric2.Qmetric CoRN.reals.fast.CRArith.

(** The approximation function for CRplus results distributes a given error evenly
among its two operands. This is a perfectly reasonable implementation choice,
but it is conceptually arbitrary: any ratio works fine. Furthermore, when
reasoning about particular uses of CRplus, different ratios can be more
natural fits to the proof at hand. For instance, in the additivity proof for the Riemann
integral implementation, having the error for the sum of two integrals distributed
proportionally to the widths of the two contiguous ranges makes it nicely match the
error for the full integral on both sides.

For situations like these, we now do a very ad-hoc redefinition of addition with
a user-specified error distribution ratio, and show that it is equivalent to the
normal CRplus. *)

Section uneven_CRplus.

  Variables
    (l r: Qpos) (* These are the error weights for x and y. *)
    (x y: CR).

  Let ll: Qpos := (l * Qpos_inv (l + r))%Qpos.
  Let rr: Qpos := (r * Qpos_inv (l + r))%Qpos.

  Let llrr: QposEq (ll + rr) (1#1).
  Proof.
   unfold ll, rr. simpl.
   unfold QposEq; simpl; field. intro.
   apply (Qpos_nonzero (l+r)%Qpos).
   assumption.
  Qed.

  Definition uneven_CRplus_approx (e: Qpos): Q_as_MetricSpace
    := approximate x (Qpos2QposInf (e * ll)) + approximate y (Qpos2QposInf (e * rr)).

  Lemma uneven_CRplus_is_RegularFunction: is_RegularFunction_noInf _ uneven_CRplus_approx.
  Proof with auto.
   intros e1 e2.
   unfold uneven_CRplus_approx. simpl.
   assert (QposEq (e1 + e2) ((e1 * ll + e2 * ll) + (e1 * rr + e2 * rr))).
   { unfold QposEq.
     transitivity (proj1_sig (e1 + e2)%Qpos * proj1_sig (ll + rr)%Qpos).
     unfold QposEq in llrr. rewrite llrr. simpl. ring.
     simpl. ring. }
   apply (ball_wd _ H _ _ (reflexivity _) _ _ (reflexivity _)). clear H.
    apply Qball_plus.
     apply (regFun_prf x (e1*ll)%Qpos (e2*ll)%Qpos).
    apply (regFun_prf y (e1*rr)%Qpos (e2*rr)%Qpos).
  Qed.

  Definition uneven_CRplus: CR := @mkRegularFunction Q_as_MetricSpace 0 _ uneven_CRplus_is_RegularFunction.

  Lemma uneven_CRplus_correct: (uneven_CRplus == x + y)%CR.
  Proof.
   simpl.
   apply regFunEq_equiv, regFunEq_e. intro e.
   unfold ball, Q_as_MetricSpace, Qball, QAbsSmall.
   rewrite approximate_CRplus...
   unfold uneven_CRplus_approx.
   setoid_replace (proj1_sig e + proj1_sig e)
     with (proj1_sig ((e * ll + (1#2) * e) + (e * rr + (1#2) * e)))%Qpos.
    apply Qball_plus; apply regFun_prf.
     simpl in llrr.
   transitivity (proj1_sig e + proj1_sig e * proj1_sig (ll + rr)%Qpos)...
   unfold QposEq in llrr. simpl in llrr. simpl. rewrite llrr.
   unfold canonical_names.equiv, stdlib_rationals.Q_eq. ring.
   unfold canonical_names.equiv, stdlib_rationals.Q_eq. simpl. ring.
  Qed.

End uneven_CRplus.


Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Arith.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import Coq.Bool.Bvector.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Stabilization.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Tactics.BreakMatch.
Import ListNotations.
Local Open Scope list_scope.
Local Open Scope bool_scope.
Local Open Scope Z_scope.

Create HintDb bitlist discriminated.

Module Import Bitlist.
  Local Set Primitive Projections.
  Record t := { internal_bitlist : list bool ; test_signbit : bool }.
  Definition signbit (v : t) : Z := if test_signbit v then -1 else 0.
  Definition sgn (v : t) : Z
    := if test_signbit v then -1 else if List.existsb (fun b => b) (internal_bitlist v) then 1 else 0.
  Definition testbit (v : t) (n : Z) : bool
    := if n <? 0
       then false
       else List.nth_default (Z.testbit (signbit v) n) (internal_bitlist v) (Z.to_nat n).
  Definition bitcount (v : t) : nat := List.length (internal_bitlist v).
  Hint Transparent bitcount : rewrite bitlist.
  Definition bitlist (v : t) (len : nat) : list bool
    := firstn len (internal_bitlist v) ++ repeat (Z.testbit (signbit v) 0) (len - bitcount v).
  Notation bitlist_default v := (bitlist v (bitcount v)) (only parsing).
  Definition to_Z (v : t) : Z
    := List.fold_right
         (fun '(n, b) a => (if b : bool then Z.setbit else Z.clearbit) a (Z.of_nat n))
         (signbit v)
         (List.enumerate (bitlist_default v)).
  Definition of_Z_len (v : Z) (len : Z) : t
    := Build_t
         (List.map (fun n => Z.testbit v (Z.of_nat n)) (seq 0 (Z.to_nat len)))
         (v <? 0).
  Definition of_Z (v : Z) : t := of_Z_len v (Z.stabilization_time v + 1).

  Lemma length_bitlist v len : length (bitlist v len) = len.
  Proof.
    cbv [bitlist bitcount]; autorewrite with distr_length.
    apply Nat.min_case_strong; try lia.
  Qed.
  Hint Rewrite length_bitlist : distr_length bitlist.

  Lemma bitcount_of_Z_len v len : bitcount (of_Z_len v len) = Z.to_nat len.
  Proof. cbv [bitcount of_Z_len internal_bitlist]; now autorewrite with distr_length. Qed.
  Hint Rewrite bitcount_of_Z_len : distr_length bitlist.

  Lemma bitcount_of_Z v : bitcount (of_Z v) = Z.to_nat (Z.stabilization_time v + 1).
  Proof. apply bitcount_of_Z_len. Qed.
  Hint Rewrite bitcount_of_Z : distr_length bitlist.

  Lemma enumerate_bitlist_default_eq v
    : enumerate (bitlist_default v) = List.combine (List.seq 0 (bitcount v)) (internal_bitlist v).
  Proof.
    cbv [enumerate]; autorewrite with distr_length.
    cbv [bitlist bitcount]; autorewrite with natsimplify; cbn [repeat].
    now rewrite List.app_nil_r, List.firstn_all.
  Qed.

  Lemma testbit_to_Z v n : Z.testbit (to_Z v) n = testbit v n.
  Proof.
    cbv [to_Z testbit].
    destruct (n <? 0) eqn:?; Z.ltb_to_lt.
    { now rewrite Z.testbit_neg_r by assumption. }
    rewrite enumerate_bitlist_default_eq.
    cbv [bitcount].
    set (offset := 0%nat) at 1.
    change 0 with (Z.of_nat offset) in * |- .
    replace n with (n - Z.of_nat offset) at 3 by lia.
    clearbody offset; revert dependent offset.
    revert dependent n.
    induction (internal_bitlist v) as [|x xs IHxs];
      cbn [length seq List.combine fold_right];
      intros; [ now rewrite nth_default_nil | ].
    specialize (fun n => IHxs n (S offset)).
    assert (H' : n = Z.of_nat offset \/ Z.of_nat offset < n) by lia.
    destruct H'; subst.
    { break_innermost_match;
        first [ rewrite Z.setbit_eq by lia | rewrite Z.clearbit_eq by lia ].
      all: autorewrite with zsimplify; reflexivity. }
    { lazymatch goal with
      | [ |- Z.testbit (?f ?x ?y) ?n = _ ] => transitivity (Z.testbit x n)
      end.
      { now break_innermost_match;
          first [ rewrite Z.setbit_neq by lia | rewrite Z.clearbit_neq by lia ]. }
      rewrite IHxs by lia.
      replace (Z.to_nat (n - Z.of_nat (S offset))) with (pred (Z.to_nat (n - Z.of_nat offset)))
        by (* could just use [lia], but only in Coq >= 8.11 *)
          (now rewrite Nat2Z.inj_succ, <- Z.add_1_r, Z.sub_add_distr, Z.sub_1_r, Z2Nat.inj_pred).
      destruct (Z.to_nat (n - Z.of_nat offset)) eqn:H'; [ exfalso | ].
      { (* could just use [lia], but only in Coq >= 8.11 *)
        apply (f_equal Z.of_nat) in H'; rewrite Z2Nat.id in H' by lia.
        lia. }
      rewrite nth_default_cons_S; reflexivity. }
  Qed.
  Hint Rewrite testbit_to_Z : bitlist Ztestbit.

  Lemma testbit_of_Z_len v n len
    : testbit (of_Z_len v len) n = if n <? len then Z.testbit v n else Z.testbit (if v <? 0 then -1 else 0) n.
  Proof.
    cbv [testbit of_Z_len signbit test_signbit internal_bitlist].
    cbv [nth_default].
    rewrite nth_error_map, nth_error_seq.
    break_innermost_match; Z.ltb_to_lt; try solve [ exfalso; lia ].
    all: repeat first [ reflexivity
                      | congruence
                      | progress cbn [option_map Nat.add] in *
                      | progress inversion_option
                      | rewrite Z.testbit_neg_r by lia
                      | progress rewrite Z2Nat.id in * by lia
                      | fail (* the rest are only needed in Coq < 8.11 *)
                      | rewrite Z.bits_m1 by lia
                      | lia
                      | match goal with
                        | [ H : ?x < 0, H' : context[Z.to_nat ?x] |- _ ]
                          => replace (Z.to_nat x) with 0%nat in * by now destruct n
                        | [ H : (_ < _)%nat |- _ ]
                          => apply inj_lt in H; rewrite ?Z2Nat.id in H by lia
                        | [ H : context[Z.of_nat (Z.to_nat ?x)] |- _ ]
                          => let H' := fresh in
                             assert (H' : x < 0 \/ 0 <= x) by lia;
                             destruct H';
                             [ replace (Z.to_nat x) with 0%nat in * by now destruct x
                             | rewrite Z2Nat.id in H by assumption ]
                        end
                      | progress zify ].
  Qed.
  Hint Rewrite testbit_of_Z_len : bitlist Ztestbit.

  Lemma testbit_of_Z v n : testbit (of_Z v) n = Z.testbit v n.
  Proof.
    cbv [of_Z]; rewrite testbit_of_Z_len.
    destruct (stabilization_time v) as [b H].
    pose proof (H n) as H'.
    break_innermost_match_step; Z.ltb_to_lt; [ reflexivity | ].
    rewrite H' by lia.
    pose proof (Z.stabilization_time_nonneg v).
    break_innermost_match_step; Z.ltb_to_lt;
      [ destruct (proj1 (Z.bits_iff_neg_ex v) ltac:(lia)) as [k H'']
      | pose proof (proj2 (Z.bits_iff_neg_ex v)) as H'' ].
    { rewrite Z.bits_m1 by lia.
      specialize (H (Z.max (Z.stabilization_time v + 1) (k + 1)) ltac:(lia)).
      rewrite H'' in H by lia; congruence. }
    { rewrite Z.testbit_0_l.
      destruct b; [ cut (v < 0); [ lia | ] | reflexivity ].
      apply H''; eexists; eassumption. }
  Qed.
  Hint Rewrite testbit_of_Z : bitlist Ztestbit.

  Lemma path_t (v1 v2 : t) : internal_bitlist v1 = internal_bitlist v2 -> test_signbit v1 = test_signbit v2 -> v1 = v2.
  Proof. destruct v1, v2; cbn; intros; subst; reflexivity. Qed.

  Definition bitwise (f : bool -> bool -> bool) (v1 v2 : t) : t
    := let len := Nat.max (bitcount v1) (bitcount v2) in
       Build_t (List.map (fun '(a, b) => f a b) (List.combine (bitlist v1 len) (bitlist v2 len)))
               (f (test_signbit v1) (test_signbit v2)).

  Lemma testbit_signbit v n : 0 <= n -> Z.testbit (signbit v) n = test_signbit v.
  Proof.
    cbv [signbit]; break_innermost_match; intro.
    { now rewrite Z.bits_m1. }
    { now rewrite Z.testbit_0_l. }
  Qed.
  Hint Rewrite testbit_signbit : bitlist Ztestbit.

  Lemma testbit_bitwise f v1 v2 n : testbit (bitwise f v1 v2) n = if n <? 0 then false else f (testbit v1 n) (testbit v2 n).
  Proof.
    cbv [testbit bitwise nth_default];
      cbn [internal_bitlist test_signbit].
    rewrite nth_error_map, nth_error_combine.
    break_innermost_match_step; Z.ltb_to_lt; [ reflexivity | ].
    rewrite testbit_signbit by lia; cbn [test_signbit].
    apply Nat.max_case_strong; intro.
    all: cbv [bitlist bitcount] in *;
      autorewrite with natsimplify;
      cbn [List.repeat]; rewrite List.app_nil_r, !firstn_all2, nth_error_app, nth_error_repeat_alt, testbit_signbit by lia.
    all: cbv [option_map].
    all: break_innermost_match.
    all: repeat first [ reflexivity
                      | rewrite testbit_signbit by lia
                      | progress inversion_option
                      | match goal with
                        | [ H : nth_error _ _ = None |- _ ] => apply nth_error_error_length in H; exfalso; lia
                        | [ H : context[nth_error _ _] |- _ ] => rewrite nth_error_length_error in H by lia
                        end ].
  Qed.
  Hint Rewrite testbit_bitwise : bitlist Ztestbit.
End Bitlist.
Hint Rewrite length_bitlist bitcount_of_Z_len bitcount_of_Z : distr_length bitlist.
Hint Rewrite testbit_to_Z testbit_of_Z_len testbit_of_Z testbit_bitwise testbit_signbit : bitlist Ztestbit.
Hint Transparent bitcount : rewrite.

Module Z2Bitlist.
  Lemma id (v : Z) : to_Z (of_Z v) = v.
  Proof. now apply Z.bits_inj; intro; autorewrite with bitlist. Qed.
End Z2Bitlist.

Definition bitwise (f : bool -> bool -> bool) (v1 v2 : Z) : Z
  := to_Z (Bitlist.bitwise f (of_Z v1) (of_Z v2)).

Lemma testbit_bitwise f v1 v2 n : Z.testbit (bitwise f v1 v2) n = if n <? 0 then false else f (Z.testbit v1 n) (Z.testbit v2 n).
Proof. now cbv [bitwise]; autorewrite with bitlist. Qed.
Hint Rewrite testbit_bitwise : Ztestbit.

Lemma bitwise_land v1 v2 : bitwise andb v1 v2 = Z.land v1 v2.
Proof.
  apply Z.bits_inj; intro; rewrite Z.land_spec, testbit_bitwise.
  break_innermost_match; Z.ltb_to_lt; [ | reflexivity ].
  now rewrite !Z.testbit_neg_r by lia.
Qed.

Lemma bitwise_lor v1 v2 : bitwise orb v1 v2 = Z.lor v1 v2.
Proof.
  apply Z.bits_inj; intro; rewrite Z.lor_spec, testbit_bitwise.
  break_innermost_match; Z.ltb_to_lt; [ | reflexivity ].
  now rewrite !Z.testbit_neg_r by lia.
Qed.

Lemma bitwise_lxor v1 v2 : bitwise xorb v1 v2 = Z.lxor v1 v2.
Proof.
  apply Z.bits_inj; intro; rewrite Z.lxor_spec, testbit_bitwise.
  break_innermost_match; Z.ltb_to_lt; [ | reflexivity ].
  now rewrite !Z.testbit_neg_r by lia.
Qed.


Require Import Arith.
Require Import List.
Import ListNotations.
Require Import Omega.

Require Import v1.NeutronTactics.
Require Import v1.Util.

Require Import ProofIrrelevance.

Set Default Timeout 5.

Inductive index (n : nat) : Set :=
| Index : forall m, m < n -> index n.
Implicit Arguments Index [n].

Definition index_nat (n : nat) (i : index n) : nat :=
    match i with Index m _ => m end.
Implicit Arguments index_nat [n].

Ltac mk_index m_ := eapply Index with (m := m_); hide; omega.

Fixpoint index_list' n i (acc : list (index n)) {struct i} : i < n -> list (index n) :=
    fun Hlt =>
        let acc' := Index i Hlt :: acc in
        match i as i_ return i_ < n -> list (index n) with
        | 0 => fun _ => acc'
        | S i' => fun Hlt => @index_list' n i' acc' ltac:(hide; omega)
        end Hlt.
Implicit Arguments index_list'.

Definition index_list n : list (index n) :=
    match n as n_ return n = n_ -> _ with
    | 0 => fun _ => []
    | S n' => fun Heq => @index_list' n n' [] ltac:(hide; omega)
    end eq_refl.

Definition index_ext (n m : nat) (Hlt : n < m) (i : index n) : index m :=
    let (i', Hlt') := i in
    @Index m i' ltac:(hide; omega).
Implicit Arguments index_ext [n m].

Definition index_eq_dec n (x y : index n) : { x = y } + { x <> y }.
destruct x, y.
destruct (eq_nat_dec m m0); [ subst | right; congruence ].
replace l0 with l by (eapply proof_irrelevance).
eauto.
Qed.

(* Using a fixpoint makes `multi 3 nat` definitionally equal to `nat * nat * nat` *)

Fixpoint multi' n A : Set :=
    match n with
    | 0 => A
    | S n => (multi' n A * A)%type
    end.

Fixpoint multi'_rep (n : nat) (A : Set) (v : A) {struct n} : multi' n A :=
    match n as n_ return multi' n_ A with
    | 0 => v
    | S n' => (@multi'_rep n' A v, v)
    end.
Implicit Arguments multi'_rep [A].

Fixpoint multi'_get n A (x : multi' n A) (i : index (S n)) {struct n} : A :=
    match n as n_ return multi' n_ A -> index (S n_) -> A with
    (* Only one element in the multi', so return that.  The index is
       guaranteed to be zero, since `m < S 0`. *)
    | 0 => fun x i => x
    (* Multiple elements.  Might need a recursive call. *)
    | S n' => fun x i =>
            (* The type of `x` is (multi n' A * A).  If the index `i` refers to
               the last element in `x`, we can just extract that with `snd`.
               Otherwise, we need to make a recursive call on `fst x`. *)
            let (i', Hlt) := i in
            if eq_nat_dec (S n') i' then
                snd x
            else
                @multi'_get n' A (fst x) ltac:(mk_index i')
    end x i.
Implicit Arguments multi'_get [n A].

Fixpoint multi'_set n A (x : multi' n A) (i : index (S n)) (v : A) {struct n} : multi' n A :=
    match n as n_ return multi' n_ A -> index (S n_) -> multi' n_ A with
    | 0 => fun x i => v
    | S n' => fun x i =>
            let (i', Hlt) := i in
            if eq_nat_dec (S n') i' then
                (fst x, v)
            else
                (@multi'_set n' A (fst x) ltac:(mk_index i') v, snd x)
    end x i.
Implicit Arguments multi'_set [n A].

Fixpoint multi'_to_list' n A (x : multi' n A) (acc : list A) : list A :=
    match n as n_ return multi' n_ A -> list A with
    | 0 => fun x => x :: acc
    | S n' => fun x => multi'_to_list' n' A (fst x) (snd x :: acc)
    end x.

Definition multi'_to_list n A (x : multi' n A) : list A :=
    multi'_to_list' n A x [].
Implicit Arguments multi'_to_list [n A].

Fixpoint index_multi'' n i : i <= n -> multi' i (index (S n)).
intro Hle.
destruct i.
- refine (Index 0 _). hide. omega.
- refine (index_multi'' n i _, Index (S i) _); hide; omega.
Defined.

Definition index_multi' n : multi' n (index (S n)).
eapply index_multi''. hide. omega.
Defined.

Fixpoint multi'_map n (A B : Set) (f : A -> B) (x : multi' n A) : multi' n B :=
    match n as n_ return multi' n_ A -> multi' n_ B with
    | 0 => fun x => f x
    | S n' => fun x => (multi'_map n' A B f (fst x), f (snd x))
    end x.
Implicit Arguments multi'_map [n A B].

Fixpoint multi'_map_opt n (A B : Set) (f : A -> option B) (x : multi' n A) : option (multi' n B) :=
    match n as n_ return multi' n_ A -> option (multi' n_ B) with
    | 0 => fun x => f x
    | S n' => fun x =>
            multi'_map_opt n' A B f (fst x) >>= fun init =>
            f (snd x) >>= fun last =>
            Some (init, last)
    end x.
Implicit Arguments multi'_map_opt [n A B].

Fixpoint multi'_zip n (A B C : Set) (f : A -> B -> C)
        (x : multi' n A) (y : multi' n B) : multi' n C :=
    match n as n_ return multi' n_ A -> multi' n_ B -> multi' n_ C with
    | 0 => fun x y => f x y
    | S n' => fun x y => (multi'_zip n' A B C f (fst x) (fst y), f (snd x) (snd y))
    end x y.
Implicit Arguments multi'_zip [n A B C].

Definition multi'_eq_dec n (A : Set)
    (eq_dec : forall (x y : A), { x = y } + { x <> y })
    (x y : multi' n A) : { x = y } + { x <> y }.
generalize dependent n. induction n; simpl; intros.
- eapply eq_dec.
- destruct x as [x xv], y as [y yv].
  decide equality.
Defined.
Implicit Arguments multi'_eq_dec [n A].

Theorem multi'_rep_get : forall n (A : Set) i (v : A),
    multi'_get (multi'_rep n v) i = v.
induction n; intros.
{ simpl. reflexivity. } (* zero case *)

unfold multi'_rep, multi'_get. fold multi'_rep. fold multi'_get.
destruct i as [i' ?].
destruct (eq_nat_dec (S n) i').
- reflexivity.
- eapply IHn.
Qed.

Theorem multi'_get_eq : forall n A (x : multi' n A) i j,
    index_nat i = index_nat j -> multi'_get x i = multi'_get x j.
induction n; intros0 Heqnat.
{ simpl. reflexivity. }

unfold multi'_get. fold multi'_get.
destruct i as [i' ?].
destruct j as [j' ?].
simpl in Heqnat.
destruct (eq_nat_dec (S n) i'); destruct (eq_nat_dec (S n) j'); try omega.
- reflexivity.
- eapply IHn. simpl. assumption.
Qed.

Theorem multi'_set_get : forall n A (x : multi' n A) i j v,
    index_nat i = index_nat j -> multi'_get (multi'_set x i v) j = v.
induction n; intros0 Heqnat.
{ simpl. reflexivity. }

unfold multi'_get, multi'_set. fold multi'_get. fold multi'_set.
destruct i as [i' ?].
destruct j as [j' ?].
simpl in Heqnat.
destruct (eq_nat_dec (S n) i'); destruct (eq_nat_dec (S n) j'); try omega.
- reflexivity.
- eapply IHn. simpl. assumption.
Qed.

Theorem multi'_set_get_other : forall n A (x : multi' n A) i j v,
    index_nat i <> index_nat j -> multi'_get (multi'_set x i v) j = multi'_get x j.
induction n; intros0 Hneqnat.
{ destruct i. destruct j. simpl in Hneqnat. omega. }

unfold multi'_get, multi'_set. fold multi'_get. fold multi'_set.
destruct i as [i' ?].
destruct j as [j' ?].
simpl in Hneqnat.
destruct (eq_nat_dec (S n) i'); destruct (eq_nat_dec (S n) j'); try omega.
- reflexivity.
- reflexivity.
- eapply IHn. simpl. assumption.
Qed.

Lemma multi'_get_shrink :
    forall n A (x : multi' n A) (v : A) (i1 : index (2 + n)) (i2 : index (1 + n)),
    index_nat i1 = index_nat i2 ->
    multi'_get ((x, v) : multi' (1 + n) A)  i1 = multi'_get x i2.
intros ? ? ? ? ? ? Heq.
compute [plus] in *.
destruct i1 as [ i1' Hlt1 ].
destruct i2 as [ i2' Hlt2 ].
simpl in Heq. subst.

unfold multi'_get. fold multi'_get.
destruct (eq_nat_dec _ _); [ omega | ].
simpl.
eapply multi'_get_eq. simpl. reflexivity.
Qed.

Lemma multi'_get_ext_fst : forall n A (x : multi' n A) (v : A) i Hlt,
    multi'_get ((x, v) : multi' (S n) A) (@index_ext (S n) (2 + n) Hlt i) = multi'_get x i.
intros.
destruct i as [ i' Hlt' ].
rewrite multi'_get_shrink with (i2 := @Index (S n) i' ltac:(hide; omega)); cycle 1.
{ simpl. reflexivity. }
eapply multi'_get_eq.
simpl. reflexivity.
Qed.

Lemma multi'_get_snd : forall n A (x : multi' n A) (v : A) Hlt,
    multi'_get ((x, v) : multi' (1 + n) A) (Index (1 + n) Hlt) = v.
intros.
simpl. destruct (eq_nat_dec _ _).
- reflexivity.
- omega.
Qed.

Lemma multi'_get_set_eq : forall n A (x : multi' n A) i, multi'_set x i (multi'_get x i) = x.
induction n; intros.
{ simpl. reflexivity. }

destruct x.
destruct i as [ i' Hlt ].
unfold multi'_set, multi'_get. destruct (eq_nat_dec (S n) i'); fold multi'_set; fold multi'_get.
- simpl. reflexivity.
- rewrite IHn. simpl. reflexivity.
Qed.

Lemma multi'_to_list'_length : forall n A x acc,
    length (@multi'_to_list' n A x acc) = S n + length acc.
first_induction n; intros; simpl.
{ reflexivity. }
rewrite IHn. simpl. omega.
Qed.

Lemma multi'_to_list_length : forall n A x,
    length (@multi'_to_list n A x) = S n.
intros. unfold multi'_to_list.
replace (S n) with (S n + @length A []) by (simpl; omega).
eapply multi'_to_list'_length.
Qed.

Theorem index_multi''_get : forall n i Hle j,
    index_nat (multi'_get (index_multi'' n i Hle) j) = index_nat j.
first_induction i; intros; destruct j as [j Hj].
- simpl. omega.
- unfold multi'_get. destruct (eq_nat_dec (S i) j); fold multi'_get.
  + simpl. assumption.
  + unfold index_multi'', fst. fold index_multi''.
    rewrite IHi. simpl. reflexivity.
Qed.

Theorem index_multi'_get : forall n i,
    index_nat (multi'_get (index_multi' n) i) = index_nat i.
intros. unfold index_multi'. eapply index_multi''_get.
Qed.

Theorem multi'_map_get : forall n (A B : Set) (f : A -> B) (x : multi' n A) i,
    multi'_get (multi'_map f x) i = f (multi'_get x i).
first_induction n; intros; destruct i as [i Hi].
- destruct i; try omega. simpl. reflexivity.
- destruct x as [x y].
  unfold multi'_get. destruct (eq_nat_dec (S n) i); fold multi'_get.
  + simpl. reflexivity.
  + unfold multi'_map. fold multi'_map. unfold fst, snd.
    eapply IHn.
Qed.

Theorem multi'_map_opt_get : forall n (A B : Set) (f : A -> option B) (x : multi' n A) y i,
    multi'_map_opt f x = Some y ->
    f (multi'_get x i) = Some (multi'_get y i).
first_induction n; intros0 Hmap; destruct i as [i Hi].
- destruct i; try omega. simpl. assumption.
- destruct x as [x_init x_last].
  unfold multi'_get. destruct (eq_nat_dec (S n) i); fold multi'_get.
  + simpl in Hmap. unfold bind_option in Hmap. do 2 (break_match; try discriminate).
    fancy_injr <- Hmap. simpl. assumption.
  + simpl in Hmap. unfold bind_option in Hmap. do 2 (break_match; try discriminate).
    eapply IHn. fancy_injr <- Hmap. simpl. assumption.
Qed.

Theorem multi'_zip_get : forall n (A B C : Set) (f : A -> B -> C)
        (x : multi' n A) (y : multi' n B) i,
    multi'_get (multi'_zip f x y) i = f (multi'_get x i) (multi'_get y i).
first_induction n; intros; destruct i as [i Hi].
- destruct i; try omega. simpl. reflexivity.
- destruct x as [x x'], y as [y y'].
  unfold multi'_get. destruct (eq_nat_dec (S n) i); fold multi'_get.
  + simpl. reflexivity.
  + unfold multi'_zip. fold multi'_zip. unfold fst, snd.
    eapply IHn.
Qed.

Definition multi n A : Set :=
    match n with
    | 0 => unit
    | S n => multi' n A
    end.

Definition multi_rep (n : nat) (A : Set) (v : A) : multi n A :=
    match n as n_ return multi n_ A with
    | 0 => tt
    | S n' => multi'_rep n' v
    end.
Implicit Arguments multi_rep [A].

Definition multi_get n A (x : multi n A) (i : index n) : A :=
    match n as n_ return multi n_ A -> index n_ -> A with
    | 0 => fun x i => @HIDDEN _ ltac:(exfalso; destruct i; omega)
    | S n' => fun x i => multi'_get x i
    end x i.
Implicit Arguments multi_get [n A].

Definition multi_set n A (x : multi n A) (i : index n) (v : A) : multi n A :=
    match n as n_ return multi n_ A -> index n_ -> multi n_ A with
    | 0 => fun x i => @HIDDEN _ ltac:(exfalso; destruct i; omega)
    | S n' => fun x i => multi'_set x i v
    end x i.
Implicit Arguments multi_set [n A].

Definition multi_to_list n A (x : multi n A) : list A :=
    match n as n_ return multi n_ A -> list A with
    | 0 => fun _ => []
    | S n' => fun x => multi'_to_list x
    end x.
Implicit Arguments multi_to_list [n A].

Definition index_multi n : multi n (index n) :=
    match n as n_ return multi n_ (index n_) with
    | 0 => tt
    | S n' => index_multi' n'
    end.

Definition multi_map n (A B : Set) (f : A -> B) (x : multi n A) : multi n B :=
    match n as n_ return multi n_ A -> multi n_ B with
    | 0 => fun _ => tt
    | S n' => fun x => multi'_map f x
    end x.
Implicit Arguments multi_map [n A B].

Definition multi_map_opt n (A B : Set) (f : A -> option B) (x : multi n A) : option (multi n B) :=
    match n as n_ return multi n_ A -> option (multi n_ B) with
    | 0 => fun _ => Some tt
    | S n' => fun x => multi'_map_opt f x
    end x.
Implicit Arguments multi_map_opt [n A B].

Definition multi_zip n (A B C : Set) (f : A -> B -> C)
        (x : multi n A) (y : multi n B) : multi n C :=
    match n as n_ return multi n_ A -> multi n_ B -> multi n_ C with
    | 0 => fun _ _ => tt
    | S n' => fun x y => multi'_zip f x y
    end x y.
Implicit Arguments multi_zip [n A B C].

Definition multi_eq_dec n (A : Set)
    (eq_dec : forall (x y : A), { x = y } + { x <> y })
    (x y : multi n A) : { x = y } + { x <> y }.
destruct n.
- destruct x, y. left. reflexivity.
- simpl in x, y. eapply multi'_eq_dec. auto.
Defined.
Implicit Arguments multi_eq_dec [n A].

Notation "x '!!' i" := (multi_get x i)
    (at level 100, i at next level).

Theorem multi_rep_get : forall n (A : Set) i (v : A),
    multi_get (multi_rep n v) i = v.
destruct n; intros.
{ destruct i. omega. }
eauto using multi'_rep_get.
Qed.

Theorem multi_get_eq : forall n A (x : multi n A) i j,
    index_nat i = index_nat j -> multi_get x i = multi_get x j.
destruct n; intros.
{ destruct i. omega. }
eauto using multi'_get_eq.
Qed.

Theorem multi_set_get : forall n A (x : multi n A) i j v,
    index_nat i = index_nat j -> multi_get (multi_set x i v) j = v.
destruct n; intros.
{ destruct i. omega. }
eauto using multi'_set_get.
Qed.

Theorem multi_set_get_other : forall n A (x : multi n A) i j v,
    index_nat i <> index_nat j -> multi_get (multi_set x i v) j = multi_get x j.
destruct n; intros.
{ destruct i. omega. }
eauto using multi'_set_get_other.
Qed.

Lemma multi_get_shrink :
    forall n A (x : multi (1 + n) A) (v : A) (i1 : index (2 + n)) (i2 : index (1 + n)),
    index_nat i1 = index_nat i2 ->
    multi_get ((x, v) : multi (2 + n) A)  i1 = multi_get x i2.
intros. compute [plus] in *.
unfold multi_get.
eauto using multi'_get_shrink.
Qed.

Lemma multi_get_ext_fst : forall n A (x : multi (1 + n) A) (v : A) i Hlt,
    multi_get ((x, v) : multi (2 + n) A) (@index_ext (1 + n) (2 + n) Hlt i) = multi_get x i.
intros. compute [plus] in *.
unfold multi_get.
eauto using multi'_get_ext_fst.
Qed.

Lemma multi_get_snd : forall n A (x : multi (1 + n) A) (v : A) Hlt,
    multi_get ((x, v) : multi (2 + n) A) (Index (1 + n) Hlt) = v.
intros. compute [plus] in *.
unfold multi_get.
eauto using multi'_get_snd.
Qed.

Lemma multi_get_set_eq : forall n A (x : multi n A) i, multi_set x i (multi_get x i) = x.
destruct n; intros.
{ destruct i. omega. }
intros. unfold multi_get, multi_set. eapply multi'_get_set_eq.
Qed.

Lemma multi_to_list_length : forall n A x,
    length (@multi_to_list n A x) = n.
intros. unfold multi_to_list.
destruct n.
- reflexivity.
- eapply multi'_to_list_length.
Qed.

Theorem index_multi_get : forall n i,
    index_nat (multi_get (index_multi n) i) = index_nat i.
intros. destruct n.
- destruct i. omega.
- unfold index_multi. eapply index_multi'_get.
Qed.

Theorem multi_map_get : forall n (A B : Set) (f : A -> B) (x : multi n A) i,
    multi_get (multi_map f x) i = f (multi_get x i).
intros. destruct n.
- destruct i. omega.
- eapply multi'_map_get.
Qed.

Theorem multi_map_opt_get : forall n (A B : Set) (f : A -> option B) (x : multi n A) y i,
    multi_map_opt f x = Some y ->
    f (multi_get x i) = Some (multi_get y i).
intros. destruct n.
- destruct i. omega.
- eapply multi'_map_opt_get. assumption.
Qed.

Theorem multi_zip_get : forall n (A B C : Set) (f : A -> B -> C)
        (x : multi n A) (y : multi n B) i,
    multi_get (multi_zip f x y) i = f (multi_get x i) (multi_get y i).
intros. destruct n.
- destruct i. omega.
- eapply multi'_zip_get.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This module proves some logical properties of the axiomatic of Reals.

- Decidability of arithmetical statements.
- Derivability of the Archimedean "axiom".
- Decidability of negated formulas.
*)

Require Import XRIneq.
Require Import XRcompleteness.

(** * Decidability of arithmetical statements *)

(** One can iterate this lemma and use classical logic to decide any
statement in the arithmetical hierarchy. *)

Section Arithmetical_dec.

Variable P : nat -> Prop.
Hypothesis HP : forall n, {P n} + {~P n}.

Lemma sig_forall_dec : {n | ~P n} + {forall n, P n}.
Proof.
assert (Hi: (forall n, R0 < INR n + R1)%R).
  intros n.
  apply Rle_lt_0_plus_1, pos_INR.
set (u n := (if HP n then R0 else / (INR n + R1))%R).
assert (Bu: forall n, (u n <= R1)%R).
  intros n.
  unfold u.
  case HP ; intros _.
  apply Rle_0_1.
  rewrite <- S_INR, <- Rinv_1.
  apply Rinv_le_contravar with (1 := Rlt_0_1).
  apply (le_INR 1), le_n_S, le_0_n.
set (E y := exists n, y = u n).
destruct (completeness E) as [l [ub lub]].
  exists R1.
  intros y [n ->].
  apply Bu.
  exists (u O).
  now exists O.
assert (Hnp: forall n, not (P n) -> ((/ (INR n + R1) <= l)%R)).
  intros n Hp.
  apply ub.
  exists n.
  unfold u.
  now destruct (HP n).
destruct (Rle_lt_dec l R0) as [Hl|Hl].
  right.
  intros n.
  destruct (HP n) as [H|H].
  exact H.
  exfalso.
  apply Rle_not_lt with (1 := Hl).
  apply Rlt_le_trans with (/ (INR n + R1))%R.
  now apply Rinv_0_lt_compat.
  now apply Hnp.
left.
set (N := Z.abs_nat (up (/l) - 2)).
assert (H1l: (R1 <= /l)%R).
  rewrite <- Rinv_1.
  apply Rinv_le_contravar with (1 := Hl).
  apply lub.
  now intros y [m ->].
assert (HN: (INR N + R1 = IZR (up (/ l)) - R1)%R).
  unfold N.
  rewrite INR_IZR_INZ.
  rewrite inj_Zabs_nat.
  replace (IZR (up (/ l)) - R1)%R with (IZR (up (/ l) - 2) + R1)%R.
  apply (f_equal (fun v => IZR v + R1)%R).
  apply Z.abs_eq.
  apply Zle_minus_le_0.
  apply (Zlt_le_succ 1).
  apply lt_IZR.
  apply Rle_lt_trans with (1 := H1l).
  apply archimed.
  rewrite minus_IZR.
  simpl.
  admit.
assert (Hl': (/ (INR (S N) + R1) < l)%R).
  rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq.
  apply Rinv_1_lt_contravar with (1 := H1l).
  rewrite S_INR.
  rewrite HN.
{
  unfold Rminus.
  rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r.
  apply archimed.
}
exists N.
intros H.
apply Rle_not_lt with (2 := Hl').
apply lub.
intros y [n ->].
unfold u.
destruct (HP n) as [_|Hp].
  apply Rlt_le.
  now apply Rinv_0_lt_compat.
apply Rinv_le_contravar.
apply Hi.
apply Rplus_le_compat_r.
apply le_INR.
destruct (le_or_lt n N) as [Hn|Hn].
  2: now apply lt_le_S.
exfalso.
destruct (le_lt_or_eq _ _ Hn) as [Hn'| ->].
2: now apply Hp.
apply Rlt_not_le with (2 := Hnp _ Hp).
rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq.
apply Rinv_1_lt_contravar.
rewrite <- S_INR.
apply (le_INR 1), le_n_S, le_0_n.
apply Rlt_le_trans with (INR N + R1)%R.
apply Rplus_lt_compat_r.
now apply lt_INR.
rewrite HN.
apply Rplus_le_reg_r with (-/l + R1)%R.
rewrite <- !Rplus_assoc.
rewrite Rplus_opp_r, Rplus_0_l.
unfold Rminus.
rewrite !Rplus_assoc.
rewrite (Rplus_comm (-R1)).
rewrite !Rplus_assoc.
rewrite Rplus_opp_r, Rplus_0_r.
apply archimed.
Admitted.

End Arithmetical_dec.

(** * Derivability of the Archimedean axiom *)

(** This is a standard proof (it has been taken from PlanetMath). It is
formulated negatively so as to avoid the need for classical
logic. Using a proof of [{n | ~P n}+{forall n, P n}], we can in
principle also derive [up] and its specification. The proof above
cannot be used for that purpose, since it relies on the [archimed] axiom. *)

Theorem not_not_archimedean :
  forall r : R, ~ (forall n : nat, (INR n <= r)%R).
Proof.
intros r H.
set (E := fun r => exists n : nat, r = INR n).
assert (exists x : R, E x) by
  (exists R0%R; simpl; red; exists 0%nat; reflexivity).
assert (bound E) by (exists r; intros x (m,H2); rewrite H2; apply H).
destruct (completeness E) as (M,(H3,H4)); try assumption.
set (M' := (M + -R1)%R).
assert (H2 : ~ is_upper_bound E M').
  intro H5.
  assert (M <= M')%R by (apply H4; exact H5).
  apply (Rlt_not_le M M').
    unfold M'.
    pattern M at 2.
    rewrite <- Rplus_0_l.
    pattern (R0 + M)%R.
    rewrite Rplus_comm.
    rewrite <- (Rplus_opp_r R1).
    apply Rplus_lt_compat_l.
    rewrite Rplus_comm.
    apply Rlt_plus_1.
  assumption.
apply H2.
intros N (n,H7).
rewrite H7.
unfold M'.
assert (H5 : (INR (S n) <= M)%R) by (apply H3; exists (S n); reflexivity).
rewrite S_INR in H5.
assert (H6 : (INR n + R1 + -R1 <= M + -R1)%R).
  apply Rplus_le_compat_r.
  assumption.
rewrite Rplus_assoc in H6.
rewrite Rplus_opp_r in H6.
rewrite (Rplus_comm (INR n) R0) in H6.
rewrite Rplus_0_l in H6.
assumption.
Qed.

(** * Decidability of negated formulas *)

Lemma sig_not_dec : forall P : Prop, {not (not P)} + {not P}.
Proof.
intros P.
set (E := fun x => x = R0 \/ (x = R1 /\ P)).
destruct (completeness E) as [x H].
  exists R1.
  intros x [->|[-> _]].
  apply Rle_0_1.
  apply Rle_refl.
  exists R0.
  now left.
destruct (Rle_lt_dec R1 x) as [H'|H'].
- left.
  intros HP.
  elim Rle_not_lt with (1 := H').
  apply Rle_lt_trans with (2 := Rlt_0_1).
  apply H.
  intros y [->|[_ Hy]].
  apply Rle_refl.
  now elim HP.
- right.
  intros HP.
  apply Rlt_not_le with (1 := H').
  apply H.
  right.
  now split.
Qed.


(** * SfLib: Software Foundations Library *)

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Export ListNotations.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

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

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
(* An exercise in Basics.v *)
Admitted.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
(* An exercise in Lists.v *)
Admitted.

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem false_beq_nat: forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
(* An exercise in Logic.v *)
Admitted.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | multi_refl  : forall (x : X),
                 multi X R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.
Implicit Arguments multi [[X]].

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  (* FILL IN HERE *) Admitted.

(**  Identifiers and polymorphic partial maps. *)

Inductive id : Type :=
  Id : nat -> id.

Theorem eq_id_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (eq_nat_dec n1 n2) as [Heq | Hneq].
   Case "n1 = n2".
     left. rewrite Heq. reflexivity.
   Case "n1 <> n2".
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x); try reflexivity.
  apply ex_falso_quodlibet; auto.
Qed.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y ->
               (if eq_id_dec x y then p else q) = q.
Proof.
  (* FILL IN HERE *) Admitted.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Notation "'\empty'" := empty.

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id; auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (eq_id_dec x2 x1)...
Qed.

(** -------------------- *)

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.


Require Import List.
Import ListNotations.

(** Monoids, represented as a class without any parameters. They are used
    by [Writer] and [WriterT]. *)
Class Monoid : Type :=
{
  carr : Type;
  neutr : carr;
  op : carr -> carr -> carr;
  id_left :
    forall x : carr, op neutr x = x;
  id_right :
    forall x : carr, op x neutr = x;
  op_assoc :
    forall x y z : carr,
      op x (op y z) = op (op x y) z
}.

Coercion carr : Monoid >-> Sortclass.

#[global] Hint Rewrite @id_left @id_right @op_assoc : CoqMTL.

(** Some instances of monoids: the initial monoid, the monoid of boolean
    values with boolean conjunction and the monoid of lists with append. *)

#[refine]
#[export]
Instance Monoid_unit : Monoid :=
{
  carr := unit;
  neutr := tt;
  op _ _ := tt
}.
Proof.
  all: try destruct x; reflexivity.
Defined.

#[refine]
#[export]
Instance Monoid_bool_andb : Monoid :=
{
  carr := bool;
  neutr := true;
  op := andb;
}.
Proof.
  all: intros; repeat
  match goal with
  | b : bool |- _ => destruct b
  end; cbn; reflexivity.
Defined.

#[refine]
#[export]
Instance Monoid_list_app (A : Type) : Monoid :=
{
  carr := list A;
  neutr := [];
  op := @app A;
}.
Proof.
  all: intros.
    reflexivity.
    rewrite app_nil_r. reflexivity.
    rewrite app_assoc. reflexivity.
Defined.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

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

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf2 : lst) (lf1 : natural) : natural :=
  len (Cons (Succ Zero) lf2).


Require Import Coq.micromega.Psatz.
Require Import Coq.Arith.Arith.

Lemma strong_induction {P: nat -> Prop}:
  (forall n, (forall m, m < n -> P m) -> P n) ->
  (forall n, P n).
Proof.
  intros ?.
  assert (forall n, (forall m, m < n -> P m)).
  + intro n; induction n.
    - intros; lia.
    - intros.
      destruct (lt_dec m n).
      * apply IHn; auto.
      * assert (m = n) by lia; subst m.
        apply H; auto.
  + intros.
    apply (H0 (S n)).
    constructor.
Qed.

Ltac strong_induction n :=
  revert dependent n;
  intro n;
  pattern n;
  revert n;
  apply strong_induction;
  intros ?n ?IH.


From Coq Require Import Arith List.

Import List Notations.

Inductive BinTree (T : Type) : Type :=
  | Leaf
  | Node (val : T) (left right : BinTree T).

Inductive RoseTree (T : Type) : Type :=
  | Empty
  | Rose (val : T) (rose : list (RoseTree T)).

Fixpoint seperateBin (T : Type) (bin : BinTree T) : list (BinTree T) :=
  match bin with
   | Node _ v l r => Node _ v (Leaf _) (Leaf _) :: seperateBin T l ++ seperateBin T r
   | _          => nil
  end.

Fixpoint binToRoseAux (T : Type) (bin : BinTree T) : list (BinTree _) :=
  match bin with
  | Node _ v l r => (Node _ v (Leaf _) (Leaf _)) :: seperateBin _ l
  | Leaf _       => nil
  end.

Fixpoint binToRose (T : Type) (binL : list (BinTree T)) : RoseTree T :=
  match binL with
  | b :: bs      => match b with
                     | Node _ v _ _ => Rose _ v (binToRose _ bs :: nil)
                     | _            => Empty _
                    end
  | nil          => Empty _
  end.

Definition sillyBin : BinTree nat := (Node _ 1 (Node _ 2 (Node _ 3 (Leaf _) (Leaf _)) (Node _ 4 (Leaf _) (Leaf _))) (Node _ 0 (Leaf _) (Leaf _))).

Compute binToRose _ (binToRoseAux _ sillyBin).


Require Import Description.

Lemma exclusive_dec: forall P Q:Prop, ~(P /\ Q) ->
  (P \/ Q) -> {P} + {Q}.
Proof.
intros.
assert ({x:bool | if x then P else Q}).
apply constructive_definite_description.
case H0.
exists true.
red; split.
assumption.
destruct x'.
reflexivity.
tauto.
exists false.
red; split.
assumption.
destruct x'.
tauto.
reflexivity.

destruct H1.
destruct x.
left.
assumption.
right.
assumption.
Qed.

Lemma decidable_dec: forall P:Prop, P \/ ~P -> {P} + {~P}.
Proof.
intros.
apply exclusive_dec.
tauto.
assumption.
Qed.

Require Import Classical.

Lemma classic_dec: forall P:Prop, {P} + {~P}.
Proof.
intro P.
apply decidable_dec.
apply classic.
Qed.


From Cat Require Import Imports Category Preorder Monoid Poset Isomorphism Terminal Dual Initial Product.
Require Import FunctionalExtensionality.

Set Universe Polymorphism.

(** Binary CoProducts *)

Class CoProduct (C: Category) (A B sum: @obj C): Type :=
{
  inl      : @arrow C sum A;
  inr      : @arrow C sum B;
  sum_f    : forall (Z: @obj C) (f: @arrow C Z A) (g: @arrow C Z B), @arrow C Z sum;
  sum_f_c1 : forall (Z: @obj C) (f: @arrow C Z A) (g: @arrow C Z B), f = sum_f Z f g o inl;
  sum_f_c2 : forall (Z: @obj C) (f: @arrow C Z A) (g: @arrow C Z B), g = sum_f Z f g o inr;
  sum_f_uni: forall (Z: @obj C) (f: @arrow C Z A) (g: @arrow C Z B) (s1 s2: @arrow C Z sum),
              f = s1 o inl -> f = s2 o inl -> g = s1 o inr -> g = s2 o inr -> s1 = s2
}.

Class hasCoProducts (C: Category): Type :=
{
  cpobj: forall (A B: @obj C), @obj C;
  hascp: forall (A B: @obj C), CoProduct C A B (cpobj A B)
}.

Lemma prod_coprod: forall (C: Category) (A B AxB: @obj C) (p: Product C A B AxB), CoProduct (DualCategory C) A B AxB.
Proof. intros C A B AxB (pi1, pi2, h, hax1, hax2, huniq).
       unshelve econstructor.
       - simpl. exact pi1.
       - simpl. exact pi2.
       - simpl. intros Z f g. exact (h Z f g).
       - simpl. intros Z f g. apply (hax1 Z f g).
       - simpl. intros Z f g. apply (hax2 Z f g).
       - simpl. intros Z f g s1 s2 Ha Hb Hc Hd.
         pose proof huniq as hhuniq.
         rewrite <- (huniq Z f g s1).
         rewrite <- (hhuniq Z f g s2); easy.
         easy.
         easy.

Qed.

Lemma coprod_prod: forall (C: Category) (A B s: @obj C) (p: CoProduct C A B s), Product (DualCategory C) A B s.
Proof. intros C A B s (inl, inr, h, hax1, hax2, huniq).
       unshelve econstructor.
       - simpl. exact inl.
       - simpl. exact inr.
       - simpl. intros Z f g. exact (h Z f g).
       - simpl. intros Z f g. apply (hax1 Z f g).
       - simpl. intros Z f g. apply (hax2 Z f g).
       - simpl. intros Z f g s1 s2 Ha.
         rewrite (huniq Z f g (h Z f g) s1); easy.
Qed.

(** TODO: Coproducts are unique up to (unique) isomorphism *)

Lemma setCoProd: forall A B: @obj SetCat, CoProduct SetCat A B (sum A B).
Proof. intros.
       unshelve econstructor.
       - simpl. intros a. exact (@Datatypes.inl A B a).
       - simpl. intros b. exact (@Datatypes.inr A B b).
       - simpl. intros Z f g z.
         destruct z as [a | b].
         + exact (f a).
         + exact (g b).
       - simpl. intros Z f g. easy.
       - simpl. intros Z f g. easy.
       - simpl. intros Z f g s1 s2 H1 H2 H3 H4.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H1) as Hax1';
         cbv beta in Hax1'.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H2) as Hax2';
         cbv beta in Hax2'.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H3) as Hax3';
         cbv beta in Hax3'.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H4) as Hax4';
         cbv beta in Hax4'.
         apply functional_extensionality.
         intros [a | b].
         + specialize (Hax1' a).
           specialize (Hax2' a).
           rewrite <- Hax1', <- Hax2'. reflexivity.
         + specialize (Hax3' b).
           specialize (Hax4' b).
           rewrite <- Hax3', <- Hax4'.
           reflexivity.
Defined.


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

Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
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 eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

  Fixpoint mem  (mem_arg1 : lst) (mem_arg0 : natural)
  := match mem_arg0, mem_arg1 with
    | x, Nil => false
    | x, Cons y z => orb (eqb x y) (mem z x)
    end.

    Definition lst_mem (lst_mem_arg0 : natural) (lst_mem_arg1 : lst) : bool
    := match lst_mem_arg0, lst_mem_arg1 with
       | n, x => mem x n
       end.

  Fixpoint lst_union (lst_union_arg0 : lst) (lst_union_arg1 : lst) : lst
  := match lst_union_arg0, lst_union_arg1 with
     | Nil, x => x
     | Cons n x, y => if lst_mem n y then lst_union x y else Cons n (lst_union x y)
     end.

Lemma Nat_beq_eq : forall (x y : natural), eqb x y = true -> x = y.
Proof.
   intros.
   generalize dependent y.
   induction x.
   - intros. destruct y.
   + simpl in H. apply IHx in H. rewrite H. reflexivity.
   + discriminate.
   - intros. destruct y.
   + discriminate.
   + reflexivity.
Qed.

Lemma mem_union : forall (x : natural) (y z : lst), lst_mem x y = true -> lst_mem x (lst_union z y) = true.
Proof.
   intros.
   induction z.
   - simpl. destruct (lst_mem n y).
   + assumption.
   + simpl. rewrite IHz. apply Bool.orb_true_r.
   - assumption.
Qed.

Theorem theorem0 : forall (x : natural) (y : lst) (z : lst), eq (lst_mem x y) true -> eq (lst_mem x (lst_union y z)) true.
Proof.
   intros.
   induction y.
   - simpl in H. apply Bool.orb_prop in H. destruct H.
   + simpl. destruct (lst_mem n z) eqn:?.
      *
lfind.
Admitted.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(***********************************************************************
      Cyclic.v

      Proof that an abelien ring is cyclic
 ************************************************************************)
Require Import ZCAux.
Require Import List.
Require Import Root.
Require Import UList.
Require Import IGroup.
Require Import EGroup.
Require Import FGroup.

Open Scope Z_scope.

Section Cyclic.

Variable A: Set.
Variable plus mult: A -> A -> A.
Variable op: A -> A.
Variable zero one: A.
Variable support: list A.
Variable e: A.

Hypothesis A_dec: forall a b: A, {a = b} + {a <> b}.
Hypothesis e_not_zero: zero <> e.
Hypothesis support_ulist: ulist support.
Hypothesis e_in_support: In e support.
Hypothesis zero_in_support: In zero support.
Hypothesis mult_internal: forall a b, In a support -> In b support -> In (mult a b) support.
Hypothesis mult_assoc: forall a b c, In a support -> In b support -> In c support -> mult a (mult b c) = mult (mult a b) c.
Hypothesis e_is_zero_l:  forall a, In a support ->  mult e a = a.
Hypothesis e_is_zero_r:  forall a, In a support ->  mult a e = a.
Hypothesis plus_internal: forall a b, In a support -> In b support -> In (plus a b) support.
Hypothesis plus_zero: forall a, In a support -> plus zero a = a.
Hypothesis plus_comm: forall a b, In a support -> In b support -> plus a b = plus b a.
Hypothesis plus_assoc: forall a b c, In a support -> In b support -> In c support -> plus a (plus b c) = plus (plus a b) c.
Hypothesis mult_zero: forall a, In a support -> mult zero a = zero.
Hypothesis mult_comm: forall a b, In a support -> In b support ->mult a b = mult b a.
Hypothesis mult_plus_distr: forall a b c, In a support -> In b support -> In c support -> mult a (plus b c) = plus (mult a b) (mult a c).
Hypothesis op_internal: forall a, In a support -> In (op a) support.
Hypothesis plus_op_zero: forall a, In a support -> plus a (op a) = zero.
Hypothesis mult_integral: forall a b, In a support -> In b support -> mult a b = zero -> a = zero \/ b = zero.

Definition IA := (IGroup A mult support e A_dec support_ulist e_in_support mult_internal
                             mult_assoc
                             e_is_zero_l e_is_zero_r).

Hint Resolve (fun x => isupport_incl _ mult support e A_dec x).

Theorem gpow_evaln: forall n, 0 < n ->
  exists p, (length p <=  Zabs_nat n)%nat /\  (forall i, In i p -> In i support) /\
  forall x, In x IA.(s) -> eval A plus mult zero (zero::p) x = gpow x IA n.
intros n Hn; generalize Hn; pattern n; apply natlike_ind; auto with zarith.
intros H1; contradict H1; auto with zarith.
intros x Hx Rec _.
case Zle_lt_or_eq with (1 := Hx); clear Hx; intros Hx; subst; simpl.
case Rec; auto; simpl; intros p (Hp1, (Hp2, Hp3)); clear Rec.
exists (zero::p); split; simpl.
rewrite Zabs_nat_Zsucc; auto with arith zarith.
split.
intros i [Hi | Hi]; try rewrite <- Hi; auto.
intros x1 Hx1; simpl.
rewrite Hp3; repeat rewrite plus_zero; unfold Zsucc; try rewrite gpow_add; auto with zarith.
rewrite gpow_1; try apply mult_comm; auto.
apply  (fun x => isupport_incl _ mult support e A_dec x); auto.
change (In (gpow x1 IA x) IA.(s)).
apply gpow_in; auto.
apply mult_internal; auto.
apply  (fun x => isupport_incl _ mult support e A_dec x); auto.
change (In (gpow x1 IA x) IA.(s)).
apply gpow_in; auto.
exists (e:: nil); split; simpl.
compute; auto with arith.
split.
intros i [Hi | Hi]; try rewrite <- Hi; auto; case Hi.
intros x Hx; simpl.
rewrite plus_zero; rewrite (fun x => mult_comm x zero); try rewrite mult_zero; auto.
rewrite plus_comm; try rewrite plus_zero; auto.
Qed.

Definition check_list_gpow: forall l n, (incl l IA.(s)) -> {forall a, In a l -> gpow a IA n = e} + {exists a, In a l /\  gpow a IA n <> e}.
intros l n; elim l; simpl; auto.
intros H; left; intros a H1; case H1.
intros a l1 Rec H.
case (A_dec (gpow a IA n) e); intros H2.
case Rec; try intros H3.
apply incl_tran with (2 := H); auto with datatypes.
left; intros a1 H4; case H4; auto.
intros H5; rewrite <- H5; auto.
right; case H3; clear H3; intros a1 (H3, H4).
exists a1; auto.
right; exists a; auto.
Defined.

Theorem prime_power_div: forall p q i, prime p -> 0 <= q -> 0 <= i -> (q | p ^ i)  -> exists j, 0 <= j <= i /\ q = p ^ j.
intros p q i Hp Hq Hi H.
assert (Hp1: 0 < p).
apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
pattern q; apply prime_div_induction with (p ^ i); auto with zarith.
exists 0; rewrite Zpower_0_r; auto with zarith.
intros p1 i1 Hp2 Hi1 H1.
case Zle_lt_or_eq with (1 := Hi1); clear Hi1; intros Hi1; subst.
assert (Heq: p1 = p).
apply prime_div_Zpower_prime with i; auto.
apply Zdivide_trans with (2 := H1).
apply Zpower_divide; auto with zarith.
exists i1; split; auto; try split; auto with zarith.
case (Zle_or_lt i1 i); auto; intros H2.
absurd (p1 ^ i1 <= p  ^ i).
apply Zlt_not_le; rewrite Heq; apply Zpower_lt_monotone; auto with zarith.
apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
apply Zdivide_le; auto with zarith.
rewrite Heq; auto.
exists 0; repeat rewrite Zpower_exp_0; auto with zarith.
intros p1 q1 Hpq (j1,((Hj1, Hj2), Hj3)) (j2, ((Hj4, Hj5), Hj6)).
case Zle_lt_or_eq with (1 := Hj1); clear Hj1; intros Hj1; subst.
case Zle_lt_or_eq with (1 := Hj4); clear Hj4; intros Hj4; subst.
inversion Hpq as [ H0 H1 H2].
absurd (p | 1).
intros H3; absurd (1 < p).
apply Zle_not_lt; apply Zdivide_le; auto with zarith.
apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
apply H2; apply Zpower_divide; auto with zarith.
exists j1; rewrite Zpower_0_r; auto with zarith.
exists j2; rewrite Zpower_0_r; auto with zarith.
Qed.

Theorem inj_lt_inv: forall n m : nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat.
intros n m H; case (le_or_lt m n); auto; intros H1; contradict H.
apply Zle_not_lt; apply inj_le; auto.
Qed.

Theorem not_all_solutions: forall i, 0 < i < g_order IA -> exists a, In a IA.(s) /\ gpow a IA i <> e.
intros i (Hi, Hi2).
case (check_list_gpow IA.(s) i); try intros H; auto with datatypes.
case (gpow_evaln i); auto; intros p (Hp1, (Hp2, Hp3)).
absurd ((op e) = zero).
intros H1; case e_not_zero.
rewrite <- (plus_op_zero e); try rewrite H1; auto.
rewrite plus_comm; auto.
apply (root_max_is_zero _ (fun x => In x support) plus mult op zero) with (l := IA.(s)) (p := op e :: p); auto with datatypes.
simpl; intros x [Hx | Hx]; try rewrite <- Hx; auto.
intros x Hx.
generalize (Hp3 _ Hx); simpl; rewrite plus_zero; auto.
intros tmp; rewrite tmp; clear tmp.
rewrite H; auto; rewrite plus_comm; auto with datatypes.
apply mult_internal; auto.
apply eval_P; auto.
simpl; apply lt_le_S; apply le_lt_trans with (1 := Hp1).
apply inj_lt_inv.
rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
Qed.

Theorem divide_g_order_e_order: forall n, 0 <= n -> (n | g_order IA) -> exists a, In a IA.(s) /\ e_order A_dec  a IA = n.
intros n Hn H.
assert (Hg: 0 < g_order IA).
apply g_order_pos.
assert (He: forall a, 0 <= e_order A_dec a IA).
intros a; apply Zlt_le_weak; apply e_order_pos.
pattern n; apply prime_div_induction with (n := g_order IA); auto.
exists e; split; auto.
apply IA.(e_in_s).
apply Zle_antisym.
apply Zdivide_le; auto with zarith.
apply e_order_divide_gpow; auto with zarith.
apply IA.(e_in_s).
rewrite gpow_1; auto.
apply IA.(e_in_s).
match goal with |- (_ <= ?X) => assert (0 < X) end; try apply e_order_pos; auto with zarith.
intros p i Hp Hi K.
assert (Hp1: 0 < p).
apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
assert (Hi1: 0 < p ^ i).
apply Zpower_gt_0; auto.
case Zle_lt_or_eq with (1 := Hi); clear Hi; intros Hi; subst.
case (not_all_solutions (g_order IA / p)).
apply Zdivide_Zdiv_lt_pos; auto with zarith.
apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
apply Zdivide_trans with (2 := K).
apply Zpower_divide; auto.
intros a (Ha1, Ha2).
exists (gpow a IA (g_order IA  / p ^ i)); split.
apply gpow_in; auto.
match goal with |- ?X = ?Y => assert (H1: (X | Y) ) end; auto.
apply e_order_divide_gpow; auto with zarith.
apply gpow_in; auto.
rewrite <- gpow_gpow; auto with zarith.
rewrite Zmult_comm; rewrite <- Zdivide_Zdiv_eq; auto with zarith.
apply fermat_gen; auto.
apply Z_div_pos; auto with zarith.
case prime_power_div with (4 := H1); auto with zarith.
intros j ((Hj1, Hj2), Hj3).
case Zle_lt_or_eq with (1 := Hj2); intros Hj4; subst; auto.
case Ha2.
replace (g_order IA) with (((g_order IA / p ^i) * p ^ j) * p ^ (i - j - 1) * p).
rewrite Z_div_mult; auto with zarith.
repeat rewrite gpow_gpow; auto with zarith.
rewrite <- Hj3.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto.
apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith.
apply gpow_in; auto.
apply Z_div_pos; auto with zarith.
apply Zmult_le_0_compat; try apply Z_div_pos; auto with zarith.
pattern p at 4; rewrite <- Zpower_1_r.
repeat rewrite <- Zmult_assoc; repeat rewrite <- Zpower_exp; auto with zarith.
replace (j + (i - j - 1 + 1)) with i; auto with zarith.
apply sym_equal; rewrite Zmult_comm; apply Zdivide_Zdiv_eq; auto with zarith.
rewrite Zpower_0_r; exists e; split.
apply IA.(e_in_s).
match goal with |- ?X = 1 => assert (tmp: 0 < X); try apply e_order_pos;
case Zle_lt_or_eq with 1 X; auto with zarith; clear tmp; intros H1 end.
absurd (gpow IA.(FGroup.e) IA 1 = IA.(FGroup.e)).
apply gpow_e_order_lt_is_not_e with A_dec; auto with zarith.
apply gpow_e; auto with zarith.
intros p q H1 (a, (Ha1, Ha2)) (b, (Hb1, Hb2)).
exists (mult a b); split.
apply IA.(internal); auto.
rewrite <- Ha2; rewrite <- Hb2; apply order_mult; auto.
rewrite Ha2; rewrite Hb2; auto.
Qed.

Set Implicit Arguments.
Definition cyclic (A: Set) A_dec (op: A -> A -> A) (G: FGroup op):= exists a, In a G.(s) /\ e_order A_dec a G = g_order G.
Unset Implicit Arguments.

Theorem cyclic_field: cyclic A_dec IA.
red; apply divide_g_order_e_order; auto.
apply Zlt_le_weak; apply g_order_pos.
exists 1; ring.
Qed.

End Cyclic.


Require Import Ascii.
Require Import Nat.
Require Import BinNat.
Require Import Decimal.
Require Import DecimalString.
Require Import List.
Require Import String.
Import ListNotations.
Local Open Scope string_scope.

Definition str : string := "1000
2000
3000

4000

5000
6000

7000
8000
9000

10000".

Fixpoint split_on (sep: ascii) (accum : string) (s : string) {struct s} : list string :=
    match s with
    | EmptyString => [accum]
    | String h t => match Ascii.compare h sep with
        | Eq => [accum] ++ split_on sep "" t
        | _ => split_on sep (accum ++ String h EmptyString) t
        end
    end.

Fixpoint split_on_string (sep: string) (accum : list string) (s : list string) {struct s} : list (list string) :=
    match s with
    | [] => [accum]
    | h::t => match String.compare h sep with
        | Eq => [accum] ++ split_on_string sep [] t
        | _ => split_on_string sep (accum ++ [h]) t
        end
    end.

Definition newline : ascii := "010".

Definition strings_to_counts (s : string) : list (list N) :=
    map (fun x => map (fun y => match NilEmpty.uint_of_string y with
                                | Some z => N.of_uint z
                                | None => 0%N
                                end)
                        x)
        (split_on_string "" [] (split_on newline "" s)).

Definition Nlist_sum l := fold_right Nplus 0%N l.
Definition Nlist_max l := fold_right N.max 0%N l.

Definition calories s := Nlist_max (map Nlist_sum (strings_to_counts s)).


Add LoadPath "coq/playground".
Require Import Ornamental.Ornaments.

Set DEVOID search prove equivalence.
Set DEVOID lift type.

(* --- 9/17: Playing with a Reviewer A example --- *)

Inductive I :=
| A : I
| B : I.

Module Old'.

Definition and (i1 i2 : I) : I :=
  match i1 with
  | A => i2
  | B => B
  end.

Definition or (i1 i2 : I) : I :=
  match i1 with
  | A => A
  | B => i2
  end.

Definition neg (i : I) : I :=
  match i with
  | A => B
  | B => A
  end.

Theorem demorgan_1:
  forall (i1 i2 : I),
    neg (and i1 i2) =
    or (neg i1) (neg i2).
Proof.
  intros i1 i2. induction i1; auto.
Defined.

Theorem demorgan_2:
  forall (i1 i2 : I),
    neg (or i1 i2) =
    and (neg i1) (neg i2).
Proof.
  intros i1 i2. induction i1; auto.
Defined.

End Old'.

Preprocess Module Old' as Old { opaque I_ind }.
Import Old.

(* We will change the type to this: *)
Inductive J :=
| makeJ : bool -> J.

(* --- Configuration ---*)

(*
 * This example uses manual configuration. Many of the examples we see later will
 * do this part automatically! The exact meaning of this will be explained
 * later. But essentially, this tells the tool which constructor maps to true
 * and which maps to false:
 *)
Definition dep_constr_I_0 : I := A.
Definition dep_constr_I_1 : I := B.

Definition dep_constr_J_0 : J := makeJ true.
Definition dep_constr_J_1 : J := makeJ false.

(*
 * How to eta-expand I and J (trivial here):
 *)
Definition eta_I (i : I) : I := i.
Definition eta_J (j : J) : J := j.

(*
 * How to map between eliminators:
 *)
Definition dep_elim_I P f0 f1 i : P (eta_I i) :=
  I_rect P f0 f1 i.

Definition dep_elim_J P f0 f1 j : P (eta_J j) :=
  J_rect P (fun b => bool_rect _ f0 f1 b) j.

(*
 * And how to reduce inductive cases of eliminators, which here is trivial since
 * there are no inductive cases of these types:
 *)
Definition iota_I_0 (P : I -> Type) (f0 : P A) (f1 : P B) (Q : P A -> Type) (H : Q f0) :=
  H.

Definition iota_I_1 (P : I -> Type) (f0 : P A) (f1 : P B) (Q : P B -> Type) (H : Q f1) :=
  H.

Definition iota_J_0 (P : J -> Type) (f0 : P (makeJ true)) (f1 : P (makeJ false)) (Q : P (makeJ true) -> Type) (H : Q f0) :=
  H.

Definition iota_J_1 (P : J -> Type) (f0 : P (makeJ true)) (f1 : P (makeJ false)) (Q : P (makeJ false) -> Type) (H : Q f1) :=
  H.

(* --- Equivalence --- *)

(*
 * Automatic configuration also does this part automatically,
 * but here we used manual configuration.
 *
 * For now, manual configuration doesn't construct the
 * equivalence, so you need to construct it yourself.
 * A bit silly! Should fix this soon. After all,
 * it's a really simple algorithm. Our two functions
 * eliminate over one type and construct the other:
 *)
Definition f (i : I) : J :=
  dep_elim_I (fun _ => J) dep_constr_J_0 dep_constr_J_1 i.

Definition g (j : J) : I :=
  dep_elim_J (fun _ => I) dep_constr_I_0 dep_constr_I_1 j.

(*
 * And our two proofs eliminate over one type and reduce using the iota reduction rules:
 *)
Definition section (i : I) : g (f i) = i :=
  dep_elim_I
    (fun i => g (f i) = i)
    (iota_I_0 (fun _ => J) dep_constr_J_0 dep_constr_J_1 (fun j => g j = g dep_constr_J_0) eq_refl)
    (iota_I_1 (fun _ => J) dep_constr_J_0 dep_constr_J_1 (fun j => g j = g dep_constr_J_1) eq_refl)
    i.

Definition retraction (j : J) : f (g j) = j :=
  dep_elim_J
    (fun j => f (g j) = j)
    (iota_J_0 (fun _ => I) dep_constr_I_0 dep_constr_I_1 (fun i => f i = f dep_constr_I_0) eq_refl)
    (iota_J_1 (fun _ => I) dep_constr_I_0 dep_constr_I_1 (fun i => f i = f dep_constr_I_1) eq_refl)
    j.

(* --- Saving the configuration and equivalence --- *)

(*
 * Then we just save that:
 *)
Save equivalence I J { promote = f; forget = g }.

Configure Lift I J {
  constrs_a = dep_constr_I_0 dep_constr_I_1;
  constrs_b = dep_constr_J_0 dep_constr_J_1;
  elim_a = dep_elim_I;
  elim_b = dep_elim_J;
  eta_a = eta_I;
  eta_b = eta_J;
  iota_a = iota_I_0 iota_I_1;
  iota_b = iota_J_0 iota_J_1
}.

(* --- Repairing the functions and proofs --- *)

(*
 * Now we repair the module:
 *)
Repair Module I J in Old as New { hint "auto" }.

(*
 * Our functions behave the same way, but are defined over J instead of I:
 *)
Print New.and.
Lemma and_OK:
  forall (j1 j2 : J),
    New.and j1 j2 = f (Old.and (g j1) (g j2)).
Proof.
  intros. induction j1. induction b; auto.
  simpl. rewrite retraction. auto.
Defined.

Print New.or.
Lemma or_OK:
  forall (j1 j2 : J),
    New.or j1 j2 = f (Old.or (g j1) (g j2)).
Proof.
  intros. induction j1. induction b; auto.
  simpl. rewrite retraction. auto.
Defined.

Print New.neg.
Lemma neg_OK:
  forall (j : J),
    New.neg j = f (Old.neg (g j)).
Proof.
  intros. induction j. induction b; auto.
Defined.

(*
 * And our proofs still hold:
 *)
Check New.demorgan_1.
Check New.demorgan_2.

(* --- Using suggested tactics --- *)

(*
 * Let's use the suggested tactics from Repair (up to renaming):
 *)
Theorem demorgan_1:
  forall j1 j2 : J,
    New.neg (New.and j1 j2) = New.or (New.neg j1) (New.neg j2).
Proof.
  intros j1 j2. induction j1 as [b].
  induction b as [ | ]; auto.
Defined.

Theorem demorgan_2:
  forall j1 j2 : J,
    New.neg (New.or j1 j2) = New.and (New.neg j1) (New.neg j2).
Proof.
  intros j1 j2. induction j1 as [b].
  induction b as [ | ]; auto.
Defined.

(* --- Manual effort --- *)

(*
 * How hard is this to do manually?
 * (Using pattern matching even though the tool uses eliminators.)
 * Start time: 18:05
 * End time: 18:13
 * So we get 8 minutes of savings, but with a small overhead of writing the
 * configuration above.
 *)
Definition and' (i1 i2 : J) : J :=
  match i1 with
  | makeJ true => i2
  | makeJ false => makeJ false
  end.

Definition or' (i1 i2 : J) : J :=
  match i1 with
  | makeJ true => makeJ true
  | makeJ false => i2
  end.

Definition neg' (i : J) : J :=
  match i with
  | makeJ true => makeJ false
  | makeJ false => makeJ true
  end.

Theorem demorgan_1':
  forall (i1 i2 : J),
    neg' (and' i1 i2) =
    or' (neg' i1) (neg' i2).
Proof.
  intros i1 i2. induction i1; auto.
  induction b; auto.
Defined.

Theorem demorgan_2':
  forall (i1 i2 : J),
    neg' (or' i1 i2) =
    and' (neg' i1) (neg' i2).
Proof.
  intros i1 i2. induction i1; auto.
  induction b; auto.
Defined.

(* --- Note on opposite direction ---*)

(*
 * In the opposite direction, we can used cached terms,
 * but if we want to get around matching problems entirely,
 * we can just define a different configuration with the
 * natural eliminator for J.
 *)


Require Export prosa.model.priority.classes.

(** * FIFO Priority Policy *)

(** We define the basic FIFO priority policy, under which jobs are prioritized
    in order of their arrival times. The FIFO policy belongs to the class of
    JLFP policies. *)
Instance FIFO (Job : JobType) `{JobArrival Job} : JLFP_policy Job :=
{
  hep_job (j1 j2 : Job) := job_arrival j1 <= job_arrival j2
}.

(** In this section, we prove a few basic properties of the FIFO policy. *)
Section Properties.

  (**  Consider any type of jobs with arrival times. *)
  Context {Job : JobType}.
  Context `{JobArrival Job}.

  (** FIFO is reflexive. *)
  Lemma FIFO_is_reflexive : reflexive_priorities.
  Proof.  by intros t j; unfold hep_job_at, JLFP_to_JLDP, hep_job, FIFO. Qed.

  (** FIFO is transitive. *)
  Lemma FIFO_is_transitive : transitive_priorities.
  Proof. by intros t y x z; apply leq_trans. Qed.

  (** FIFO is total. *)
  Lemma FIFO_is_total : total_priorities.
  Proof. by move=> t j1 j2; apply leq_total. Qed.

End Properties.

(** We add the above lemmas into a "Hint Database" basic_facts, so Coq
    will be able to apply them automatically. *)
Hint Resolve
     FIFO_is_reflexive
     FIFO_is_transitive
     FIFO_is_total
  : basic_facts.