Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Pow2.
Require Import Crypto.Util.ZUtil.Log2.
Require Import Crypto.Util.ZUtil.Tactics.PeelLe.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Tactics.LinearSubstitute.
Require Import Crypto.Util.ZUtil.Tactics.SplitMinMax.
Require Import Crypto.Util.ZUtil.Modulo.PullPush.
Require Import Crypto.Util.ZUtil.LandLorShiftBounds.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Ones.
Require Import Crypto.Util.ZUtil.Lnot.
Require Import Crypto.Util.ZUtil.Land.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Local Open Scope Z_scope.

Module Z.
  Lemma round_lor_land_bound_bounds x
  : (0 <= x <= Z.round_lor_land_bound x) \/ (Z.round_lor_land_bound x <= x <= -1).
  Proof.
    cbv [Z.round_lor_land_bound]; break_innermost_match; Z.ltb_to_lt.
    all: constructor; split; try lia; [].
    all: Z.replace_all_neg_with_pos.
    all: match goal with |- context[2^Z.log2_up ?x] => pose proof (Z.log2_up_le_full x) end.
    all: lia.
  Qed.
#[global]
  Hint Resolve round_lor_land_bound_bounds : zarith.

  Lemma round_lor_land_bound_bounds_pos x
  : (0 <= Z.pos x <= Z.round_lor_land_bound (Z.pos x)).
  Proof. generalize (round_lor_land_bound_bounds (Z.pos x)); lia. Qed.
#[global]
  Hint Resolve round_lor_land_bound_bounds_pos : zarith.

  Lemma round_lor_land_bound_bounds_neg x
  : Z.round_lor_land_bound (Z.neg x) <= Z.neg x <= -1.
  Proof. generalize (round_lor_land_bound_bounds (Z.neg x)); lia. Qed.
#[global]
  Hint Resolve round_lor_land_bound_bounds_neg : zarith.

  Local Ltac saturate :=
    repeat first [ progress cbv [Z.round_lor_land_bound Proper respectful Basics.flip] in *
                 | progress Z.ltb_to_lt
                 | progress intros
                 | break_innermost_match_step
                 | lia
                 | rewrite !Pos2Z.opp_neg
                 | match goal with
                   | [ |- context[Z.log2_up ?x] ]
                     => unique pose proof (Z.log2_up_nonneg x)
                   | [ |- context[2^?x] ]
                     => unique assert (0 <= 2^x) by (apply Z.pow_nonneg; lia)
                   | [ H : 0 <= ?x |- context[2^?x] ]
                     => unique assert (0 < 2^x) by (apply Z.pow_pos_nonneg; lia)
                   | [ H : Pos.le ?x ?y |- context[Z.pos ?x] ]
                     => unique assert (Z.pos x <= Z.pos y) by lia
                   | [ H : Pos.le ?x ?y |- context[Z.pos (?x+1)] ]
                     => unique assert (Z.pos (x+1) <= Z.pos (y+1)) by lia
                   | [ H : Z.le ?x ?y |- context[?x+1] ]
                     => unique assert (x+1 <= y+1) by lia
                   | [ H : Z.le ?x ?y |- context[2^Z.log2_up ?x] ]
                     => unique assert (2^Z.log2_up x <= 2^Z.log2_up y) by (Z.peel_le; lia)
                   | [ H : ?a^?b <= ?a^?c |- _ ]
                     => unique assert (a^(c-b) = a^c/a^b) by auto with zarith;
                       unique assert (a^c mod a^b = 0) by auto with zarith
                   end ].
  Local Ltac do_rewrites_step :=
    match goal with
    | [ |- ?R ?x ?x ] => reflexivity
    (*| [ |- context[Z.land (-2^_) (-2^_)] ]
      => rewrite <- !Z.lnot_ones_equiv, <- !Z.lnot_lor, !Z.lor_ones_ones, !Z.lnot_ones_equiv
    | [ |- context[Z.lor (-2^_) (-2^_)] ]
      => rewrite <- !Z.lnot_ones_equiv, <- !Z.lnot_land, !Z.land_ones_ones, !Z.lnot_ones_equiv
    | [ |- context[Z.land (2^_-1) (2^_-1)] ]
      => rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.land_ones_ones, !Z.ones_equiv, <- !Z.sub_1_r
    | [ |- context[Z.lor (2^_-1) (2^_-1)] ]
      => rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.lor_ones_ones, !Z.ones_equiv, <- !Z.sub_1_r
    | [ |- context[Z.land (2^?x-1) (-2^?y)] ]
      => rewrite (@Z.land_comm (2^x-1) (-2^y))
    | [ |- context[Z.lor (2^?x-1) (-2^?y)] ]
      => rewrite (@Z.lor_comm (2^x-1) (-2^y))
    | [ |- context[Z.land (-2^_) (2^_-1)] ]
      => rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.land_ones, ?Z.ones_equiv, <- ?Z.sub_1_r by lia
    | [ |- context[Z.lor (-2^?x) (2^?y-1)] ]
      => rewrite <- !Z.lnot_ones_equiv, <- (Z.lnot_involutive (2^y-1)), <- !Z.lnot_land, ?Z.lnot_ones_equiv, (Z.lnot_sub1 (2^y)), !Z.ones_equiv, ?Z.lnot_equiv, <- !Z.sub_1_r
    | [ |- context[-?x mod ?y] ]
      => rewrite (@Z.opp_mod_mod_push x y) by Z.NoZMod*)
    | [ |- context[Z.land (2^?y-1) ?x] ]
      => is_var x; rewrite (Z.land_comm (2^y-1) x)
    | [ |- context[Z.lor (2^?y-1) ?x] ]
      => is_var x; rewrite (Z.lor_comm (2^y-1) x)
    | [ |- context[Z.land (-2^?y) ?x] ]
      => is_var x; rewrite (Z.land_comm (-2^y) x)
    | [ |- context[Z.lor (-2^?y) ?x] ]
      => is_var x; rewrite (Z.lor_comm (-2^y) x)
    | [ |- context[Z.land _ (2^_-1)] ]
      => rewrite !Z.sub_1_r, <- !Z.ones_equiv, !Z.land_ones by auto with zarith
    | [ |- context[Z.land ?x (-2^?y)] ]
      => is_var x;
        rewrite <- !Z.lnot_ones_equiv, <- (Z.lnot_involutive x), <- !Z.lnot_lor, !Z.ones_equiv, !Z.lnot_equiv, <- !Z.sub_1_r;
        let x' := fresh in
        remember (-x-1) as x' eqn:?; Z.linear_substitute x;
        rename x' into x
    | [ |- context[Z.lor ?x (-2^?y)] ]
      => is_var x;
        rewrite <- !Z.lnot_ones_equiv, <- (Z.lnot_involutive x), <- !Z.lnot_land, !Z.ones_equiv, !Z.lnot_equiv, <- !Z.sub_1_r;
        let x' := fresh in
        remember (-x-1) as x' eqn:?; Z.linear_substitute x;
        rename x' into x
    | [ |- Z.lor ?x (?y-1) <= Z.lor ?x (?y'-1) ]
      => rewrite (Z.div_mod'' (Z.lor x (y-1)) y), (Z.div_mod'' (Z.lor x (y'-1)) y') by auto with zarith
    | [ |- Z.lor ?x (?y-1) = _ ]
      => rewrite (Z.div_mod'' (Z.lor x (y-1)) y) by auto with zarith
    | [ |- context[?m1 - 1 + (?x - ?x mod ?m1)] ]
      => replace (m1 - 1 + (x - x mod m1)) with ((m1 - x mod m1) + (x - 1)) by lia
    | _ => progress rewrite ?Z.lor_pow2_div_pow2_r, ?Z.lor_pow2_div_pow2_l, ?Z.lor_pow2_mod_pow2_r, ?Z.lor_pow2_mod_pow2_l by auto with zarith
    | _ => rewrite !Z.mul_div_eq by lia
    | _ => progress rewrite ?(Z.add_comm 1) in *
    | [ |- context[?x mod 2^(Z.log2_up (?x + 1))] ]
      => rewrite (Z.mod_small x (2^Z.log2_up (x+1))) by (rewrite <- Z.le_succ_l, <- Z.add_1_r, Z.log2_up_le_pow2 by lia; lia)
    | [ H : ?a^?b <= ?a^?c |- context[?x mod ?a^?b] ]
      => rewrite (@Z.mod_pow_r_split x a b c) by auto with zarith;
        (Z.div_mod_to_quot_rem; nia)
    | _ => progress Z.peel_le
    (*| [ H : ?x <= ?x |- _ ] => clear H
    | [ H : ?x < ?y, H' : ?y <= ?z |- _ ] => unique assert (x < z) by lia
    | [ H : ?x < ?y, H' : ?a <= ?x |- _ ] => unique assert (a < y) by lia
    | [ H : 2^?x < 2^?y |- context[2^?x mod 2^?y] ]
      => repeat first [ rewrite (Z.mod_small (2^x) (2^y)) by lia
                      | rewrite !(@Z_mod_nz_opp_full (2^x) (2^y)) ]
    | [ H : ?x < ?y, H' : context[?x mod ?y] |- _ ] => rewrite (Z.mod_small x y) in H' by lia
    | [ |- context[2^?x mod 2^?y] ]
      => let H := fresh in
         destruct (@Z.pow2_lt_or_divides x y ltac:(lia)) as [H|H];
         [ repeat first [ rewrite (Z.mod_small (2^x) (2^y)) by lia
                        | rewrite !(@Z_mod_nz_opp_full (2^x) (2^y)) ]
         | rewrite H ]*)
    | _ => progress autorewrite with zsimplify_fast in *
    | [ |- context[-(-?x-1)] ] => replace (-(-x-1)) with (1+x) by lia
    | [ H : 0 > -(1+?x) |- _ ] => assert (0 <= x) by (clear -H; lia); clear H
    | [ H : 0 > -(?x+1) |- _ ] => assert (0 <= x) by (clear -H; lia); clear H
    | [ |- ?a - ?b = ?a' - ?b' ] => apply f_equal2; try reflexivity; []
    | [ |- -?a = -?a' ] => apply f_equal
    | _ => rewrite <- !Z.sub_1_r
    | _ => lia
    end.
  Local Ltac do_rewrites := repeat do_rewrites_step.
  Local Ltac fin_t :=
    repeat first [ progress destruct_head'_and
                 | match goal with
                   | [ H : orb _ _ = _ |- _ ]
                     => progress rewrite ?Bool.orb_true_iff, ?Bool.orb_false_iff, ?Z.ltb_lt, ?Z.ltb_ge in *
                   end
                 | break_innermost_match_step
                 | progress destruct_head'_or
                 | lia
                 | progress Z.peel_le ].
  Local Ltac t :=
    saturate; do_rewrites.

  Local Instance land_round_Proper_pos_r x
    : Proper (Pos.le ==> Z.le) (fun y => Z.land x (Z.round_lor_land_bound (Z.pos y))).
  Proof. t. Qed.

  Local Instance land_round_Proper_pos_l y
    : Proper (Pos.le ==> Z.le) (fun x => Z.land (Z.round_lor_land_bound (Z.pos x)) y).
  Proof. t. Qed.

  Local Instance lor_round_Proper_pos_r x
    : Proper (Pos.le ==> Z.le) (fun y => Z.lor x (Z.round_lor_land_bound (Z.pos y))).
  Proof. t. Qed.

  Local Instance lor_round_Proper_pos_l y
    : Proper (Pos.le ==> Z.le) (fun x => Z.lor (Z.round_lor_land_bound (Z.pos x)) y).
  Proof. t. Qed.

  Local Instance land_round_Proper_neg_r x
    : Proper (Basics.flip Pos.le ==> Z.le) (fun y => Z.land x (Z.round_lor_land_bound (Z.neg y))).
  Proof. t. Qed.

  Local Instance land_round_Proper_neg_l y
    : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.land (Z.round_lor_land_bound (Z.neg x)) y).
  Proof. t. Qed.

  Local Instance lor_round_Proper_neg_r x
    : Proper (Basics.flip Pos.le ==> Z.le) (fun y => Z.lor x (Z.round_lor_land_bound (Z.neg y))).
  Proof. t. Qed.

  Local Instance lor_round_Proper_neg_l y
    : Proper (Basics.flip Pos.le ==> Z.le) (fun x => Z.lor (Z.round_lor_land_bound (Z.neg x)) y).
  Proof. t. Qed.

  Lemma land_round_lor_land_bound_r x
    : Z.land x (Z.round_lor_land_bound x) = if (0 <=? x) then x else Z.round_lor_land_bound x.
  Proof. t. Qed.
#[global]
  Hint Rewrite land_round_lor_land_bound_r : zsimplify_fast zsimplify.
  Lemma land_round_lor_land_bound_l x
    : Z.land (Z.round_lor_land_bound x) x = if (0 <=? x) then x else Z.round_lor_land_bound x.
  Proof. rewrite Z.land_comm, land_round_lor_land_bound_r; reflexivity. Qed.
#[global]
  Hint Rewrite land_round_lor_land_bound_l : zsimplify_fast zsimplify.

  Lemma lor_round_lor_land_bound_r x
    : Z.lor x (Z.round_lor_land_bound x) = if (0 <=? x) then Z.round_lor_land_bound x else x.
  Proof. t. Qed.
#[global]
  Hint Rewrite lor_round_lor_land_bound_r : zsimplify_fast zsimplify.
  Lemma lor_round_lor_land_bound_l x
    : Z.lor (Z.round_lor_land_bound x) x = if (0 <=? x) then Z.round_lor_land_bound x else x.
  Proof. rewrite Z.lor_comm, lor_round_lor_land_bound_r; reflexivity. Qed.
#[global]
  Hint Rewrite lor_round_lor_land_bound_l : zsimplify_fast zsimplify.

  Lemma land_round_bound_pos_r v x
    : 0 <= Z.land v (Z.pos x) <= Z.land v (Z.round_lor_land_bound (Z.pos x)).
  Proof.
    rewrite Z.land_nonneg; split; [ lia | ].
    replace (Z.pos x) with (Z.land (Z.pos x) (Z.round_lor_land_bound (Z.pos x))) at 1
      by now rewrite land_round_lor_land_bound_r.
    rewrite (Z.land_comm (Z.pos x)), Z.land_assoc.
    apply Z.land_upper_bound_l; rewrite ?Z.land_nonneg; t.
  Qed.
#[global]
  Hint Resolve land_round_bound_pos_r (fun v x => proj1 (land_round_bound_pos_r v x)) (fun v x => proj2 (land_round_bound_pos_r v x)) : zarith.
  Lemma land_round_bound_pos_l v x
    : 0 <= Z.land (Z.pos x) v <= Z.land (Z.round_lor_land_bound (Z.pos x)) v.
  Proof. rewrite <- !(Z.land_comm v); apply land_round_bound_pos_r. Qed.
#[global]
  Hint Resolve land_round_bound_pos_l (fun v x => proj1 (land_round_bound_pos_l v x)) (fun v x => proj2 (land_round_bound_pos_l v x)) : zarith.

  Lemma land_round_bound_neg_r v x
    : Z.land v (Z.round_lor_land_bound (Z.neg x)) <= Z.land v (Z.neg x) <= v.
  Proof.
    assert (0 < 2 ^ Z.log2_up (Z.pos x)) by auto with zarith.
    split; [ | apply Z.land_le; lia ].
    replace (Z.round_lor_land_bound (Z.neg x)) with (Z.land (Z.neg x) (Z.round_lor_land_bound (Z.neg x)))
      by now rewrite land_round_lor_land_bound_r.
    rewrite !Z.land_assoc.
    etransitivity; [ apply Z.land_le; cbn; lia | ]; lia.
  Qed.
#[global]
  Hint Resolve land_round_bound_neg_r (fun v x => proj1 (land_round_bound_neg_r v x)) (fun v x => proj2 (land_round_bound_neg_r v x)) : zarith.
  Lemma land_round_bound_neg_l v x
    : Z.land (Z.round_lor_land_bound (Z.neg x)) v <= Z.land (Z.neg x) v <= v.
  Proof. rewrite <- !(Z.land_comm v); apply land_round_bound_neg_r. Qed.
#[global]
  Hint Resolve land_round_bound_neg_l (fun v x => proj1 (land_round_bound_neg_l v x)) (fun v x => proj2 (land_round_bound_neg_l v x)) : zarith.

  Lemma lor_round_bound_neg_r v x
    : Z.lor v (Z.round_lor_land_bound (Z.neg x)) <= Z.lor v (Z.neg x) <= -1.
  Proof.
    change (-1) with (Z.pred 0); rewrite <- Z.lt_le_pred.
    rewrite Z.lor_neg; split; [ | lia ].
    replace (Z.neg x) with (Z.lor (Z.neg x) (Z.round_lor_land_bound (Z.neg x))) at 2
      by now rewrite lor_round_lor_land_bound_r.
    rewrite (Z.lor_comm (Z.neg x)), Z.lor_assoc.
    cbn; rewrite <- !Z.lnot_ones_equiv, <- (Z.lnot_involutive v), <- (Z.lnot_involutive (Z.neg x)), <- !Z.lnot_land, !Z.ones_equiv, !Z.lnot_equiv, <- !Z.sub_1_r, !Pos2Z.opp_neg.
    Z.peel_le.
    apply Z.land_upper_bound_l; rewrite ?Z.land_nonneg; t.
  Qed.
#[global]
  Hint Resolve lor_round_bound_neg_r (fun v x => proj1 (lor_round_bound_neg_r v x)) (fun v x => proj2 (lor_round_bound_neg_r v x)) : zarith.
  Lemma lor_round_bound_neg_l v x
    : Z.lor (Z.round_lor_land_bound (Z.neg x)) v <= Z.lor (Z.neg x) v <= -1.
  Proof. rewrite <- !(Z.lor_comm v); apply lor_round_bound_neg_r. Qed.
#[global]
  Hint Resolve lor_round_bound_neg_l (fun v x => proj1 (lor_round_bound_neg_l v x)) (fun v x => proj2 (lor_round_bound_neg_l v x)) : zarith.

  Lemma lor_round_bound_pos_r v x
    : v <= Z.lor v (Z.pos x) <= Z.lor v (Z.round_lor_land_bound (Z.pos x)).
  Proof.
    assert (0 < 2 ^ Z.log2_up (Z.pos (x + 1))) by auto with zarith.
    split; [ apply Z.lor_lower; lia | ].
    replace (Z.round_lor_land_bound (Z.pos x)) with (Z.lor (Z.pos x) (Z.round_lor_land_bound (Z.pos x)))
      by now rewrite lor_round_lor_land_bound_r.
    rewrite !Z.lor_assoc.
    etransitivity; [ | apply Z.lor_lower; rewrite ?Z.lor_nonneg; cbn; lia ]; lia.
  Qed.
#[global]
  Hint Resolve lor_round_bound_pos_r (fun v x => proj1 (lor_round_bound_pos_r v x)) (fun v x => proj2 (lor_round_bound_pos_r v x)) : zarith.
  Lemma lor_round_bound_pos_l v x
    : v <= Z.lor (Z.pos x) v <= Z.lor (Z.round_lor_land_bound (Z.pos x)) v.
  Proof. rewrite <- !(Z.lor_comm v); apply lor_round_bound_pos_r. Qed.
#[global]
  Hint Resolve lor_round_bound_pos_l (fun v x => proj1 (lor_round_bound_pos_l v x)) (fun v x => proj2 (lor_round_bound_pos_l v x)) : zarith.

  Lemma land_round_bound_pos_r' v x : Z.land v (Z.pos x) <= Z.land v (Z.round_lor_land_bound (Z.pos x)). Proof. auto with zarith. Qed.
  Lemma land_round_bound_pos_l' v x : Z.land (Z.pos x) v <= Z.land (Z.round_lor_land_bound (Z.pos x)) v. Proof. auto with zarith. Qed.
  Lemma land_round_bound_neg_r' v x : Z.land v (Z.round_lor_land_bound (Z.neg x)) <= Z.land v (Z.neg x). Proof. auto with zarith. Qed.
  Lemma land_round_bound_neg_l' v x : Z.land (Z.round_lor_land_bound (Z.neg x)) v <= Z.land (Z.neg x) v. Proof. auto with zarith. Qed.
  Lemma lor_round_bound_neg_r' v x : Z.lor v (Z.round_lor_land_bound (Z.neg x)) <= Z.lor v (Z.neg x). Proof. auto with zarith. Qed.
  Lemma lor_round_bound_neg_l' v x : Z.lor (Z.round_lor_land_bound (Z.neg x)) v <= Z.lor (Z.neg x) v. Proof. auto with zarith. Qed.
  Lemma lor_round_bound_pos_r' v x : Z.lor v (Z.pos x) <= Z.lor v (Z.round_lor_land_bound (Z.pos x)). Proof. auto with zarith. Qed.
  Lemma lor_round_bound_pos_l' v x : Z.lor (Z.pos x) v <= Z.lor (Z.round_lor_land_bound (Z.pos x)) v. Proof. auto with zarith. Qed.
End Z.


Require Import Classical.

Declare Scope ordinal_scope.

Inductive Ordinal : Type :=
  | ordS : Ordinal -> Ordinal
  | ord_sup: forall {I:Type}, (I->Ordinal) -> Ordinal.

(*
Fixpoint ord_le (alpha beta:Ordinal) : Prop :=
  match alpha with
  | ordS alpha =>
                  (fix gt_alpha (beta:Ordinal) : Prop :=
                  match beta with
                  | ordS beta => ord_le alpha beta
                  | ord_sup J beta => exists j:J,
                    gt_alpha (beta j)
                  end) beta
  | ord_sup I0 alpha => forall i:I0, ord_le (alpha i) beta
  end.
*)

Inductive ord_le : Ordinal -> Ordinal -> Prop :=
  | ord_le_respects_succ: forall alpha beta:Ordinal,
    ord_le alpha beta -> ord_le (ordS alpha) (ordS beta)
  | ord_le_S_sup: forall (alpha:Ordinal) (J:Type)
    (beta:J->Ordinal) (j:J), ord_le (ordS alpha) (beta j) ->
    ord_le (ordS alpha) (ord_sup beta)
  | ord_sup_minimal: forall (I:Type) (alpha:I->Ordinal)
    (beta:Ordinal), (forall i:I, ord_le (alpha i) beta) ->
                    ord_le (ord_sup alpha) beta.

Definition ord_lt (alpha beta:Ordinal) :=
  ord_le (ordS alpha) beta.
Definition ord_eq (alpha beta:Ordinal) :=
  ord_le alpha beta /\ ord_le beta alpha.
Definition ord_ge (alpha beta:Ordinal) :=
  ord_le beta alpha.
Definition ord_gt (alpha beta:Ordinal) :=
  ord_lt beta alpha.

Open Scope ordinal_scope.
Notation "alpha < beta" := (ord_lt alpha beta) : ordinal_scope.
Notation "alpha <= beta" := (ord_le alpha beta) : ordinal_scope.
Notation "alpha == beta" := (ord_eq alpha beta)
  (at level 70) : ordinal_scope.
Notation "alpha > beta" := (ord_gt alpha beta) : ordinal_scope.
Notation "alpha >= beta" := (ord_ge alpha beta) : ordinal_scope.

Lemma ord_le_respects_succ_converse: forall alpha beta:Ordinal,
  ordS alpha <= ordS beta -> alpha <= beta.
Proof.
intros.
inversion_clear H.
assumption.
Qed.

Lemma ord_le_S_sup_converse: forall (alpha:Ordinal)
  (J:Type) (beta:J->Ordinal), ordS alpha <= ord_sup beta ->
  exists j:J, ordS alpha <= beta j.
Proof.
intros.
inversion H.
exists j.
assumption.
Qed.

Lemma ord_sup_minimal_converse: forall (I:Type)
  (alpha:I->Ordinal) (beta:Ordinal),
  ord_sup alpha <= beta -> forall i:I, alpha i <= beta.
Proof.
intros.
inversion H.
Require Import Eqdep.
apply inj_pair2 in H2.
destruct H2.
apply H3.
Qed.

Lemma ord_le_trans: forall alpha beta gamma:Ordinal,
  alpha <= beta -> beta <= gamma -> alpha <= gamma.
Proof.
induction alpha.
induction beta.
induction gamma.
intros.
apply ord_le_respects_succ.
apply IHalpha with beta.
apply ord_le_respects_succ_converse; trivial.
apply ord_le_respects_succ_converse; trivial.
intros.
apply ord_le_S_sup_converse in H1.
destruct H1 as [i].
apply ord_le_S_sup with i.
apply H; trivial.
intros.
pose proof (ord_sup_minimal_converse _ _ _ H1).
apply ord_le_S_sup_converse in H0.
destruct H0 as [i].
apply H with i; trivial.
intros.
pose proof (ord_sup_minimal_converse _ _ _ H0).
constructor.
intro.
apply H with beta; trivial.
Qed.

Lemma ord_le_sup: forall (I:Type) (alpha:I->Ordinal) (i:I),
  alpha i <= ord_sup alpha.
Proof.
assert (forall beta:Ordinal, beta <= beta /\
  forall (I:Type) (alpha:I->Ordinal) (i:I),
  beta <= alpha i -> beta <= ord_sup alpha).
induction beta.
destruct IHbeta.
split.
apply ord_le_respects_succ; trivial.
intros.
apply ord_le_S_sup with i.
trivial.
split.
apply ord_sup_minimal.
intro.
destruct (H i).
apply H1 with i; trivial.
intros J alpha j ?.
apply ord_sup_minimal.
intro.
destruct (H i).
apply H2 with j.
apply ord_le_trans with (ord_sup o).
apply H2 with i; trivial.
trivial.

intros.
destruct (H (alpha i)).
apply H1 with i; trivial.
Qed.

Lemma ord_le_refl: forall alpha:Ordinal, alpha <= alpha.
Proof.
induction alpha.
apply ord_le_respects_succ; trivial.
apply ord_sup_minimal.
apply ord_le_sup.
Qed.

Lemma ord_le_S: forall alpha:Ordinal, alpha <= ordS alpha.
Proof.
induction alpha.
apply ord_le_respects_succ; trivial.
apply ord_sup_minimal.
intro.
apply ord_le_trans with (ordS (o i)).
apply H.
apply ord_le_respects_succ.
apply ord_le_sup.
Qed.

Lemma ord_lt_le: forall alpha beta:Ordinal,
  alpha < beta -> alpha <= beta.
Proof.
intros.
apply ord_le_trans with (ordS alpha); trivial.
apply ord_le_S.
Qed.

Lemma ord_lt_le_trans: forall alpha beta gamma:Ordinal,
  alpha < beta -> beta <= gamma -> alpha < gamma.
Proof.
intros.
apply ord_le_trans with beta; trivial.
Qed.

Lemma ord_le_lt_trans: forall alpha beta gamma:Ordinal,
  alpha <= beta -> beta < gamma -> alpha < gamma.
Proof.
intros.
apply ord_le_trans with (ordS beta); trivial.
apply ord_le_respects_succ; trivial.
Qed.

Lemma ord_lt_trans: forall alpha beta gamma:Ordinal,
  alpha < beta -> beta < gamma -> alpha < gamma.
Proof.
intros.
apply ord_lt_le_trans with beta; trivial;
 apply ord_lt_le; trivial.
Qed.

Lemma ord_lt_respects_succ: forall alpha beta:Ordinal,
  alpha < beta -> ordS alpha < ordS beta.
Proof.
intros.
apply ord_le_respects_succ; trivial.
Qed.

Lemma ord_total_order: forall alpha beta:Ordinal,
  alpha < beta \/ alpha == beta \/ alpha > beta.
Proof.
induction alpha.
induction beta.
destruct (IHalpha beta) as [|[|]].
left; apply ord_lt_respects_succ; trivial.
right; left.
split.
apply ord_le_respects_succ; apply H.
apply ord_le_respects_succ; apply H.
right; right.
apply ord_lt_respects_succ; trivial.

destruct (classic (exists i:I, ordS alpha < o i)).
destruct H0 as [i].
left.
apply ord_lt_le_trans with (o i); trivial.
apply ord_le_sup.
destruct (classic (exists i:I, ordS alpha == o i)).
destruct H1 as [i].
right; left.
split.
apply ord_le_trans with (o i).
apply H1.
apply ord_le_sup.
apply ord_sup_minimal.
intro.
destruct (H i0) as [|[|]].
contradiction H0; exists i0; trivial.
apply H2.
apply ord_lt_le; trivial.
assert (forall i:I, ordS alpha > o i).
intros.
destruct (H i) as [|[|]].
contradiction H0; exists i; trivial.
contradiction H1; exists i; trivial.
trivial.
right; right.
apply ord_le_lt_trans with alpha.
apply ord_sup_minimal.
intro.
apply ord_le_respects_succ_converse.
apply H2.
apply ord_le_refl.

induction beta.
case (classic (exists i:I, o i > ordS beta)); intro.
destruct H0 as [i].
right; right.
apply ord_lt_le_trans with (o i); trivial.
apply ord_le_sup.
case (classic (exists i:I, o i == ordS beta)); intro.
right; left.
destruct H1 as [i].
split.
apply ord_sup_minimal.
intro j.
destruct (H j (ordS beta)) as [|[|]].
apply ord_lt_le; trivial.
apply H2.
contradiction H0; exists j; trivial.
apply ord_le_trans with (o i).
apply H1.
apply ord_le_sup.
left.
apply ord_le_respects_succ.
apply ord_sup_minimal.
intro.
destruct (H i (ordS beta)) as [|[|]].
apply ord_le_respects_succ_converse; trivial.
contradiction H1; exists i; trivial.
contradiction H0; exists i; trivial.

case (classic (exists j:I0, ord_sup o < o0 j)); intro.
left.
destruct H1 as [j].
apply ord_lt_le_trans with (o0 j); trivial.
apply ord_le_sup.
case (classic (exists i:I, o i > ord_sup o0)); intro.
destruct H2 as [i].
right; right.
apply ord_lt_le_trans with (o i); trivial.
apply ord_le_sup.

right; left.
split.
apply ord_sup_minimal; intro.
destruct (H i (ord_sup o0)) as [|[|]].
apply ord_lt_le; trivial.
apply H3.
contradiction H2; exists i; trivial.
apply ord_sup_minimal; intro j.
destruct (H0 j) as [|[|]].
contradiction H1; exists j; trivial.
apply H3.
apply ord_lt_le; trivial.
Qed.

Lemma ordinals_well_founded: well_founded ord_lt.
Proof.
red; intro alpha.
induction alpha.
constructor.
intros beta ?.
apply ord_le_respects_succ_converse in H.
constructor; intros gamma ?.
destruct IHalpha.
apply H1.
apply ord_lt_le_trans with beta; trivial.

constructor; intros alpha ?.
apply ord_le_S_sup_converse in H0.
destruct H0 as [j].

destruct (H j).
apply H1; trivial.
Qed.

Lemma ord_lt_irrefl: forall alpha:Ordinal, ~(alpha < alpha).
Proof.
intro; red; intro.
assert (forall beta:Ordinal, beta <> alpha).
intro.
pose proof (ordinals_well_founded beta).
induction H0.
red; intro.
symmetry in H2; destruct H2.
contradiction (H1 alpha H); trivial.
contradiction (H0 alpha); trivial.
Qed.

Inductive successor_ordinal : Ordinal->Prop :=
  | intro_succ_ord: forall alpha:Ordinal,
    successor_ordinal (ordS alpha)
  | succ_ord_wd: forall alpha beta:Ordinal,
    successor_ordinal alpha -> alpha == beta ->
    successor_ordinal beta.
Inductive limit_ordinal : Ordinal->Prop :=
  | intro_limit_ord: forall {I:Type} (alpha:I->Ordinal),
    (forall i:I, exists j:I, alpha i < alpha j) ->
    limit_ordinal (ord_sup alpha)
  | limit_ord_wd: forall alpha beta:Ordinal,
    limit_ordinal alpha -> alpha == beta ->
    limit_ordinal beta.

Lemma ord_successor_or_limit: forall alpha:Ordinal,
  successor_ordinal alpha \/ limit_ordinal alpha.
Proof.
induction alpha.
left; constructor.
destruct (classic (forall i:I, exists j:I, o i < o j)).
right; constructor; trivial.
destruct (not_all_ex_not _ _ H0) as [i].
assert (forall j:I, o j <= o i).
intro.
destruct (ord_total_order (o i) (o j)) as [|[|]].
contradiction H1; exists j; trivial.
apply H2.
apply ord_lt_le; trivial.

assert (ord_sup o == o i).
split.
apply ord_sup_minimal; trivial.
apply ord_le_sup.
case (H i); intro.
left; apply succ_ord_wd with (o i); trivial.
split; apply H3.
right.
apply limit_ord_wd with (o i); trivial.
split; apply H3.
Qed.

Lemma successor_ordinal_not_limit: forall alpha:Ordinal,
  successor_ordinal alpha -> ~ limit_ordinal alpha.
Proof.
intros; red; intro.
induction H.
inversion_clear H0.
induction H as [I beta|].
assert (ord_sup beta <= alpha).
apply ord_sup_minimal.
intro.
apply ord_le_respects_succ_converse.
destruct (H i) as [j].
apply ord_le_trans with (beta j); trivial.
apply ord_le_trans with (ord_sup beta).
apply ord_le_sup.
apply H1.

contradiction (ord_lt_irrefl alpha).
apply ord_le_trans with (ord_sup beta); trivial.
apply H1.

apply IHlimit_ordinal.
split; apply ord_le_trans with beta;
  (apply H0 || apply H1).

contradiction IHsuccessor_ordinal.
apply limit_ord_wd with beta; trivial.
split; apply H1.
Qed.


Require Import Coq.Classes.Morphisms
  Coq.micromega.Lia Sigma.Algebra.Hierarchy
  Sigma.Algebra.Monoid Sigma.Algebra.Group
  Sigma.Algebra.Ring
  Sigma.Algebra.Integral_domain
  Sigma.Algebra.Field.

Section Vector_Space.

  (* Underlying Field of Vector Space *)
  Context
    {F : Type}
    {eqf : F -> F -> Prop}
    {zero one : F}
    {add mul sub div : F -> F -> F}
    {opp inv : F -> F}.

  (* Vector Element *)
  Context
    {V : Type}
    {eqv : V -> V -> Prop}
    {vid : V} {vopp : V -> V}
    {vadd : V -> V -> V} {smul : V -> F -> V}
    {Hvec: @vector_space F eqf zero one add mul
      sub div opp inv V eqv vid vopp vadd smul}.

  Local Infix "=" := eqv : type_scope.
  Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Infix "*s" := smul (at level 40).
  Local Infix "+v" := vadd (at level 50).

  (* smul will be ^ pow function *)
  Lemma connection_between_vopp_and_fopp :
    forall u v, vopp (u *s v) = u *s (opp v).
  Proof.
    intros ? ?.
    eapply group_cancel_right with (z := smul u v).
    rewrite group_is_left_inverse,
     <-(@vector_space_smul_distributive_fadd F eqf zero one add mul sub div
      opp inv V eqv vid vopp vadd smul),
      field_zero_iff_left,
      vector_space_field_zero;
      try reflexivity;
      exact Hvec.
  Qed.

  Lemma smul_pow_up :
    forall g x r, (g *s x) *s r = g *s (mul x r).
  Proof.
    intros ? ? ?.
    rewrite (@vector_space_smul_associative_fmul F eqf);
    try reflexivity; exact Hvec.
  Qed.

  Lemma smul_pow_mul :
    forall g x r, smul (smul g x) r = smul g (mul r x).
  Proof.
    intros ? ? ?.
    rewrite smul_pow_up, commutative;
    reflexivity.
  Qed.

End Vector_Space.


(*

   Benedikt Ahrens and Régis Spadotti

   Terminal semantics for codata types in intensional Martin-Löf type theory

   http://arxiv.org/abs/1401.1053

*)

(*

  Content of this file:

  definition of the category of relative comonads over a fixed functor

*)

Require Import Theory.Category.
Require Import Theory.Functor.
Require Import Theory.RelativeComonad.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＣＡＴＥＧＯＲＹ  ＯＦ  ＲＥＬＡＴＩＶＥ  ＣＯＭＯＮＡＤＳ
  ----------------------------------------------------------------------------*)
(** * Category of Relative comonads **)

(** ** Category definition **)

Section Definitions.

  Context `(F : Functor 𝒞 𝒟).

  Implicit Types (A B C D : RelativeComonad F).

  Import RelativeComonad.Morphism.

  Infix "⇒" := Hom.
  Infix "∘" := compose.

  Lemma left_id A B  (f : A ⇒ B) : id ∘ f ≈ f.
  Proof.
    intro x; simpl. rewrite left_id. reflexivity.
  Qed.

  Lemma right_id A B (f : A ⇒ B) : f ∘ id ≈ f.
  Proof.
    intro x; simpl. now rewrite right_id.
  Qed.

  Lemma compose_assoc A B C D (f : A ⇒ B) (g : B ⇒ C) (h : C ⇒ D) : h ∘ g ∘ f ≈ h ∘ (g ∘ f).
  Proof.
    intro x; simpl. now rewrite compose_assoc.
  Qed.

  Canonical Structure 𝑹𝑪𝒐𝒎𝒐𝒏𝒂𝒅 : Category :=
    mkCategory left_id right_id compose_assoc.

End Definitions.


From Coq Require Import List.
From Coq Require Import Psatz.
From Coq Require Import ZArith.
From Coq Require Import Znumtheory.
Import ListNotations.

Local Open Scope Z.

Fixpoint egcd_aux
        (n : nat)
        (r0 a0 b0 r1 a1 b1 : Z) {struct n} : Z * Z :=
  match n with
  | 0%nat => (0, 0)
  | S n => let (q, r) := Z.div_eucl r0 r1 in
           if r =? 0 then
             (a1, b1)
           else
             egcd_aux n r1 a1 b1 r (a0 - q*a1) (b0 - q*b1)
  end.

(* returns (x, y) such that x*m + y*n = Z.gcd(x, y) *)
Definition egcd (m n : Z) : Z * Z :=
  if m =? 0 then
    (0, Z.sgn n)
  else if n =? 0 then
    (Z.sgn m, 0)
  else
    let num_steps := S (Z.to_nat (Z.log2 (Z.abs m) + Z.log2 (Z.abs n))) in
    if Z.abs m <? Z.abs n then
      let (x, y) := egcd_aux num_steps (Z.abs n) 1 0 (Z.abs m) 0 1 in
      (Z.sgn m * y, Z.sgn n * x)
    else
      let (x, y) := egcd_aux num_steps (Z.abs m) 1 0 (Z.abs n) 0 1 in
      (Z.sgn m * x, Z.sgn n * y).

Lemma egcd_aux_spec m n steps r0 a0 b0 r1 a1 b1 :
  Z.log2 r0 + Z.log2 r1 < Z.of_nat steps ->
  0 < r1 ->
  r1 <= r0 ->
  r0 = a0*m + b0*n ->
  r1 = a1*m + b1*n ->
  Z.gcd r0 r1 = Z.gcd m n ->
  let (x, y) := egcd_aux steps r0 a0 b0 r1 a1 b1 in
  x*m + y*n = Z.gcd m n.
Proof.
  revert r0 a0 b0 r1 a1 b1.
  induction steps as [|steps IH];
    intros r0 a0 b0 r1 a1 b1 enough_steps r1pos r1gt r0eq r1eq is_gcd.
  {
    cbn -[Z.add] in enough_steps.
    pose proof (Z.log2_nonneg r0).
    pose proof (Z.log2_nonneg r1).
    lia.
  }
  cbn.
  pose proof (Z_div_mod r0 r1 ltac:(lia)).
  destruct (Z.div_eucl r0 r1) as [q r].
  destruct (Z.eqb_spec r 0) as [->|?].
  - destruct H.
    rewrite Z.add_0_r in *.
    rewrite <- r1eq.
    rewrite <- is_gcd.
    rewrite H.
    rewrite Z.gcd_comm.
    now rewrite Z.gcd_mul_diag_l by lia.
  - apply IH; auto.
    + destruct H.
      destruct q; try lia; cycle 1.
      assert (r + r1 <= r0).
      {
        enough (r1 <= r1 * Z.pos p) by lia.
        apply Z.le_mul_diag_r; lia.
      }
      assert (Z.log2 r1 + Z.log2 r < Z.log2 r0 + Z.log2 r1).
      {
        enough (Z.log2 r < Z.log2 r0) by lia.
        pose proof (Z.log2_le_mono (r*2^1) r0 ltac:(lia)).
        rewrite <- Z.shiftl_mul_pow2 in H2 by lia.
        rewrite Z.log2_shiftl in H2 by lia.
        lia.
      }
      lia.
    + lia.
    + lia.
    + rewrite !Z.mul_sub_distr_r.
      replace (a0 * m - q * a1 * m + (b0 * n - q * b1 * n))
        with (a0 * m + b0*n + (-1) * (q*(a1*m + b1*n)))
        by lia.
      rewrite <- r0eq, <-r1eq.
      lia.
    + rewrite <- is_gcd.
      rewrite (proj1 H).
      rewrite (Z.gcd_comm (r1 * q + r)).
      rewrite Z.add_comm, Z.mul_comm.
      now rewrite Z.gcd_add_mult_diag_r.
Qed.

Lemma egcd_spec m n :
  let (x, y) := egcd m n in
  m*x + n*y = Z.gcd m n.
Proof.
  unfold egcd.
  destruct (Z.eqb_spec m 0) as [->|?].
  { apply Z.sgn_abs. }
  destruct (Z.eqb_spec n 0) as [->|?].
  { rewrite Z.gcd_0_r, Z.add_0_r; apply Z.sgn_abs. }
  pose proof (Z.log2_nonneg (Z.abs m)).
  pose proof (Z.log2_nonneg (Z.abs n)).
  destruct (Z.ltb_spec (Z.abs m) (Z.abs n)).
  - unshelve epose proof (egcd_aux_spec
                            (Z.abs n) (Z.abs m)
                            (S (Z.to_nat (Z.log2 (Z.abs m) + Z.log2 (Z.abs n))))
                            (Z.abs n) 1 0
                            (Z.abs m) 0 1
                            _ _ _ _ _ _).
    + rewrite Nat2Z.inj_succ.
      rewrite Z2Nat.id by lia.
      lia.
    + lia.
    + lia.
    + lia.
    + lia.
    + lia.
    + destruct (egcd_aux _ _ _ _ _ _ _).
      rewrite !Z.mul_assoc.
      rewrite Z.gcd_abs_l, Z.gcd_comm, Z.gcd_abs_l in H2.
      rewrite !Z.sgn_abs.
      lia.
  - unshelve epose proof (egcd_aux_spec
                            (Z.abs m) (Z.abs n)
                            (S (Z.to_nat (Z.log2 (Z.abs m) + Z.log2 (Z.abs n))))
                            (Z.abs m) 1 0
                            (Z.abs n) 0 1
                            _ _ _ _ _ _).
    + rewrite Nat2Z.inj_succ.
      rewrite Z2Nat.id by lia.
      lia.
    + lia.
    + lia.
    + lia.
    + lia.
    + lia.
    + destruct (egcd_aux _ _ _ _ _ _ _).
      rewrite !Z.mul_assoc.
      rewrite Z.gcd_abs_l, Z.gcd_comm, Z.gcd_abs_l, Z.gcd_comm in H2.
      rewrite !Z.sgn_abs.
      lia.
Qed.

Lemma mul_fst_egcd a n :
  rel_prime a n ->
  a * fst (egcd a n) mod n = 1 mod n.
Proof.
  pose proof (egcd_spec a n).
  destruct (Z.eqb_spec n 0) as [->|?].
  { intros. cbn in *. rewrite !Zmod_0_r.
    rewrite <- Zgcd_1_rel_prime in *.
    rewrite Z.gcd_0_r in *.
    unfold egcd. destruct (Z.eqb_spec a 0) as [->|?]; cbn; lia. }
  intros relprime.
  destruct (egcd a n) as [x y]; cbn.
  rewrite (proj2 (Zgcd_1_rel_prime _ _) relprime) in H.
  replace (a * x) with (1 + (-y)*n) by lia.
  rewrite <- Z.add_mod_idemp_r by lia.
  now rewrite Z.mod_mul, Z.add_0_r by lia.
Qed.

Lemma egcd_divides a b :
  b <> 0 ->
  (b | a) ->
  egcd a b = (0, Z.sgn b).
Proof.
  intros b0 divides.
  unfold egcd.
  destruct (Z.eqb_spec a 0) as [->|a0]; [easy|].
  rewrite (proj2 (Z.eqb_neq _ _) b0).
  assert (Z.abs b <= Z.abs a) by (apply Zdivide_bounds; auto).
  replace (Z.abs a <? Z.abs b) with false; cycle 1.
  { now symmetry; apply Z.ltb_ge. }
  cbn.
  pose proof (Z_div_mod_full (Z.abs a) (Z.abs b) ltac:(lia)).
  destruct (Z.div_eucl (Z.abs a) (Z.abs b)) as [q r].
  rewrite (Zmod_unique_full _ _ _ _ (proj2 H0) (proj1 H0)).
  apply Z.divide_abs_l, Z.divide_abs_r in divides.
  rewrite (Zdivide_mod _ _ divides).
  cbn.
  now rewrite Z.mul_0_r, Z.mul_1_r.
Qed.


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

(*i $Id: Permut.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(* G. Huet 1-9-95 *)

(** We consider a Set [U], given with a commutative-associative operator [op],
    and a congruence [cong]; we show permutation lemmas *)

Section Axiomatisation.

  Variable U : Type.
  Variable op : U -> U -> U.
  Variable cong : U -> U -> Prop.

  Hypothesis op_comm : forall x y:U, cong (op x y) (op y x).
  Hypothesis op_ass : forall x y z:U, cong (op (op x y) z) (op x (op y z)).

  Hypothesis cong_left : forall x y z:U, cong x y -> cong (op x z) (op y z).
  Hypothesis cong_right : forall x y z:U, cong x y -> cong (op z x) (op z y).
  Hypothesis cong_trans : forall x y z:U, cong x y -> cong y z -> cong x z.
  Hypothesis cong_sym : forall x y:U, cong x y -> cong y x.

  (** Remark. we do not need: [Hypothesis cong_refl : (x:U)(cong x x)]. *)

  Lemma cong_congr :
    forall x y z t:U, cong x y -> cong z t -> cong (op x z) (op y t).
  Proof.
    intros; apply cong_trans with (op y z).
    apply cong_left; trivial.
    apply cong_right; trivial.
  Qed.

  Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)).
  Proof.
    intros; apply cong_right; apply op_comm.
  Qed.

  Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z).
  Proof.
    intros; apply cong_left; apply op_comm.
  Qed.

  Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y).
  Proof.
    intros.
    apply cong_trans with (op x (op y z)).
    apply op_ass.
    apply cong_trans with (op x (op z y)).
    apply cong_right; apply op_comm.
    apply cong_sym; apply op_ass.
  Qed.

  Lemma perm_left : forall x y z:U, cong (op x (op y z)) (op y (op x z)).
  Proof.
    intros.
    apply cong_trans with (op (op x y) z).
    apply cong_sym; apply op_ass.
    apply cong_trans with (op (op y x) z).
    apply cong_left; apply op_comm.
    apply op_ass.
  Qed.

  Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)).
  Proof.
    intros; apply cong_trans with (op (op x y) z).
    apply cong_sym; apply op_ass.
    apply op_comm.
  Qed.

  (** Needed for treesort ... *)
  Lemma twist :
    forall x y z t:U, cong (op x (op (op y z) t)) (op (op y (op x t)) z).
  Proof.
    intros.
    apply cong_trans with (op x (op (op y t) z)).
    apply cong_right; apply perm_right.
    apply cong_trans with (op (op x (op y t)) z).
    apply cong_sym; apply op_ass.
    apply cong_left; apply perm_left.
  Qed.

End Axiomatisation.


From mathcomp Require Import all_ssreflect.

(* 6. Sub-Types Terms with properties *)
(* 6.4 The ordinal subtype *)

(*
Section MySubTypeKit.
  Variables (T : Type) (P : pred T).

  Structure subType : Type :=
    SubTypeKit {
        sub_sort :> Type;                   (* projector *)
        val : sub_sort -> T;                (* constructor *)
        Sub : forall x, P x -> sub_sort;    (* constructor *)
        (* elimination rule for sub_sort *)
        _: forall K (_ : forall x Px, K (@Sub x Px)) u, K u;
        _: forall x Px, val (@Sub x Px) = x
      }.

  Notation "[ ’subType’ ’for’ v ]" :=
    (SubType _ v _
             (fun K K_S u => let (x, Px) as u return K u := u in K_S x Px)
             (fun x px => erefl x)).
End MySubTypeKit.
*)
Section MyOrdinal.
  Variable n : nat.

  Inductive ordinal : Type := Ordinal m of m < n.

  Print Canonical Projections.
  Coercion nat_of_ord i := let: @Ordinal m _ := i in m. (* i : 'I_n *)
  (* _ は、H : m < n である。 *)
  Print Graph.
  (* [nat_of_ord] : ordinal >-> nat *)

  Canonical ordinal_subType := [subType for nat_of_ord].
  Print ordinal_subType.
  (*
    ordinal_subType =
    [subType for nat_of_ord]
     : subType (T:=nat) (fun x : nat => x < n)
   *)
  Print Canonical Projections.
  (* nat_of_ord <- val ( ordinal_subType ) *)

  (* 次の定義には、カノニカルが必要 Canonical ordinal_subType。
     カノニカルにしないと、"SubEqMixin ?s" has type "Equality.mixin_of ?s"
     while it is expected to have type "Equality.mixin_of ordinal". *)
  Definition ordinal_eqMixin := Eval hnf in [eqMixin of ordinal by <:].
  Set Printing Coercions.
  Print ordinal_eqMixin.
  (*
ordinal_eqMixin =
EqMixin (T:=ordinal) (op:=fun x y : ordinal => nat_of_ord x == nat_of_ord y)
  (@val_eqP nat_eqType (fun x : nat => x < n) ordinal_subType)
     : Equality.mixin_of ordinal
 *)

  Canonical ordinal_eqType := Eval hnf in EqType ordinal ordinal_eqMixin.
  Print Canonical Projections.
  (* ordinal <- sort ( ordinal_eqType ) *)

  Definition ord_enum : seq ordinal := pmap insub (iota 0 n).

  Check @pmap : forall aT rT : Type, (aT -> option rT) -> seq aT -> seq rT.
  (* 要素に関数(この場合は insub : aT -> option rT)を適用して、
     結果の Some x の Some を外し、None なら捨てる。 *)

  (* ord_enum n から値を取り出した結果は、自然数の0からn-1までのリストと等しい。 *)
  Lemma val_ord_enum : map val ord_enum = (iota 0 n).
  Proof.
    rewrite pmap_filter; last exact: insubK.
    by apply/all_filterP; apply/allP=> i; rewrite mem_iota isSome_insub.
  Qed.

  (* 以下の証明において、Canonical ordinal_eqType が必要。カノニカルにしないと、
  "ord_enum" has type "seq ordinal" while it is expected to have type "seq ?T". *)

  (* ordinal <- sort ( ordinal_eqType ) *)
  Check @uniq : forall T : eqType, seq T -> bool.
  Check ord_enum : seq ordinal.
  (* ordinal と sort (ordinal_eqType) = eqType のユニファイが可能になる。 *)

  (* ord_enum n の要素はユニークである。 *)
  Lemma ord_enum_uniq : uniq ord_enum.
  Proof.
      by rewrite pmap_sub_uniq ?iota_uniq.
  Qed.

  Lemma ord_inj : injective nat_of_ord.     (* fintype.v から転記 *)
  Proof.
    exact: val_inj.
  Qed.

  Lemma ltn_ord (i : ordinal) : i < n.      (* fintype.v から転記 *)
  Proof.
    exact: valP i.
  Qed.

  Lemma mem_ord_enum i : i \in ord_enum.
  Proof.
    Check pmap insub (iota 0 n).
    Check (mem_map ord_inj).
    rewrite -(mem_map ord_inj).
    rewrite val_ord_enum.
    rewrite mem_iota.
    rewrite add0n /=.
    Check ltn_ord.
    by apply ltn_ord.
  Qed.

End MyOrdinal.

(* Definition p1 : 'I_3. Proof. have : 1 < 3 by []. apply Ordinal. Defined. *)
Definition p1 := Ordinal 3 1 is_true_true.

Check @insub: forall (T : Type) (P : pred T) (sT : subType (T:=T) P), T -> option sT.
(* サブタイプに含まれるなら Some x、さもなければ None を返す。 *)
Print ordinal_subType.
Check (fun i : nat => i < 3).
Check (fun i : 'I_3 => i < 3).              (* カノニカル効くけど、それじゃない。 *)
Check @insub nat.
Check @insub nat (fun i : nat => i < 3).
Check @insub nat (fun i : nat => i < 3) (ordinal_subType 3).
Check @insub nat (fun i : nat => i < 3) (ordinal_subType 3) 1.
Check @insub nat (fun i : nat => i < 3) (ordinal_subType 3) 1 = Some p1.
Check insub 1 = Some p1.
Goal insub 1 = Some p1.
Proof.
  by rewrite insubT.
Qed.

(* *************** *)
Notation "''I_' n" := (ordinal n).
(* *************** *)

(* ******* *)
(* SUBTYPE *)
(* ******* *)

(*
  Definition ordinal_finMixin :=
    Eval hnf in UniqFinMixin ord_enum_uniq mem_ord_enum.

  Canonical ordinal_finType :=
    Eval hnf in FinType ordinal ordinal_finMixin.

*)

Lemma tnth_default {T n} (t : n.-tuple T) : 'I_n -> T.
Proof.
  rewrite -(size_tuple t).
  elim: (tval t).
  - case=> //=.
  - move=> a l H1 H2.
    done.
  Restart.
    by rewrite -(size_tuple t); case: (tval t) => [|//] [].
Qed.

Check @nth : forall T : Type, T -> seq T -> nat -> T.
Definition tnth T n (t : n.-tuple T) (i : 'I_n) : T :=
  nth (tnth_default t i) t i.
(* nth の最後の引数 nat に、 'I_n を与えている。 *)
(* nth の最後から二つ目の引数 seq T に、n.tuple T を与えている。 *)

Check tnth : forall (T : Type) (n : nat), n.-tuple T -> 'I_n -> T.

Lemma Hsize : size [::false;true;false] == 3. Proof. done. Qed.
Check Tuple Hsize.
Check tnth bool 3 (Tuple Hsize) p1 : bool.
Eval compute in tnth bool 3 (Tuple Hsize) p1. (* true *)

Check Tuple Hsize : 3.-tuple bool.
Check @tnth_default bool 3 (Tuple Hsize) p1 : bool.
Eval compute in @tnth_default bool 3 (Tuple Hsize) p1. (* bool型のなにか *)
Eval compute in tnth_default (Tuple Hsize) p1.         (* bool型のなにか *)
Eval compute in @nth bool (tnth_default (Tuple Hsize) p1) (Tuple Hsize) p1. (* true *)
Eval compute in nth _ (Tuple Hsize) p1. (* true *)
Eval compute in nth _ (Tuple Hsize) 1. (* true *)

(* END *)


Require Export Poly.

Theorem silly1: forall (n m o p: nat),
    n = m -> [n;o] = [n;p] -> [n;o] = [m;p].
Proof.
    intros n m o p eq1 eq2.
    rewrite <- eq1.
    apply eq2.
Qed.

Theorem silly2: forall (n m o p: nat),
    n = m -> (forall q r: nat, q = r -> [q;o] = [r;p]) -> [n;o] = [m;p].
Proof.
    intros n m o p eq1 eq2.
    apply eq2.
    apply eq1.
Qed.

Theorem silly2a: forall n m: nat,
    (n,n) = (m,m) -> (forall q r: nat, (q,q) = (r,r) -> [q] = [r]) ->
    [n] = [m].
Proof.
    intros n m eq1 eq2.
    apply eq2.
    apply eq1.
Qed.

Theorem silly_ex: (forall n, evenb n = true -> oddb (S n) = true) ->
    evenb 3 = true -> oddb 4 = true.
Proof.
    intros eq1.
    apply eq1.
Qed.

Theorem silly3: forall n: nat, true = beq_nat n 5 ->
    beq_nat (S (S n)) 7 = true.
Proof.
    intros n H.
    symmetry.
    apply H.
Qed.

Example trans_eq_example: forall a b c d e f: nat,
    [a;b] = [c;d] ->
    [c;d] = [e;f] ->
    [a;b] = [e;f].
Proof.
    intros a b c d e f eq1 eq2.
    rewrite -> eq1.
    rewrite -> eq2.
    reflexivity.
Qed.

Theorem trans_eq: forall (X: Type) (n m o: X),
    n = m -> m = o -> n = o.
Proof. intros X n m o eq1 eq2. rewrite eq1. apply eq2. Qed.

Example trans_eq_example': forall a b c d e f: nat,
    [a;b] = [c;d] ->
    [c;d] = [e;f] ->
    [a;b] = [e;f].
Proof.
    intros a b c d e f eq1 eq2.
    apply trans_eq with (m:=[c;d]). apply eq1. apply eq2.
Qed.


Require Import Setoid.
Require Import FunctionalExtensionality.

Lemma uniq_choice : forall (A B : Prop),
  forall (P : A -> B -> Prop),
  (forall (a : A), exists! (b : B), P a b)
  -> (exists (f : A -> B), forall (a : A), P a (f a)).
Proof.
  intros.
  exists (fun a => ex_proj1 (H a)).
  intros.
  destruct (H a), u.
  auto.
Qed.

(**)
Record MRE :=
{ set : Prop
; elem : set
; op : set -> set -> set
; subset : Prop
; subset_incl : subset -> set
; exist_axiom : forall (f : subset -> set), exists! (x : set),
  f = fun y => op (subset_incl y) x
}.

Definition witness_fcn : forall (M : MRE),
  forall (f : set M -> set M),
  exists (fn : set M -> set M),
  forall (x : set M),
  (fun y => f (op M (subset_incl M y) x))
  = (fun y => op M (subset_incl M y) (fn x)).
Proof.
  intros.
  assert (forall (x : set M), exists! (y : set M),
    (fun d => f (op M (subset_incl M d) x))
    = (fun d => op M (subset_incl M d) y)).
  intro.
  exact (exist_axiom M (fun d => f (op M (subset_incl M d) x))).
  pose (pred := fun x => fun y =>
    (fun d : subset M => f (op M (subset_incl M d) x))
    = (fun d : subset M => op M (subset_incl M d) y)).
  exact (uniq_choice (set M ) (set M) pred H).
Defined.

(* The basic structure of the Rock-Lawvere real numbers *)
(* There is some redundancy in these axioms, for convenience *)
Record SynthReal :=
{ set : Prop

(* Addition forms an Abelian group *)
; zero : set
; add : set -> set -> set
; add_id : forall (x : set), add x zero = x
; add_assoc : forall (x y z : set), add (add x y) z = add x (add y z)
; add_comm : forall (x y : set), add x y = add y x
; add_inv : forall (x : set),
  (exists (negx : set), add x negx = zero)

(* Multiplication forms a commutative monoid with inverses except at 0 *)
; one : set
; mul : set -> set -> set
; mul_id : forall (x : set), mul x one = x
; mul_assoc : forall (x y z : set), mul (mul x y) z = mul x (mul y z)
; mul_comm : forall (x y : set), mul x y = mul y x
; mul_inv : forall (x : set), x <> zero
  -> (exists (invx : set), mul x invx = one)

(* Multiplication distributes over addition *)
; left_distrib : forall (x y z : set),
  mul x (add y z) = add (mul x y) (mul x z)
; right_distrib : forall (x y z : set),
  mul (add x y) z = add (mul x z) (mul y z)

(* A total ordering which behaves nicely with the field operations *)
; lessthan : set -> set -> Prop
; transitive : forall (x y z : set), (lessthan x y) -> (lessthan y z)
  -> (lessthan x z)
; zero_less_one : lessthan zero one
; total : forall (x y : set), x <> y -> lessthan x y \/ lessthan y x
; translation : forall(x y z : set),
  lessthan x y -> lessthan (add x z) (add y z)
; dilation : forall (x y z : set),
  (not (lessthan z zero) /\ lessthan x y) -> lessthan (mul z x) (mul z y)

(* Square roots existence and uniqueness *)
; sqrt_exist : forall (x : set), (exists (y : set), mul y y = x)
; sqrt_uniq : forall (x y : set), (lessthan zero y /\ mul y y = x)
  -> y = ex_proj1 (sqrt_exist x)

(* Nilsquare infinitesimals are treated as a separate type *)
(* with an injection into the rest of the field *)
; nilsquares : Prop
; nilsquare_incl : nilsquares -> set
; nilsquare_subset : forall (d1 d2 : nilsquares),
  nilsquare_incl d1 = nilsquare_incl d2 -> d1 = d2
; nilsquare_def : forall (d : nilsquares),
  mul (nilsquare_incl d) (nilsquare_incl d) = zero
; nilsquare_recl : forall (x : set),
  forall (nilsqr : mul x x = zero),
    exists (d : nilsquares), x = nilsquare_incl d
; nilzero : nilsquares
; nilzero_def : nilsquare_incl nilzero = zero

(* The Kock-Lawvere axiom! *)
; KockLawvere : forall (f : nilsquares -> set),
  (exists (a : set),
    f = fun d => add (f nilzero) (mul a (nilsquare_incl d)))

}.

(* Basic algebra stuff *)

Fact cancel_add : forall (R: SynthReal),
  forall (x y z : set R),
  add R x z = add R y z -> x = y.
Proof.
intros R x y z hyp.
rewrite <- (add_id R x).
destruct (add_inv R z).
rewrite <- H.
rewrite <- (add_assoc R x z x0).
rewrite -> hyp.
rewrite -> (add_assoc R y z x0).
rewrite -> H.
rewrite -> (add_id R y).
reflexivity.
Qed.

Fact mul_zero : forall (R : SynthReal),
  forall (x : set R),
  mul R (zero R) x = zero R.
Proof.
intros R x.
assert (add R (mul R (zero R) x) (mul R (zero R) x)
  = add R (zero R) (mul R (zero R) x)).
rewrite -> (add_comm R (zero R) (mul R (zero R) x)).
rewrite -> (add_id R).
rewrite <- (right_distrib R (zero R) (zero R) x).
rewrite -> (add_id R (zero R)) at 1.
reflexivity.
exact (cancel_add R (mul R (zero R) x) (zero R) (mul R (zero R) x) H).
Qed.

(* A few utilities before beginning single variable calculus *)

Definition diff (R : SynthReal) (x : set R)
  (d : nilsquares R) : set R := mul R (nilsquare_incl R d) x.

Fact nilsquare_diff : forall (R : SynthReal),
  forall (x : set R),
  forall (d : nilsquares R),
  mul R (diff R x d) (diff R x d) = zero R.
Proof.
intros R x d.
unfold diff.
rewrite -> (mul_comm R (nilsquare_incl R d) x) at 1.
rewrite -> (mul_assoc R x (nilsquare_incl R d) (mul R (nilsquare_incl R d) x)).
rewrite <- (mul_assoc R (nilsquare_incl R d) (nilsquare_incl R d) x).
rewrite -> (nilsquare_def R d).
rewrite -> (mul_zero R).
rewrite -> (mul_comm R).
rewrite -> (mul_zero R).
reflexivity.
Qed.

Fact linearize_diff : forall (R : SynthReal),
  forall (x : set R),
  ex_proj1 (linear_exist R (diff R x)) = x.
Proof.
intros R x.
assert (forall (d : nilsquares R),
  diff R x d = add R (diff R x (nilzero R)) (mul R x (nilsquare_incl R d))).
intros d.
unfold diff.
rewrite -> (nilzero_def R).
rewrite -> (mul_zero R).
rewrite -> (add_comm R).
rewrite -> (add_id R).
rewrite -> (mul_comm R).
reflexivity.
symmetry.
exact (linear_uniq R (diff R x) x H).
Qed.

Lemma microcancellation : forall (R : SynthReal),
  forall (x y : set R),
  diff R x = diff R y -> x = y.
Proof.
intros R x y hyp.
rewrite <- (linearize_diff R x).
rewrite <- (linearize_diff R y).
rewrite -> hyp.
reflexivity.
Qed.

(* Single-variable calculus! *)

(**)
Remark derivative_w_prf : forall (R : SynthReal),
  forall (f : set R -> set R),
  exists (df : set R -> set R),
  forall (x : set R),
  forall (d : nilsquares R),
  f (add R x (nilsquare_incl R d))
  = add R (f x) (mul R (nilsquare_incl R d) (df x)).
Proof.
intros R f.
pose (df0 := fun x =>
  (linear_exist R (fun d => (f (add R x (nilsquare_incl R d)))))).
exists (fun x => ex_proj1 (df0 x)).
intros x d.
(**)

Definition derivative (R : SynthReal)
  (f : set R -> set R)
  (x : set R) : set R :=
  ex_proj1 (linear_exist R (fun d => f (add R x (nilsquare_incl R d)))).

Fact rewrite_derivative : forall (R : SynthReal),
  forall (f : set R -> set R),
  forall (x : set R),
  forall (d : nilsquares R),
  f (add R x (nilsquare_incl R d))
  = add R (f x) (mul R (nilsquare_incl R d) (derivative R f x)).
Proof.
intros R f x d.
pose (ex_df := fun y =>
  linear_exist R (fun d0 => f (add R y (nilsquare_incl R d0)))).
unfold derivative.
exact (linear_uniq R (fun d1 =>
  f (add R x (nilsquare_incl R d1))) (derivative R f x) H).

Proposition product_rule : forall (R : SynthReal),
  forall (f : set R -> set R),
  forall (g : set R -> set R),
  forall (x : set R),
  derivative R (fun y => mul R (f y) (g y)) x
  = add R (mul R (derivative R f x) (g x)) (mul R (f x) (derivative R g x)).
Proof.
intros R f g x.
unfold derivative at 1.
fold (derivative R f).

Theorem derivative_distrib : forall (R : SynthReal),
  forall (f : set R -> set R),
  forall (g : set R -> set R),
  forall (x : set R),
  add R (derivative R f x) (derivative R g x)
  = derivative R (fun y => add R (f y) (g x)) x.
Proof.
intros R f g x.
unfold derivative.


Require Coq.Init.Datatypes.
Import Coq.Init.Notations.
Notation "A -> B" := (forall (_ : A), B) : type_scope.

Section inductionExamples.

  Inductive ThreeElementSet:=
  |zero
  |one
  |two.

  Inductive PairOrTriple:=
  |pair (x y:ThreeElementSet)
  |triple (x y z:ThreeElementSet).

  Inductive Lst:=
  |nil
  |cons (x:ThreeElementSet) (l:Lst).

End inductionExamples.

Section functionExamples.

  Definition plusOneModThree (X:ThreeElementSet):
    ThreeElementSet.
  Proof.
    induction X.
    - apply one.
    - apply two.
    - apply zero.
  Defined.

  Definition constantAtZero (X:ThreeElementSet):
    ThreeElementSet.
  Proof.
    apply zero.
  Defined.

  Definition plusTwoModThree (X:ThreeElementSet):
    ThreeElementSet.
  Proof.
    induction X.
    - apply two.
    - apply zero.
    - apply one.
  Defined.

  Definition roundToPair (p:PairOrTriple):
    PairOrTriple.
  Proof.
    induction p.
    - apply (pair x y).
    - apply (pair x y).
  Defined.

  Fixpoint append (l m:Lst):
    Lst.
  Proof.
    destruct l.
    - apply m.
    - apply (cons x (append l m)).
  Defined.

End functionExamples.

Section inductionExercises.

  Inductive FourElementSet:=
  |zero4
  |one4
  |two4
  |three4.

  Inductive Nat:=
  |base
  |succ (n:Nat).

End inductionExercises.

Section functionExercises.

  Definition constantAtZero4 (x:FourElementSet):
    FourElementSet.
  Proof.
    apply zero4.
  Defined.

  Definition doubleModThree (x:ThreeElementSet):
    ThreeElementSet.
  Proof.
    induction x.
    - apply zero.
    - apply two.
    - apply one.
  Defined.

  Definition fourModThree (x:FourElementSet):
    ThreeElementSet.
  Proof.
    induction x.
    - apply zero.
    - apply one.
    - apply two.
    - apply zero.
  Defined.

  Fixpoint length (l:Lst):
    Nat.
  Proof.
    destruct l.
    - apply base.
    - apply (succ (length l)).
  Defined.

End functionExercises.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(*
  The following is an algorithm for extracting the path leading to an item v
  in a binary tree. This path is the code of the item in huffman compression.
  The algorithm is used only when the given item is is the tree.

    exception Not_found
    let encode t v =
       let rec lookup = function
              Leaf -> raise Not_found
            | Node(t1,b,t2) ->
                 if a=b then []
                 else try L::lookup t1 with
                      Not_found -> R::lookup t2
       in lookup t

  The informal argument is as follows : if the item has not been found in the
  left branch (the raised exception is catched), then if the item has not
  been found in the right branch, then nothing has to be done : the raised
  exception will propagate, which means that the item was not in the current
  subtree.

  It is not necessary to be aware of this reasoning when building the formal
  proof: the right proof obligations are automatically generated and are easy
  to prove.

*)

Require Import List.
Require Extraction.

Section sec_dom.
Variable dom : Set.
Variable a : dom.
Axiom eg : forall a b : dom, {a = b} + {a <> b}.

Inductive tree : Set :=
  | Leaf : tree
  | Node : tree -> dom -> tree -> tree.

Inductive direction : Set :=
  | L : direction
  | R : direction.

Definition ld := list direction.

Fixpoint elsewhere (t : tree) : Prop :=
  match t with
  | Leaf => True
  | Node t1 b t2 => elsewhere t1 /\ a <> b /\ elsewhere t2
  end.

Inductive path : ld -> tree -> Prop :=
  | path_leaf : forall t1 t2 : tree, path nil (Node t1 a t2)
  | path_node1 :
      forall (t1 t2 : tree) (b : dom) (l : ld),
      path l t1 -> path (L :: l) (Node t1 b t2)
  | path_node2 :
      forall (t1 t2 : tree) (b : dom) (l : ld),
      path l t2 -> path (R :: l) (Node t1 b t2).
Hint Resolve path_leaf path_node1 path_node2: huffman.

Lemma not_elsewhere :
 forall (t : tree) (l : ld), path l t -> elsewhere t -> False.
intros t l p. elim p; clear p l; simpl in |- *; try tauto.
(*  Intros t1 t2 (e1,(N,e2)); Case N; Reflexivity. *)
Qed.

Require Import Mx_defs.

Theorem lookup : forall t : tree, Mx (elsewhere t) {l : ld | path l t}.
fix 1.
intro t; case t; clear t.
  apply Mx_raise. simpl in |- *; trivial.
  intros t1 b t2; case (eg a b).
    intro E; apply Mx_unit. exists (nil (A:=direction)); case E; auto with huffman.

    intro N; apply Mx_try with (1 := lookup t1).
    intros (l, Hl). apply Mx_unit. exists (L :: l); auto with huffman.
    intro elsewhere_t1. apply Mx_bind with (1 := lookup t2).
      intros l2; apply Mx_unit; case l2; intros l Hl; exists (R :: l);
       auto with huffman.
      intro elsewhere_t2; simpl in |- *; auto.
Defined.

Theorem encode :
 forall t : tree, (exists l : ld, path l t) -> {l : ld | path l t}.
intros t Ht.
apply Mx_try with (1 := lookup t).
  intro x; exact x.
  intro et; exists (nil (A:=direction)).
    case Ht; intros l p. case (not_elsewhere t l); assumption.
Defined.

End sec_dom.

(* Extracting terms typed in system F but not in ML *)
(* In the extracted ML program, you have to
    - put an Obj.magic in front of each call to mx_try
      (at least for each recursive (then polymorphic) use of mx_try)
*)

Extract Inductive sumbool => "bool" [ "true" "false" ].
Extract Constant eg => "(=)".

Extraction "huff_extr.ml" Mx_unit Mx_raise Mx_try Mx_bind lookup encode.
Extraction Inline Mx_bind Mx_unit Mx_raise Mx_try.
Extraction "huff_opt_extr.ml" lookup encode.


(* week-05_mystery-functions.v *)
(* FPP 2020 - YSC3236 2020-2021, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 12 Sep 2020 *)

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

(* Your name: Bobbie Soedirgo
   Your student ID number: A0181001A
   Your e-mail address: sram-b@comp.nus.edu.sg
*)

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

(* Paraphernalia: *)

Ltac fold_unfold_tactic name := intros; unfold name; fold name; reflexivity.

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

Notation "A =b= B" :=
  (eqb A B) (at level 70, right associativity).

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

Definition specification_of_mystery_function_00 (mf : nat -> nat) :=
  mf 0 = 1 /\ forall i j : nat, mf (S (i + j)) = mf i + mf j.

(* ***** *)

Proposition there_is_at_most_one_mystery_function_00 :
  forall f g : nat -> nat,
    specification_of_mystery_function_00 f ->
    specification_of_mystery_function_00 g ->
    forall n : nat,
      f n = g n.
Proof.
  unfold specification_of_mystery_function_00.
  intros f g [S_f_O S_f_S] [S_g_O S_g_S] n.
  induction n as [| n' IHn'].
  - rewrite -> S_g_O.
    exact S_f_O.
  - Search (0 + _ = _).
    rewrite <- (plus_O_n n').
    rewrite -> (S_f_S 0 n').
    rewrite -> (S_g_S 0 n').
    rewrite -> S_f_O.
    rewrite -> S_g_O.
    rewrite -> IHn'.
    reflexivity.
Qed.

(* ***** *)

Definition unit_test_for_mystery_function_00a (mf : nat -> nat) :=
  (mf 0 =n= 1) (* etc. *).

Definition unit_test_for_mystery_function_00b (mf : nat -> nat) :=
  (mf 0 =n= 1) && (mf 1 =n= 2) (* etc. *).

Definition unit_test_for_mystery_function_00c (mf : nat -> nat) :=
  (mf 0 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) (* etc. *).

Definition unit_test_for_mystery_function_00d (mf : nat -> nat) :=
  (mf 0 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) && (mf 3 =n= 4)
  (* etc. *).

(* ***** *)

Definition mystery_function_00 := S.

Definition less_succinct_mystery_function_00 (n : nat) : nat :=
  S n.

Compute (unit_test_for_mystery_function_00d mystery_function_00).

Theorem there_is_at_least_one_mystery_function_00 :
  specification_of_mystery_function_00 mystery_function_00.
Proof.
  unfold specification_of_mystery_function_00, mystery_function_00.
  split.
  - reflexivity.
  - intros i j.
    rewrite -> (plus_Sn_m i (S j)).
    rewrite <- (plus_n_Sm i j).
    reflexivity.
Qed.

(* ***** *)

Definition mystery_function_00_alt := fun (n : nat) => n + 1.

Theorem there_is_at_least_one_mystery_function_00_alt :
  specification_of_mystery_function_00 mystery_function_00_alt.
Proof.
Abort.

(* ***** *)

Theorem soundness_of_the_unit_test_function_for_mystery_function_00 :
  forall mf : nat -> nat,
    specification_of_mystery_function_00 mf ->
    unit_test_for_mystery_function_00c mf = true.
Proof.
  unfold specification_of_mystery_function_00.
  unfold unit_test_for_mystery_function_00c.
  intros mf [H_O H_S].
  (* Goal: (mf 0 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  rewrite -> H_O.
  (* Goal: (1 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  rewrite -> (Nat.eqb_refl 1).
  (* Goal: true && (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  rewrite -> (andb_true_l (mf 1 =n= 2)).
  (* Goal: (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  (* etc. *)
  Check (Nat.add_1_l 0).
  rewrite <- (Nat.add_1_l 0) at 1.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  rewrite -> (Nat.add_1_l 1).
  Check (Nat.eqb_refl 2).
  rewrite -> (Nat.eqb_refl 2).
  rewrite -> (andb_true_l (mf 2 =n= 3)).
  Check (Nat.add_1_l 1).
  rewrite <- (Nat.add_1_l 1) at 1.
  Check (plus_Sn_m 0 1).
  rewrite -> (plus_Sn_m 0 1).
  rewrite -> (H_S 0 1).
  rewrite -> H_O.
  rewrite <- (Nat.add_1_l 0) at 2.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  rewrite -> (Nat.add_1_l 1).
  rewrite -> (Nat.add_1_l 2).
  exact (Nat.eqb_refl 3).
Qed.

Theorem soundness_of_the_unit_test_function_for_mystery_function_00b :
  forall mf : nat -> nat,
    specification_of_mystery_function_00 mf ->
    unit_test_for_mystery_function_00b mf = true.
Proof.
  unfold specification_of_mystery_function_00,
         unit_test_for_mystery_function_00b.
  intros mf [H_O H_S].
  (* Goal: (mf 0 =n= 1) && (mf 1 =n= 2) = true *)
  rewrite -> H_O.
  (* Goal: (1 =n= 1) && (mf 1 =n= 2) = true *)
  rewrite -> (Nat.eqb_refl 1).
  (* Goal: true && (mf 1 =n= 2) = true *)
  rewrite -> (andb_true_l (mf 1 =n= 2)).
  (* Goal: (mf 1 =n= 2) = true *)
  (* etc. *)
  Check (Nat.add_1_l 0).
  rewrite <- (Nat.add_1_l 0) at 1.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  Check (plus_Sn_m 0 1).
  rewrite -> (plus_Sn_m 0 1).
  Check (Nat.add_1_r 0).
  rewrite -> (Nat.add_1_r 0).
  Check (Nat.eqb_refl 2).
  exact (Nat.eqb_refl 2).
Qed.

Theorem soundness_of_the_unit_test_function_for_mystery_function_00_with_Search :
  forall mf : nat -> nat,
    specification_of_mystery_function_00 mf ->
    unit_test_for_mystery_function_00b mf = true.
Proof.
  unfold specification_of_mystery_function_00,
         unit_test_for_mystery_function_00b.
  intros mf [H_O H_S].

  rewrite -> H_O.
  Search (beq_nat _  _ = true).
  Check (Nat.eqb_refl 1).
  rewrite -> (Nat.eqb_refl 1).
  Search (true && _ = _).
  Check (andb_true_l (mf 1 =n= 2)).
  rewrite -> (andb_true_l (mf 1 =n= 2)).

  Check (Nat.add_1_l 0).
  rewrite <- (Nat.add_1_l 0) at 1.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  Check (plus_Sn_m 0 1).
  rewrite -> (plus_Sn_m 0 1).
  Check (Nat.add_1_r 0).
  rewrite -> (Nat.add_1_r 0).
  Check (Nat.eqb_refl 2).
  exact (Nat.eqb_refl 2).
Qed.

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

Definition specification_of_mystery_function_11 (mf : nat -> nat) :=
  mf 1 = 1
  /\
  forall i j : nat,
    mf (i + j) = mf i + 2 * i * j + mf j.

Lemma about_mystery_function_11 :
  forall f : nat -> nat,
    specification_of_mystery_function_11 f ->
    f 0 = 0.
Proof.
  unfold specification_of_mystery_function_11.
  intros f [S_f_1 S_f_S].
  Check (S_f_S 0 1).
  assert (H_f := S_f_S 0 1).
  rewrite -> (plus_O_n 1) in H_f.
  Search (_ * 0 = 0).
  rewrite -> (Nat.mul_0_r 2) in H_f.
  Search (0 * _ = 0).
  rewrite -> (Nat.mul_0_l 1) in H_f.
  Search (_ + 0 = _).
  rewrite -> (Nat.add_0_r (f 0)) in H_f.
  rewrite -> (Nat.add_comm (f 0) (f 1)) in H_f.
  rewrite <- (Nat.add_0_r (f 1)) in H_f at 1.
  Search (_ + _ = _ -> _ = _).
  Check (plus_reg_l 0 (f 0) (f 1) H_f).
  symmetry.
  exact (plus_reg_l 0 (f 0) (f 1) H_f).
Qed.

Theorem there_is_at_most_one_mystery_function_11 :
  forall f g : nat -> nat,
    specification_of_mystery_function_11 f ->
    specification_of_mystery_function_11 g ->
    forall n : nat,
      f n = g n.
Proof.
  unfold specification_of_mystery_function_11.
  intros f g [S_f_O S_f_S] [S_g_O S_g_S] n.
  induction n as [| n' IHn'].
  - Check (about_mystery_function_11 g (conj S_g_O S_g_S)).
    rewrite -> (about_mystery_function_11 g (conj S_g_O S_g_S)).
    exact (about_mystery_function_11 f (conj S_f_O S_f_S)).
Abort.

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

Definition specification_of_mystery_function_04 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  forall n' : nat,
    mf (S n') = mf n' + S (2 * n').

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

Definition specification_of_mystery_function_15 (mf : nat -> nat * nat) :=
  mf 0 = (0, 1)
  /\
  forall n' : nat,
    mf (S n') = let (x, y) := mf n'
                in (S x, y * S x).

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

Definition specification_of_mystery_function_16 (mf : nat -> nat * nat) :=
  mf 0 = (0, 1)
  /\
  forall n' : nat,
    mf (S n') = let (x, y) := mf n'
                in (y, x + y).

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

Definition specification_of_mystery_function_17 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 1
  /\
  mf 2 = 1
  /\
  forall p q : nat,
    mf (S (p + q)) = mf (S p) * mf (S q) + mf p * mf q.

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

Definition specification_of_mystery_function_18 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 1
  /\
  mf 2 = 1
  /\
  forall n''' : nat,
    mf n''' + mf (S (S (S n'''))) = 2 * mf (S (S n''')).

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

Definition specification_of_mystery_function_03 (mf : nat -> nat -> nat) :=
  mf 0 0 = 0
  /\
  (forall i j: nat, mf (S i) j = S (mf i j))
  /\
  (forall i j: nat, S (mf i j) = mf i (S j)).

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

Definition specification_of_mystery_function_42 (mf : nat -> nat) :=
  mf 1 = 42
  /\
  forall i j : nat,
    mf (i + j) = mf i + mf j.

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

Definition specification_of_mystery_function_07 (mf : nat -> nat -> nat) :=
  (forall j : nat, mf 0 j = j)
  /\
  (forall i : nat, mf i 0 = i)
  /\
  (forall i j k : nat, mf (i + k) (j + k) = (mf i j) + k).

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

Definition specification_of_mystery_function_08 (mf : nat -> nat -> bool) :=
  (forall j : nat, mf 0 j = true)
  /\
  (forall i : nat, mf (S i) 0 = false)
  /\
  (forall i j : nat, mf (S i) (S j) = mf i j).

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

Definition specification_of_mystery_function_23 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 0
  /\
  forall n'' : nat,
    mf (S (S n'')) = S (mf n'').

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

Definition specification_of_mystery_function_24 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 1
  /\
  forall n'' : nat,
    mf (S (S n'')) = S (mf n'').

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

Definition specification_of_mystery_function_13 (mf : nat -> nat) :=
  (forall q : nat, mf (2 * q) = q)
  /\
  (forall q : nat, mf (S (2 * q)) = q).

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

Definition specification_of_mystery_function_25 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  (forall q : nat,
      mf (2 * (S q)) = S (mf (S q)))
  /\
  mf 1 = 0
  /\
  (forall q : nat,
      mf (S (2 * (S q))) = S (mf (S q))).

(* ****** *)

Definition specification_of_mystery_function_20 (mf : nat -> nat -> nat) :=
  (forall j : nat, mf O j = j)
  /\
  (forall i j : nat, mf (S i) j = S (mf i j)).

(* ****** *)

Definition specification_of_mystery_function_21 (mf : nat -> nat -> nat) :=
  (forall j : nat, mf O j = j)
  /\
  (forall i j : nat, mf (S i) j = mf i (S j)).

(* ****** *)

Definition specification_of_mystery_function_22 (mf : nat -> nat -> nat) :=
  forall i j : nat,
    mf O j = j
    /\
    mf (S i) j = mf i (S j).

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

(* Binary trees of natural numbers: *)

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

Definition specification_of_mystery_function_19 (mf : tree -> tree) :=
  (forall n : nat,
     mf (Leaf n) = Leaf n)
  /\
  (forall (n : nat) (t : tree),
     mf (Node (Leaf n) t) = Node (Leaf n) (mf t))
  /\
  (forall t11 t12 t2 : tree,
     mf (Node (Node t11 t12) t2) = mf (Node t11 (Node t12 t2))).

(* You might not manage to prove
   that at most one function satisfies this specification (why?),
   but consider whether the following function does.
   Assuming it does, what does this function do?
   And what is the issue here?
*)

Fixpoint mystery_function_19_aux (t a : tree) : tree :=
  match t with
  | Leaf n =>
     Node (Leaf n) a
  | Node t1 t2 =>
     mystery_function_19_aux t1 (mystery_function_19_aux t2 a)
  end.

Fixpoint mystery_function_19 (t : tree) : tree :=
  match t with
  | Leaf n =>
     Leaf n
  | Node t1 t2 =>
     mystery_function_19_aux t1 (mystery_function_19 t2)
  end.

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

Definition specification_of_mystery_function_05 (mf : nat -> nat) :=
  mf 0 = 1
  /\
  forall i j : nat,
    mf (S (i + j)) = 2 * mf i * mf j.

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

Definition specification_of_mystery_function_06 (mf : nat -> nat) :=
  mf 0 = 2
  /\
  forall i j : nat,
    mf (S (i + j)) = mf i * mf j.

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

Definition specification_of_mystery_function_09 (mf : nat -> bool) :=
  mf 0 = false
  /\
  mf 1 = true
  /\
  forall i j : nat,
    mf (i + j) = xorb (mf i) (mf j).

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

Definition specification_of_mystery_function_10 (mf : nat -> bool) :=
  mf 0 = false
  /\
  mf 1 = true
  /\
  forall i j : nat,
    mf (i + j) = (mf i =b= mf j).

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

Definition specification_of_mystery_function_12 (mf : nat -> nat) :=
  mf 1 = 1
  /\
  forall i : nat,
    mf (S (S i)) = (S (S i)) * mf (S i).

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

Definition specification_of_mystery_function_14 (mf : nat -> bool) :=
  (forall q : nat, mf (2 * q) = true)
  /\
  (forall q : nat, mf (S (2 * q)) = false).

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

(* Simple examples of specifications: *)

(* ***** *)

Definition specification_of_the_factorial_function (fac : nat -> nat) :=
  fac 0 = 1
  /\
  forall n' : nat, fac (S n') = S n' * fac n'.

(* ***** *)

Definition specification_of_the_fibonacci_function (fib : nat -> nat) :=
  fib 0 = 0
  /\
  fib 1 = 1
  /\
  forall n'' : nat,
    fib (S (S n'')) = fib n'' + fib (S n'').

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

(* end of week-05_mystery-functions.v *)


Require Import Bool.
Require Import Peano.
Require Import Omega.           (* I use this to handle a bunch of mundane index calculations*)

(* Summary:
We have the following notions of finiteness:

Definition Eaf (f: nat -> bool) := {n | forall m, m>=n -> f m = false}.
Definition StrictlyBounded (f: nat -> bool ):= {n | ((forall k, NrOfTrue k <= n) /\
                                    (forall np, (np< n) -> (not ((forall k, NrOfTrue k <= np) ))))}.
Definition Bounded (f: nat -> bool) := {n | ((forall k, NrOfTrue k <= n))}.

And we also have the following properties:
Definition Markovs_Principle:= forall P, DecidableP nat P ->  (({n: nat| P n} -> False)-> False) -> {n: nat| P n}.
Definition WLPO := forall g:nat->bool, {forall n,g n=false} + {not (forall n,g n=false)}.

StrictlyBounded also have an equivalent formulation, proven equivalent below:
Definition StrictlyBoundedAlternative := {n | ((forall k, NrOfTrue k <= n) /\
                                        (not ((forall k, NrOfTrue k < n))))}.

It is straightforward to see that we have: Eaf->StrictlyBounded->Bounded

In this file we prove the following:
(StrictlyBounded->Eaf) <-> Markovs_principle
(Bounded->StrictlyBounded) <-> WLPO.

Only the important results are prefixed with Theorem, all the helpers are prefixed with Lemma.
 *)

  Definition WLPO := forall g:nat->bool, {forall n,g n=false} + {not (forall n,g n=false)}.

  Definition WLPOInv := forall g:nat->bool, {forall n,g n=true} + {not (forall n,g n=true)}.

  (* Markovs_Principle *)
  Definition DecidableP (A: Set)(P: A -> Prop) := forall a: A, {(P a)} + {~(P a)}.

  Definition Markovs_Principle:= forall P, DecidableP nat P ->  (({n: nat| P n} -> False)-> False) -> {n: nat| P n}.
  (* A formalization of Markovs principle using streams instead of predicates*)
  Definition  MP:= (forall g:nat->bool,  (({ n: nat | g n = true} -> False)-> False) -> { n: nat | g n = true}).

  Lemma WLPOImplWPOAlt: WLPO -> WLPOInv.
  Proof.
    intro.
    unfold WLPO in H.
    set (gneg :=  (fun x=> negb x )).
    intro.
    assert ({(forall n : nat, negb (g n) = false)} + {~ (forall n : nat, negb (g n) = false)});auto.
    elim H0;intros;auto.
    left;simpl;auto.
    intro.
    assert ( negb (g n) = false);auto.
    assert (true = negb false);auto.
    rewrite H2.
    rewrite<- H1;auto.
    assert (negb (negb (g n)) = g n);auto.
    apply negb_involutive.
    right;simpl;auto.
    intro.
    apply b.
    intro.
    assert (g n = true);auto.
    assert (false = negb true);auto.
    rewrite H3.
    rewrite H2.
    auto.
  Qed.

  Lemma WLPOAltImplWPO: WLPOInv ->  WLPO.
  Proof.
    intro.
    unfold WLPOInv in H.
    set (gneg :=  (fun x=> negb x )).
    intro.
    assert ({(forall n : nat, negb (g n) = true)} + {~ (forall n : nat, negb (g n) = true)});auto.
    elim H0;intros;auto with bool.
    left;simpl;auto with bool.
    intro.
    assert ( negb (g n) = true);auto with bool.
    assert (false = negb true);auto with bool.
    rewrite H2.
    rewrite<- H1;auto with bool.
    assert (negb (negb (g n)) = g n);auto with bool.
    apply negb_involutive.
    right;simpl;auto with bool.
    intro.
    apply b.
    intro.
    assert (g n = false);auto with bool.
    assert (true = negb false);auto with bool.
    rewrite H3.
    rewrite H2.
    auto.
  Qed.

  Lemma MarkPrinImplMP: Markovs_Principle -> MP.
  Proof.
    intros.
    intro.
    intro.
    apply X;auto.
    intro.
    destruct (g a);auto.
  Qed.

  Lemma MPImplMarkPrinciple(mp:MP): Markovs_Principle .
    Proof.
      unfold MP in mp.
      unfold Markovs_Principle.
      intros.
      unfold DecidableP in H.
      set (decider := (fun x => if (H x) then true else false)).
      assert ((({n : nat | decider n = true} -> False) -> False) -> {n :nat | decider n = true});auto.
      assert (forall a, (P a) <-> (decider a = true));auto.
      intros.
      split;intros;auto.
      unfold decider;elim (H a);auto.
      unfold decider in H2.
      induction (H a);auto.
      contradict H2;auto.
      assert ((({n : nat | decider n = true} -> False) -> False)).
      firstorder.
      assert ({n :nat | decider n = true});auto.
      elim H4;intros.
      exists x.
      apply H2;auto.
    Qed.

 Section notionsOfFiniteness.
  Variable f: nat -> bool.

  (* Counts the nr of n s.t n<=m and f n = true *)
  Fixpoint NrOfTrue (m : nat) : nat :=
    match m with
      | 0 => if (f 0) then 1 else 0
      | S n => if (f (S n)) then (S (NrOfTrue n) ) else (NrOfTrue n)
    end.

  Definition Eaf := {n | forall m, m>=n -> f m = false}.

  (* Two equivalent versions of strictly bounded (proven equivalent below in "StrictlyBoundedSTBPredEQ") *)
  Definition StrictlyBounded := {n | ((forall k, NrOfTrue k <= n) /\
                                    (forall np, (np< n) -> (not ((forall k, NrOfTrue k <= np) ))))}.

  Definition StrictlyBoundedAlternative := {n | ((forall k, NrOfTrue k <= n) /\
                                        (not ((forall k, NrOfTrue k < n))))}.

  (* Sigma n. all k. #{i | 0 <= i <= k & f(i)=1} <= n *)
  Definition Bounded := {n| ((forall k, NrOfTrue k <= n))}.

  Lemma decidableF: forall n:nat, f n = true \/ f n = false.
  Proof.
    intros.
    induction (f n);auto.
  Qed.

  Lemma NrOfTrueIsMonotoneOneStep:  forall m:nat,   (NrOfTrue  m ) <= (NrOfTrue  (S m)).
    intros.
    assert (forall n:nat, f n = true \/ f n = false).
    apply decidableF;auto.
    induction m;auto.
    unfold NrOfTrue.
    assert (f 0 = true \/ f 0 = false);auto.
    assert (f 1 = true \/ f 1 = false);auto.
    simpl.
    case H0;intro;case H1;auto;intros;rewrite H2;auto;simpl;auto with arith;rewrite H3;auto.
    assert (f (S m) = true \/ f (S m)=false);auto.
    assert (f (S (S m)) = true \/ f (S (S m))=false);auto.
    case H0;intro;case H1;auto;intros. simpl.
    rewrite H2;rewrite H3;auto.
    unfold NrOfTrue.
    rewrite H2;rewrite H3;auto.
    unfold NrOfTrue.
    rewrite H2;rewrite H3;auto.
    unfold NrOfTrue.
    rewrite H2;rewrite H3;auto.
  Qed.

  Hint Resolve   NrOfTrueIsMonotoneOneStep.

  Lemma NrOfTrueIsMonotone:  forall m n :nat, m <=n ->  (NrOfTrue  m ) <= (NrOfTrue  n).
  Proof.
    intros.
    induction n;auto with arith.
    inversion H;auto.
    elim (eq_nat_dec m n);intros;auto.
    rewrite a;auto.
    elim (eq_nat_dec m (S(n)));intros;auto.
    rewrite a;auto.
    assert (m<n);auto with arith.
    omega.
    assert (NrOfTrue m <= NrOfTrue n);auto.
    apply IHn.
    omega.
    assert (NrOfTrue n <= NrOfTrue (S(n)));auto.
    firstorder.
  Qed.
  Hint Resolve   NrOfTrueIsMonotone.

  Lemma NrOfTrueIsMonotoneConverse:  forall m n :nat, m <=n -> (NrOfTrue  n)  >= (NrOfTrue  m ).
  Proof.
    intros.
    firstorder.
  Qed.
  Hint Resolve   NrOfTrueIsMonotoneConverse.

  Theorem StrictlyBoundedSTBPredEQ: (StrictlyBounded -> StrictlyBoundedAlternative) * (StrictlyBoundedAlternative -> StrictlyBounded).
  Proof.
    split;intros H.
    unfold StrictlyBounded in H.
    unfold StrictlyBoundedAlternative.
    elim H;intros x p.
    pose (zerop x).
    inversion s.
    exists x.
    inversion p;auto.
    split;auto.
    intro.
    pose (H3 1).
    omega.
    exists x.
    inversion p;auto.
    split;auto.
    intro.
    apply  (H2 (pred x)).
    omega.
    intro.
    pose (H3 k).
    omega.
    (* Done with (StrictlyBounded -> StrictlyBoundedAlternative) *)
    unfold StrictlyBoundedAlternative in H.
    unfold StrictlyBounded.
    elim H;intros x p.
    elim p;intros H0 H1.
    exists x.
    split;auto.
    intros.
    elim (zerop x);intros;auto.
    omega.
    intro.
    apply H1.
    intro.
    pose (H3 k).
    inversion l;auto.
    rewrite H4.
    auto.
    omega.
  Qed.

  (* We introduce the x-limit such the nrOfTrue is always smaller than it.
     We then proceed to show that there is an index such that nrOfTrue is exactly x-limit. For this we use MP.
     So we need to get a contradiction from the assumption ~ (exists n : nat, NrOfTrue n = x)
     This assumption lets us proof that forall n : nat, NrOfTrue n <> x, and then forall n : nat, NrOfTrue n < x
     Then we branch on wether x is 0 or S(p). In the first case it is easy. In the other case we have p<x, giving
      ~ (forall k : nat, NrOfTrue k <= p), contradicting  forall n : nat, NrOfTrue n < x.

     Then we let the index be that number + 1, and we need to show that every element of f after this is false. This is proved by induction, and the fact that NrOfTrue is monotone.

     *)
  Lemma MarkovsPAndSTBImplEaf:  Markovs_Principle -> (StrictlyBoundedAlternative -> Eaf).
  Proof.
    intro mp.
    intro sd.
    unfold Markovs_Principle in mp.
    unfold StrictlyBounded in sd.
    unfold Eaf.
    elim sd;intros x p.
    elim p.
    intro xlim.
    intro xsmallest.
    assert ({index | NrOfTrue index = x});auto.
    apply mp.
    intro.
    apply eq_nat_dec.
    intro.
    assert (forall  n : nat, not (NrOfTrue n = x));auto.
    intro.
    intro.
    apply H.
    exists n;auto.
    assert (forall n : nat, NrOfTrue n < x);auto.
    intros.
    assert (NrOfTrue n <= x);auto.
    assert (NrOfTrue n <> x);auto.
    omega.

    elim H.
    intros x0 p0.
    exists (S(x0)).
    intros.

    assert (f m = false \/ f m = true);auto.
    induction (f m);auto.
    elim H1;auto.
    intros.

    assert (NrOfTrue m <= x);auto.
    inversion H0.
    intros.
    rewrite<- H4 in H2.
    assert ( NrOfTrue  (S(x0)) <= NrOfTrue  m);auto.
    assert (m <= S x0);auto.
    rewrite H4;auto.

    assert ( NrOfTrue (S x0) = S(x));auto.
    rewrite<- p0.
    simpl.
    rewrite H2.
    omega.
    rewrite H2.
    omega.
    assert ((S x0) < m);auto.
    omega.
    assert (x0 < m);auto.
    assert (NrOfTrue x0 <= NrOfTrue m);auto.
    apply NrOfTrueIsMonotone.
    omega.
    assert (NrOfTrue m = x);auto.
    rewrite p0 in H8.
    eauto.
    omega.
    assert (exists p, m = S(p));auto.
    exists (pred m).
    omega.
    elim H10.
    intro p1.
    intros.
    assert (NrOfTrue m = S(NrOfTrue p1));auto.
    compute;simpl;auto.
    rewrite H11;auto;simpl;auto.
    rewrite<- H11.
    rewrite H2.
    auto.
    assert ((NrOfTrue p1) < NrOfTrue m);auto.
    rewrite H12;auto.
    assert ((NrOfTrue p1) < x);auto.
    rewrite<- H9;auto.
    assert (x <= NrOfTrue m);auto.
    rewrite p0 in H8;auto.
    assert (p1>=x0);auto.
    omega.
    inversion H16.
    omega.
    assert (x0 < p1).
    omega.
    assert (NrOfTrue x0 <= NrOfTrue p1);auto.
    assert (NrOfTrue x0 < NrOfTrue m);auto.
    omega.
    firstorder.
   Qed.

  End notionsOfFiniteness.

(* If there exists a positive index in the stream for which the predicate holds, there is a smallest*)
Lemma FindingSmallestInBoundedRange: forall P:nat->bool, {n:nat | P n = true}-> (P 0)=false
                                                         -> {n | P n = true /\ P (pred n) = false}.
Proof.
  intros.
  elim H.
  intro upperlimit.
  intros.
  induction upperlimit;auto.
  congruence.
  assert ({P upperlimit=true} + {P upperlimit = false});auto.
  elim (P upperlimit);auto.
  elim H1;intro;auto.
  exists (S upperlimit);auto.
Qed.
Hint Resolve   FindingSmallestInBoundedRange.

Lemma FindingSmallestInBoundedRangePred (P:nat->Prop)(decidable: forall n, {P n}+{not (P n)}):  ({ n | P n}) ->  not (P 0) -> {n | P n  /\ not( P (pred n))}.
Proof.
  intros.
  elim H.
  intro upperlimit.
  intros.
  induction upperlimit;auto.
  congruence.
  assert ({P upperlimit} + {not (P upperlimit)});auto.
  elim H1;intro;auto.
  exists (S upperlimit);auto.
Qed.
Hint Resolve FindingSmallestInBoundedRangePred.

Lemma trueOrFalse(a b :bool) : {a = b} + {a=negb b}.
Proof.
  compute.
  elim a;elim b;intros;auto.
 Qed.
Hint Resolve   trueOrFalse.

Lemma inBoundedRangeDecidable (g:nat->bool)(limit:nat)(value:bool):{x | x<=limit /\ g x = value} + {(forall x, x<=limit -> not (g x = value))}.
Proof.
  pose (trueOrFalse (g limit) value) as H.
  pose (trueOrFalse (g 0) value) as H0.
  elim H;intro limval;elim H0; intro valval;try (rewrite hval);try (rewrite valval).
  left; exists limit;auto.
  left; exists limit;auto.
  left; exists 0;auto.
  split;auto.
  omega.
  induction limit;auto.
  right;auto.
  intros.
  assert (x=0).
  omega.
  rewrite H2.
  rewrite valval.
  apply no_fixpoint_negb.
  assert ({g limit =  value} + {g limit = negb value});auto.
  elim H1;intros.
  left.
  exists limit;auto.
  assert (            {x : nat| x <= limit /\ g x = value} +
            {(forall x : nat, x <= limit -> g x <> value)});auto.
  elim H2;intros;auto.
  left.
  elim a;intros x H3;auto.
  elim H3.
  exists x;auto.
  assert ({g (S limit) =  value} + {g (S limit) = negb value});auto.
  elim H3;intros;auto.
  left.
  exists (S limit);auto.
  right.
  intros.
  assert ({x <= limit} + {limit < x}).
  apply(le_lt_dec x limit);auto.
  elim H5;auto;intros;auto.
  assert (x = S limit);auto.
  omega.
  rewrite H6;auto.
  rewrite b1;apply no_fixpoint_negb.
Qed.
Hint Resolve   inBoundedRangeDecidable.

Lemma inBoundedRangeDecidableStrict (g:nat->bool)(limit:nat)(value:bool):{x | x<limit /\ g x = value} + {(forall x, x<limit -> not (g x = value))}.
Proof.
  pose (zerop limit).
  inversion s.
  right.
  intro.
  omega.
  pose (inBoundedRangeDecidable g (pred limit) value) as s0.
  inversion s0;auto.
  left.
  inversion H0.
  inversion H1.
  exists x.
  split;auto.
  omega.
  right.
  intros.
  pose (H0 x).
  apply n.
  omega.
Qed.
Hint Resolve   inBoundedRangeDecidableStrict.

Lemma NrOfTrueWithConstantNegFunction (trues lim:nat )(f : nat-> bool) :  ((NrOfTrue f lim)=trues /\ forall x, x>lim -> f x = false) -> forall y, y>lim -> (NrOfTrue f y )=trues.
    Proof.
      intros.
      elim H;intros.
      induction y;auto.
      contradict H0.
      omega.
      assert (f (S y) = false);auto.
      assert (NrOfTrue f y = trues);auto.
      elim (eq_nat_dec y lim);intro.
      rewrite a;auto.
      apply IHy.
      omega.
      unfold NrOfTrue.
      rewrite H3.
      auto.
    Qed.

Fixpoint trueOnFirst (g:nat-> bool) (n:nat):  (bool):=
  match n with
    | 0 => (g 0)
    | S n =>  if (g (S n)) then if (inBoundedRangeDecidable g n true ) then false else true   else false
  end.

Lemma nrOftrueIntrueIsLimitedByfalse(g:nat->bool): forall k, (forall x, x<=k ->  g x = false) <->  NrOfTrue  g k=0.
Proof.
intros.
induction k;auto.
split.
intros.
assert (g 0 =false);auto.
compute.
rewrite H0;auto.
intros.
assert (x=0).
omega.
rewrite H1.
unfold NrOfTrue in H.
induction (g 0);auto.
contradict H.
omega.

split.
intros.
assert ( NrOfTrue g k = 0);auto.
apply IHk.
intros.
apply H;auto.
assert (g ( S k) = false);auto.
compute;auto.
rewrite H1.
simpl.
assert ({k<=0} + {0<k}).
apply (le_lt_dec).
elim H2;auto.
intros.
assert (NrOfTrue g k = 0);auto.
assert (NrOfTrue g k <= NrOfTrue g (S k));auto.
apply NrOfTrueIsMonotone.
omega.
omega.
assert ((forall x : nat, x <= k -> g x = false));auto.
apply IHk;auto.

assert ({S k<=x} + {x<S k}).
apply (le_lt_dec).
elim H3;intros;auto.
assert (x = S k);auto.
omega.
rewrite H4.
unfold NrOfTrue in H.
induction (g (S k));auto.
contradict H.
omega.
apply H2.
omega.
Qed.
Hint Resolve   nrOftrueIntrueIsLimitedByfalse.

Lemma trueOnFirstImplTrueForG(g:nat->bool): (forall x, (trueOnFirst g) x = true -> (g x)=true).
Proof.
intros.
induction x;auto.
unfold trueOnFirst in H.
induction (g (S x));auto.
Qed.

Hint Resolve trueOnFirstImplTrueForG.

Lemma trueOnFirstAlwaysFalseAfter(g:nat->bool): (forall x, (trueOnFirst g) x = true -> forall y, y>x ->(trueOnFirst g) y = false).
Proof.
  intro.
  intro.
  intro.
  induction y;intros;auto.
  contradict H0.
  omega.

  assert ({x=y}+{x<>y});auto.
  apply (eq_nat_dec x y);auto.
  induction H1;intros;auto.
  assert (g x = true);auto.
  unfold trueOnFirst.
  induction (g (S y));auto.
  induction (inBoundedRangeDecidable g y);auto.
  intros.
  assert (x <= y -> g x <> true);auto.
  rewrite a in H2.
  assert ( g y <> true);auto.
  rewrite<- a in H3.
  contradict H3;auto.

  assert (x < y);auto.
  omega.
  assert (trueOnFirst g y = false);auto.
  unfold trueOnFirst.
  induction (g ( S y));auto.
  induction (inBoundedRangeDecidable g y);auto.
  intros.
  assert ( g x <> true).
  apply b0;auto.
  omega.
  contradict H3.
  apply trueOnFirstImplTrueForG;auto.
Qed.
Hint Resolve trueOnFirstAlwaysFalseAfter.

Lemma trueOnFirstConstantFalseImplConstantFalseHelper(g:nat->bool)(lim:nat):(forall x : nat,x<=lim ->  trueOnFirst g x = false) -> ((forall n : nat,n<=lim ->  g n = false)).
Proof.
  induction lim;intros.
  assert (n=0).
  omega.
  assert (trueOnFirst g 0 = false);auto.
  rewrite H1.
  auto.
  elim (eq_nat_dec n (S lim));intros;auto.
  rewrite a.
  assert (trueOnFirst g (S lim) = false);auto.
  unfold trueOnFirst in H1.
  induction (g (S lim));auto.
  induction (inBoundedRangeDecidable g lim true);auto.
  elim a0;intros x H2;auto.
  elim H2;intros.
  assert (g x = false).
  apply IHlim;intros;auto.
  rewrite<- H4.
  rewrite<- H5.
  auto.
  assert (n<=lim);auto.
  omega.
Qed.
Hint Resolve trueOnFirstConstantFalseImplConstantFalseHelper.

Lemma trueOnFirstConstantFalseImplConstantFalse(g:nat->bool):(forall x : nat, trueOnFirst g x = false) -> ((forall n : nat, g n = false)).
Proof.
  intro.
  intro lim.
  assert (((forall n : nat,n<=lim ->  g n = false)));auto.
  apply trueOnFirstConstantFalseImplConstantFalseHelper;auto.
Qed.

Lemma nrOftrueIntrueOnFirstStays1Succ(g:nat->bool): forall k, NrOfTrue (trueOnFirst g) k=1->NrOfTrue (trueOnFirst g) (S k)=1.
  Proof.
    intros.
    apply (NrOfTrueWithConstantNegFunction 1 k  );auto.
    split;auto.
    intros.
    assert ({x : nat | x <= k /\ (trueOnFirst g ) x = true} +
            {(forall x : nat, x <= k -> (trueOnFirst g ) x <> true)});auto.

    elim H1;intros;auto.
    elim a.
    intros x0 H2.
    elim H2;intros.
    apply (trueOnFirstAlwaysFalseAfter g x0);auto.
    omega.
    assert (forall x : nat, x <= k -> trueOnFirst g x =false );auto.
    intros.
    assert (trueOnFirst g x0 <> true);auto.
    apply (not_true_iff_false);auto.
    assert (trueOnFirst g 0 = false);auto.
    apply H2;auto.
    omega.
    assert (NrOfTrue (trueOnFirst g) 0 = 0);auto.
    unfold NrOfTrue.
    rewrite H3;auto.
    assert (NrOfTrue (trueOnFirst g) k = 0);auto.
    apply nrOftrueIntrueIsLimitedByfalse;intros;auto.
    contradict H;auto.
    omega.
  Qed.
Hint Resolve nrOftrueIntrueOnFirstStays1Succ.

Lemma nrOftrueIntrueOnFirstIs1or0(g:nat->bool): forall k, NrOfTrue (trueOnFirst g) k<=1.
Proof.
  intro.
  induction k;auto.
  unfold NrOfTrue.
  elim (trueOnFirst g 0);auto.
  elim (lt_eq_lt_dec (NrOfTrue (trueOnFirst g) k) 1 );intro.
  elim a;auto;intros;auto.
  assert (NrOfTrue (trueOnFirst g) k=0);auto.
  omega.
  unfold NrOfTrue.
  elim (trueOnFirst g (S k));auto.
  assert (NrOfTrue (trueOnFirst g) (S k) = 1).
  apply nrOftrueIntrueOnFirstStays1Succ;auto.
  omega.
  contradict IHk.
  omega.
Qed.

Theorem EafAndSTBImplMarkovsP (arrow: forall f,  StrictlyBoundedAlternative f -> Eaf f) : Markovs_Principle.
    Proof.
      apply MPImplMarkPrinciple;auto.
      unfold MP.
      unfold StrictlyBoundedAlternative in arrow.
      unfold Eaf in arrow.
      intros.
      assert ( ~ (forall n : nat, not (g n = true)));auto.
      intro.
      firstorder.
      assert ( ~ (forall n : nat, g n = false));auto.
      intro.
      apply H0;intros;auto.
      assert (g n = false);auto.
      rewrite H2.
      congruence.

      (* NEW: *)
      assert {n : nat | forall m : nat, m >= n -> (trueOnFirst g) m = false};auto.
      apply arrow;auto.
      exists 1;intros;auto.
      split;intros;auto.
      apply (nrOftrueIntrueOnFirstIs1or0).
      intro.
      assert (forall k : nat, NrOfTrue (trueOnFirst g) k = 0);intros;auto.
      pose (H2 k).
      omega.
      pose (nrOftrueIntrueIsLimitedByfalse (trueOnFirst g)).
      assert ( forall k : nat, (forall x : nat, x <= k -> trueOnFirst g x = false) );auto.
      intro.
      apply i;auto.
      pose (trueOnFirstConstantFalseImplConstantFalse g ).
      apply H1.
      apply e;auto.
      intro.
      apply (H4 x x).
      auto.

      elim H2.
      intro limit.
      intros H3.
      assert {y | (trueOnFirst g y) = true};auto.
      assert ({x : nat | ( x <= limit /\ (trueOnFirst g x) = true)} +
              {(forall x : nat, x <= limit -> (trueOnFirst g x) <> true)}).
      apply inBoundedRangeDecidable.
      elim H4;auto.
       intros.
       elim a;intros.
       exists x;auto.
       firstorder.
       intros.
       assert (forall x : nat, x <= limit -> trueOnFirst g x = false);auto.
       intros.
       assert (trueOnFirst g x <> true);auto.
       apply not_true_iff_false;auto.
       assert (forall x : nat,  trueOnFirst g x = false);auto.
       intros.
       elim (lt_eq_lt_dec x limit);intros;auto.
       elim a;intros;auto.
       apply H5;auto.
       omega.
       apply H5;auto.
       omega.
       apply H3;auto.
       omega.
       assert (forall n : nat, g n = false);auto.
       apply trueOnFirstConstantFalseImplConstantFalse;auto.
       contradict H7;auto.
       elim H4.
       intros.
       exists x;auto.
    Qed.

Theorem MarkovsPAndSTBImplEafOuter:  Markovs_Principle ->forall f:nat->bool,  (StrictlyBounded f) -> (Eaf f).
  intros M f.
  intro.
  apply (MarkovsPAndSTBImplEaf f M).
  apply StrictlyBoundedSTBPredEQ.
  auto.
Qed.

Lemma WLPOImplBoundedImplSTBPred:  WLPO -> (forall f:nat->bool,  (Bounded f) -> (StrictlyBoundedAlternative f)).
Proof.
  intros.
  unfold WLPO in H.
  unfold Bounded in H0.
  unfold StrictlyBoundedAlternative.
  elim H0.
  intro upperlimit.
  intro H1.

  assert(forall g : nat -> bool,
           {(forall n : nat, g n = true)} + {~ (forall n : nat, g n = true)});auto.
  apply  WLPOImplWPOAlt;auto.

  assert (forall pl, (forall n : nat,
                        ((NrOfTrue f n)<=pl) <->
                        ((Compare_dec.leb (NrOfTrue f n) pl) = true))).

  intro;auto.
  split;intros.
  assert (NrOfTrue f n <= pl);auto.
  apply leb_correct;auto.
  assert(Compare_dec.leb (NrOfTrue f n) pl = true);auto.
  apply leb_complete;auto.

  set (B:=(fun pl k=>  (Compare_dec.leb (NrOfTrue f k) pl))).
  (* Lets try 0 first. *)

  assert ((forall k : nat, NrOfTrue f k <= 0) +
          ~ (forall k : nat, NrOfTrue f k <=  0));auto.

  elim (H2 (B 0));auto;intros.
  left;auto.
  intro.
  assert (B 0 k = true);auto.
  unfold B in H4.
  apply H3;auto.
  right.
  unfold not in b.
  unfold not.
  unfold B in b.
  intro.
  apply b.
  intros.
  assert (NrOfTrue f n <= 0);auto.
  apply H3;auto.
  elim H4.
  intro.
  (*0 is our strict bound if 0 is a bound  *)
  exists 0;auto.
  split;auto.
  intro.
  pose (H5 1).
  omega.

  (* We are not in the zero case *)
  intro notZero.
  clear H4.

  assert ({n: nat|
            (forall k : nat, NrOfTrue f k <= n) /\
            (~ (forall k : nat, NrOfTrue f k <= pred n))}).

  apply FindingSmallestInBoundedRangePred.
  intros pl.
  elim (H2 (B pl));auto;intros.
  left;auto.
  intro.
  assert (B pl k = true);auto.
  unfold B in H4.
  apply H3;auto.
  right.
  unfold not in b.
  unfold not.
  intro.
  apply b.
  intro.
  unfold B.
  assert (NrOfTrue f n <= pl);auto.
  apply H3;auto.
  exists upperlimit.
  auto.
  intro.
  apply notZero;auto.
  elim H4.
  intros x H5.
  exists x.
  elim H5.
  intros.
  split;auto.
  intro.
  apply H7.
  intro.
  pose (H8 k).
omega.
Qed.

Theorem WLPOImplBoundedImplSTB:  WLPO -> (forall f:nat->bool,  (Bounded f) -> (StrictlyBounded f)).
Proof.
  intros  wlpo f bounded.
  apply (snd (StrictlyBoundedSTBPredEQ f)).
  apply WLPOImplBoundedImplSTBPred;auto.
Qed.

Theorem BoundedImplSTBImplWLPO:  (forall f:nat->bool,  (Bounded f) -> (StrictlyBoundedAlternative f)) -> WLPO.
Proof.
  intro arrow.
  unfold Bounded in arrow.
  unfold StrictlyBounded in arrow.

    (* The idea: Lets make a function which is true only on the exactly first
  place where g n = true, and false everywhere else. This has a limit of 1. But
  is has a limit on exactly 1 iff {~ (forall n : nat, g n = false)} and 0 iff
  {(forall n : nat, g n = false)}. *)

unfold  WLPO.
intro g.

assert {n : nat |
            (forall k : nat, NrOfTrue (trueOnFirst g) k <= n) /\
             ~ (forall k : nat, NrOfTrue (trueOnFirst g) k < n)};auto.

apply arrow;auto.
exists 1;auto.
intros;auto.
apply nrOftrueIntrueOnFirstIs1or0.

elim H.
assert (forall (g : nat -> bool) (k : nat), NrOfTrue (trueOnFirst g) k <= 1);auto.
apply nrOftrueIntrueOnFirstIs1or0.
intro lim.
intro H1.

elim H1.
intros.
assert (lim <= 1).
assert (forall k : nat, NrOfTrue (trueOnFirst g) k <=1).
apply nrOftrueIntrueOnFirstIs1or0.
elim (le_lt_dec lim 1).
intros.
auto.
intro.
contradict H3.
intro.
pose (H4 k).
omega.

elim (lt_eq_lt_dec lim 1 );auto;intros;auto.
elim a;intros;auto.
assert (lim=0).
omega.
assert ( forall k : nat, NrOfTrue (trueOnFirst g) k <= 0).
rewrite H5 in H2.
apply H2.
left.
intro n.
assert (NrOfTrue (trueOnFirst g) n <= 0);auto.
assert (NrOfTrue (trueOnFirst g) n = 0);auto.
omega.
assert ((forall x : nat, x <= n -> trueOnFirst g x = false) );auto.
apply nrOftrueIntrueIsLimitedByfalse;auto.
apply (trueOnFirstConstantFalseImplConstantFalseHelper g n);auto.
(* Done the case where the limit is 0! *)

right.
intro.
assert (forall k, NrOfTrue  g k=0).
intro.
apply (nrOftrueIntrueIsLimitedByfalse g).
intros.
apply H5.
assert (~ (forall k : nat, NrOfTrue (trueOnFirst g) k <= 0));auto.
intro.
apply H3.
rewrite b.
intro.
pose (H7 k).
omega.
apply H7.
intro.
assert ( forall x : nat,   trueOnFirst g x = false);auto.
intro.
assert (g x = false);auto.
assert (trueOnFirst g x = true \/ trueOnFirst g x =false);auto.
elim (trueOnFirst g x);auto.
elim H9;intros;auto.
assert (g x = true);auto.
rewrite H8 in H11.
contradict H11.
auto.
assert (NrOfTrue (trueOnFirst g) k = 0);auto.
apply nrOftrueIntrueIsLimitedByfalse.
intros;auto.
omega.
assert False.
omega.
contradict H5.
 Qed.