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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.
  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.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Definition synth (lf2 : natural) (lf1 : natural) : natural := plus lf2 Zero.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) : natural := Succ y.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import riscv.Utility.
Require Import riscv.util.Monads.
Require Import riscv.Memory.
Import ListNotations.
Local Open Scope Z_scope.

Section Memory.

  Definition mem := list (word 8).
  Definition mem_size(m: mem): Z := Zlength m.

  Definition read_byte(m: mem)(a: Z): word 8 := Znth m a (ZToWord _ 0).

  Definition write_byte'(m: mem)(a: Z)(v: word 8): mem :=
    (Zfirstn a m) ++ [v] ++ (Zskipn (a + 1) m).

  (* fix for the case when a is out of bounds to make sure length is always preserved:
     allows for _preserves_mem_size lemmas with no hypotheses, and ensures things which
     should not work because out of bounds writes-then-reads don't work *)
  Definition write_byte(m: mem)(a: Z)(v: word 8): mem :=
    firstn (length m) (write_byte' m a v).

  Definition read_half(m: mem)(a: Z): word 16 :=
    let v0 := read_byte m a in let v1 := read_byte m (a + 1) in wappend v1 v0.
  Definition read_word(m: mem)(a: Z): word 32 :=
    let v0 := read_half m a in let v1 := read_half m (a + 2) in wappend v1 v0.
  Definition read_double(m: mem)(a: Z): word 64 :=
    let v0 := read_word m a in let v1 := read_word m (a + 4) in wappend v1 v0.

  Definition write_half(m: mem)(a: Z)(v: word 16): mem :=
    let m := write_byte m a (lobits 8 v) in write_byte m (a + 1) (hibits 8 v).
  Definition write_word(m: mem)(a: Z)(v: word 32): mem :=
    let m := write_half m a (lobits 16 v) in write_half m (a + 2) (hibits 16 v).
  Definition write_double(m: mem)(a: Z)(v: word 64): mem :=
    let m := write_word m a (lobits 32 v) in write_word m (a + 4) (hibits 32 v).

  Definition const_mem(default: word 8)(size: Z): mem :=
    map_range (fun _: Z => default) size.

  Lemma const_mem_mem_size: forall default size,
      0 <= size ->
      mem_size (const_mem default size) = size.
  Proof.
    intros. unfold mem_size, const_mem. apply Zlength_map_range. assumption.
  Qed.

  Definition zero_mem: Z -> mem := const_mem (ZToWord 8 0).

End Memory.

Ltac omega' := zify; rewrite Z2Nat.id in *; omega.

Lemma write_read_byte_eq': forall m a1 a2 v,
    0 <= a1 < mem_size m ->
    a2 = a1 ->
    read_byte (write_byte' m a1 v) a2 = v.
Proof.
  intros. subst. unfold write_byte', read_byte, mem_size in *.
  unfold Zfirstn, Zskipn, Znth, Zlength in *.
  pose proof (@firstn_length_le _ m (Z.to_nat a1)).
  rewrite app_nth2 by omega'.
  rewrite H0 by omega'.
  replace (Z.to_nat a1 - Z.to_nat a1)%nat with 0%nat by omega.
  reflexivity.
Qed.

Lemma Z_bounds_to_nat_bound: forall (a: Z) (n: nat),
    0 <= a < Z.of_nat n ->
    (Z.to_nat a < n)%nat.
Proof.
  intros. omega'.
Qed.

Lemma Z_ne_to_nat_ne: forall (a b: Z),
    0 <= a ->
    0 <= b ->
    a <> b ->
    Z.to_nat a <> Z.to_nat b.
Proof.
  intros. intro. apply H1. apply Z2Nat.inj; assumption.
Qed.

Lemma write_read_byte_ne': forall m a1 a2 v,
    0 <= a1 < mem_size m ->
    0 <= a2 < mem_size m ->
    a2 <> a1 ->
    read_byte (write_byte' m a1 v) a2 = read_byte m a2.
Proof.
  intros. unfold write_byte', read_byte, mem_size in *.
  pose proof (@firstn_length_le _ m (Z.to_nat a1)).
  pose proof (@firstn_length_le _ m (Z.to_nat a2)).
  unfold Znth, Zfirstn, Zskipn, Zlength in *.
  rewrite Z2Nat.inj_add by omega.
  apply Z_ne_to_nat_ne in H1; [|omega..].
  apply Z_bounds_to_nat_bound in H.
  apply Z_bounds_to_nat_bound in H0.
  remember (Z.to_nat a1) as a1'. clear Heqa1' a1. rename a1' into a1.
  remember (Z.to_nat a2) as a2'. clear Heqa2' a2. rename a2' into a2.
  replace (a1 + Z.to_nat 1)%nat with (S a1) by omega'.
  assert (a2 < a1 \/ a1 < a2 < length m)%nat as P by omega.
  destruct P as [P | P].
  - rewrite app_nth1 by omega.
    clear H2 H3.
    generalize dependent m. generalize dependent a1.
    induction a2; intros.
    + destruct a1; [omega|simpl]. destruct m; reflexivity.
    + destruct a1; [omega|simpl]. destruct m.
      * simpl in H; omega.
      * simpl in *. apply IHa2; omega.
  - rewrite app_nth2 by omega.
    rewrite app_nth2 by (simpl; omega).
    rewrite H2 by omega.
    replace (a2 - a1 - length [v])%nat with (a2 - (S a1))%nat by (simpl; omega).
    clear H2 H3.
    generalize dependent m. generalize dependent a1.
    induction a2; intros.
    + omega.
    + replace (S a2 - S a1)%nat with (a2 - a1)%nat by omega.
      destruct a1.
      * replace (a2 - 0)%nat with a2 by omega. destruct m; [simpl in *; omega|reflexivity].
      * destruct m; [simpl in *; omega|].
        change (skipn (S (S a1)) (w :: m)) with (skipn (S a1) m).
        change (nth (S a2) (w :: m)) with (nth a2 m).
        apply IHa2; simpl in *; try omega.
Qed.

Lemma skipn_length_le: forall A n (l: list A),
    (n <= length l)%nat ->
    length (skipn n l) = (length l - n)%nat.
Proof.
  induction n; intros.
  - simpl. omega.
  - simpl. destruct l; [simpl in *; omega|].
    simpl in *.
    apply IHn; omega.
Qed.

Lemma write_byte_preserves_mem_size': forall m a v,
    0 <= a < mem_size m ->
    mem_size (write_byte' m a v) = mem_size m.
Proof.
  intros. unfold mem_size, write_byte' in *.
  unfold Zlength, Zfirstn, Zskipn in *.
  repeat rewrite app_length.
  rewrite firstn_length_le by omega'.
  rewrite skipn_length_le by omega'.
  simpl.
  omega'.
Qed.

Lemma firstn_all_write_byte': forall m a1 v,
    0 <= a1 < mem_size m ->
    firstn (length m) (write_byte' m a1 v) = write_byte' m a1 v.
Proof.
  intros.
  replace (length m) with (length (write_byte' m a1 v)).
  - rewrite firstn_all. reflexivity.
  - pose proof (write_byte_preserves_mem_size' m a1 v H) as P.
    unfold mem_size, Zlength in *.
    apply Nat2Z.inj in P.
    assumption.
Qed.

Lemma write_read_byte_eq: forall m a1 a2 v,
    0 <= a1 < mem_size m ->
    a2 = a1 ->
    read_byte (write_byte m a1 v) a2 = v.
Proof.
  intros. unfold write_byte in *.
  erewrite <- write_read_byte_eq' by eassumption.
  rewrite firstn_all_write_byte' by assumption.
  reflexivity.
Qed.

Lemma write_read_byte_ne: forall m a1 a2 v,
    0 <= a1 < mem_size m ->
    0 <= a2 < mem_size m ->
    a2 <> a1 ->
    read_byte (write_byte m a1 v) a2 = read_byte m a2.
Proof.
  intros. unfold write_byte in *.
  rewrite <- (write_read_byte_ne' m a1 a2 v);
    rewrite? firstn_all_write_byte' by assumption;
    rewrite? write_byte_preserves_mem_size' by assumption;
    [reflexivity | eassumption ..].
Qed.

Lemma Z2Nat_nonpos: forall (a: Z),
    a <= 0 ->
    Z.to_nat a = 0%nat.
Proof.
  intros.
  destruct a.
  - reflexivity.
  - lia.
  - apply Z2Nat.inj_neg.
Qed.

Lemma write_byte_preserves_mem_size: forall m a v,
    mem_size (write_byte m a v) = mem_size m.
Proof.
  intros. unfold write_byte.
  assert (a < 0 \/ 0 <= a < mem_size m \/ a >= mem_size m) as C by omega.
  destruct C as [H | [H | H]].
  - unfold write_byte', Zfirstn, Zskipn.
    rewrite! Z2Nat_nonpos by omega.
    simpl.
    unfold mem_size, Zlength in *.
    apply Znat.inj_eq.
    apply firstn_length_le.
    simpl.
    repeat constructor.
  - pose proof write_byte_preserves_mem_size' as P.
    specialize P with (1 := H).
    unfold mem_size, Zlength in *.
    rewrite <- (P v) at 1.
    rewrite firstn_all_write_byte' by assumption.
    reflexivity.
  - unfold mem_size, Zlength in *.
    apply Znat.inj_eq.
    apply firstn_length_le.
    unfold write_byte', Zfirstn, Zskipn.
    rewrite? app_length.
    rewrite firstn_length.
    omega'.
Qed.

Lemma write_read_half_eq: forall m a1 a2 v,
    0 <= a1 ->
    a1 + 1 < mem_size m ->
    a2 = a1 ->
    read_half (write_half m a1 v) a2 = v.
Proof.
  intros. subst. unfold write_half, read_half in *.
  pose proof H.
  rewrite (write_read_byte_eq _ (a1 + 1) (a1 + 1)); try reflexivity.
  - rewrite write_read_byte_ne; try omega.
    + rewrite write_read_byte_eq; try reflexivity; try omega.
      apply (wappend_split 8 8); omega.
    + rewrite write_byte_preserves_mem_size; omega.
    + rewrite write_byte_preserves_mem_size; omega.
  - rewrite write_byte_preserves_mem_size; omega.
Qed.

Lemma write_read_half_ne: forall m a1 a2 v,
    a1 + 1 < mem_size m ->
    a1 mod 2 = 0 ->
    a2 + 1 < mem_size m ->
    a2 mod 2 = 0 ->
    a2 <> a1 ->
    0 <= a1 ->
    0 <= a2 ->
    read_half (write_half m a1 v) a2 = read_half m a2.
Proof.
  intros. unfold write_half, read_half in *.
  f_equal.
  - rewrite write_read_byte_ne.
    + apply write_read_byte_ne; try omega.
      intro. subst. rewrite Z.add_mod in H0; try omega.
      rewrite H2 in H0.
      simpl in H0.
      discriminate.
    + rewrite write_byte_preserves_mem_size; omega.
    + rewrite write_byte_preserves_mem_size; omega.
    + omega.
  - rewrite write_read_byte_ne.
    + apply write_read_byte_ne; omega.
    + rewrite write_byte_preserves_mem_size; omega.
    + rewrite write_byte_preserves_mem_size; omega.
    + intro. subst. rewrite Z.add_mod in H2; try omega.
      rewrite H0 in H2.
      simpl in H2.
      discriminate.
Qed.

Lemma add_mod_r: forall a m,
    m <> 0 ->
    (a + m) mod m = a mod m.
Proof.
  intros.
  rewrite Z.add_mod by assumption.
  rewrite Z.mod_same by assumption.
  rewrite Z.add_0_r.
  apply Z.mod_mod.
  assumption.
Qed.

Lemma weaken_alignment: forall n al,
    n mod (al * 2) = 0 ->
    al <> 0 ->
    n mod al = 0.
Proof.
  intros.
  pose proof H.
  apply Z.mod_divide in H; try omega.
  destruct H as [n' H]. subst.
  replace (n' * (al * 2)) with (n' * 2 * al) by ring.
  apply Z.mod_mul.
  assumption.
Qed.

Lemma write_half_preserves_mem_size: forall m a v,
    mem_size (write_half m a v) = mem_size m.
Proof.
  intros. unfold write_half, mem_size in *.
  repeat rewrite write_byte_preserves_mem_size; unfold mem_size; omega.
Qed.

Lemma diviBy4_implies_diviBy2: forall n,
    n mod 4 = 0 ->
    n mod 2 = 0.
Proof.
  intros.
  apply weaken_alignment; [assumption | omega].
Qed.

Lemma write_read_word_eq: forall m a1 a2 v,
    a1 + 4 <= mem_size m ->
    a1 mod 4 = 0 ->
    a2 = a1 ->
    0 <= a1 ->
    read_word (write_word m a1 v) a2 = v.
Proof.
  intros. subst. unfold write_word, read_word in *.
  pose proof H.
  rewrite (write_read_half_eq _ (a1 + 2) (a1 + 2)); try reflexivity; try omega.
  - rewrite write_read_half_ne; try omega.
    + rewrite write_read_half_eq; try reflexivity; try omega.
      apply (wappend_split 16 16); omega.
    + rewrite write_half_preserves_mem_size; omega.
    + apply diviBy4_implies_diviBy2 in H0. rewrite Z.add_mod by omega.
      rewrite H0.
      reflexivity.
    + rewrite write_half_preserves_mem_size; omega.
    + apply diviBy4_implies_diviBy2. assumption.
  - rewrite write_half_preserves_mem_size; omega.
Qed.

Lemma write_read_word_ne: forall m a1 a2 v,
    a1 + 4 <= mem_size m ->
    a1 mod 4 = 0 ->
    a2 + 4 <= mem_size m ->
    a2 mod 4 = 0 ->
    a2 <> a1 ->
    0 <= a1 ->
    0 <= a2 ->
    read_word (write_word m a1 v) a2 = read_word m a2.
Proof.
  intros. unfold write_word, read_word in *.
  rename H4 into H6, H5 into H7.
  pose proof (diviBy4_implies_diviBy2 _ H0).
  pose proof (diviBy4_implies_diviBy2 _ H2).
  f_equal.
  - rewrite write_read_half_ne.
    + apply write_read_half_ne; try omega.
      * rewrite add_mod_r; omega.
      * intro. subst. rewrite Z.add_mod in H0; try omega.
        rewrite H2 in H0.
        simpl in H0.
        discriminate.
    + rewrite write_half_preserves_mem_size; omega.
    + rewrite add_mod_r; omega.
    + rewrite write_half_preserves_mem_size; omega.
    + rewrite add_mod_r; omega.
    + omega.
    + omega.
    + omega.
  - rewrite write_read_half_ne.
    + apply write_read_half_ne; omega.
    + rewrite write_half_preserves_mem_size; omega.
    + rewrite Z.add_mod by omega.
      rewrite H4.
      reflexivity.
    + rewrite write_half_preserves_mem_size; omega.
    + assumption.
    + intro. subst. rewrite Z.add_mod in H2; try omega.
      rewrite H0 in H2.
      simpl in H2.
      discriminate.
    + omega.
    + assumption.
Qed.

Lemma write_word_preserves_mem_size: forall m a v,
    mem_size (write_word m a v) = mem_size m.
Proof.
  intros. unfold write_word, mem_size in *.
  repeat rewrite write_half_preserves_mem_size; unfold mem_size; omega.
Qed.

Lemma diviBy8_implies_diviBy4: forall n,
    n mod 8 = 0 ->
    n mod 4 = 0.
Proof.
  intros.
  apply weaken_alignment; [assumption | omega].
Qed.

Lemma write_read_double_eq: forall m a1 a2 v,
    a1 + 8 <= mem_size m ->
    a1 mod 8 = 0 ->
    a2 = a1 ->
    0 <= a1 ->
    read_double (write_double m a1 v) a2 = v.
Proof.
  intros. subst. unfold write_double, read_double in *.
  pose proof H.
  rewrite (write_read_word_eq _ (a1 + 4) (a1 + 4)); try reflexivity; try omega.
  - rewrite write_read_word_ne; try omega.
    + rewrite write_read_word_eq; try reflexivity; try omega.
      * apply (wappend_split 32 32); omega.
      * apply diviBy8_implies_diviBy4. assumption.
    + rewrite write_word_preserves_mem_size; omega.
    + apply diviBy8_implies_diviBy4 in H0. rewrite Z.add_mod by omega.
      rewrite H0.
      reflexivity.
    + rewrite write_word_preserves_mem_size; omega.
    + apply diviBy8_implies_diviBy4. assumption.
  - rewrite write_word_preserves_mem_size; omega.
  - rewrite add_mod_r by omega.
    apply diviBy8_implies_diviBy4. assumption.
Qed.

Lemma write_read_double_ne: forall m a1 a2 v,
    a1 + 8 <= mem_size m ->
    a1 mod 8 = 0 ->
    a2 + 8 <= mem_size m ->
    a2 mod 8 = 0 ->
    a2 <> a1 ->
    0 <= a1 ->
    0 <= a2 ->
    read_double (write_double m a1 v) a2 = read_double m a2.
Proof.
  intros. unfold write_double, read_double in *.
  rename H4 into H6, H5 into H7.
  pose proof (diviBy8_implies_diviBy4 _ H0).
  pose proof (diviBy8_implies_diviBy4 _ H2).
  f_equal.
  - rewrite write_read_word_ne.
    + apply write_read_word_ne; try omega.
      * rewrite add_mod_r; omega.
      * intro. subst. rewrite Z.add_mod in H0; try omega.
        rewrite H2 in H0.
        simpl in H0.
        discriminate.
    + rewrite write_word_preserves_mem_size; omega.
    + rewrite add_mod_r; omega.
    + rewrite write_word_preserves_mem_size; omega.
    + rewrite add_mod_r; omega.
    + omega.
    + omega.
    + omega.
  - rewrite write_read_word_ne.
    + apply write_read_word_ne; omega.
    + rewrite write_word_preserves_mem_size; omega.
    + rewrite Z.add_mod by omega.
      rewrite H4.
      reflexivity.
    + rewrite write_word_preserves_mem_size; omega.
    + assumption.
    + intro. subst. rewrite Z.add_mod in H2; try omega.
      rewrite H0 in H2.
      simpl in H2.
      discriminate.
    + omega.
    + omega.
Qed.

Lemma write_double_preserves_mem_size: forall m a v,
    mem_size (write_double m a v) = mem_size m.
Proof.
  intros. unfold write_double, mem_size in *.
  repeat rewrite write_word_preserves_mem_size; unfold mem_size; omega.
Qed.


Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Basics.
Require Import Logic.JMeq.
Require Import Coq.Logic.FunctionalExtensionality.

(** Module defining fingertrees ala Hinze and Paterson and verifying them*)

Module FingerTrees.

  Import List.ListNotations.

  Open Scope list_scope.

  (** ============================================================================== *)
  (**                                 type classes                                   *)
  (** ============================================================================== *)

  (** A Functor typeclass *)
  Class functor F := Functor {
    map : forall {A B : Type}, (A -> B) -> F A -> F B;

    map_id : forall {A : Type} (f : F A), map (fun x => x) f = f;
    map_comp : forall {A B C : Type} (f : B -> C) (g : A -> B) (x : F A),
        map (fun x => f (g x)) x = (fun x => map f (map g x)) x;
  }.

  (** Something that can be reduced *)
  Class reduce F := Reduce {
    reducer : forall {A} {B}, (A -> B -> B) -> (F A -> B -> B);
    reducel : forall {A} {B}, (B -> A -> B) -> (B -> F A -> B);
  }.

  (** ============================================================================== *)
  (**                                 list instances                                 *)
  (** ============================================================================== *)

  (** All reducibles can be folded into a list *)
  Definition to_list {F: Type -> Type} {r: reduce F} {A : Type} (s : F A) : list A :=
    reducer cons s nil.

  (** List can be reduced using fold_right/left *)
  Instance list_reduce : reduce list :=
    {|
      reducer := fun _ _ fn xs z => List.fold_right fn z xs;
      reducel := fun _ _ fn z xs => List.fold_left fn xs z;
    |}.

  (** Lists are functors *)
  Instance list_functor : functor list :=
    {|
      map := @List.map;
    |}.
  Proof.
    - intros. induction f; [reflexivity|]. simpl. rewrite IHf. reflexivity.
    - induction x; [reflexivity|]. simpl. rewrite IHx. reflexivity.
  Qed.

  (** ============================================================================== *)
  (**                                    node                                        *)
  (** ============================================================================== *)

  (** A node contains two or three values *)
  Inductive node (A:Type) : Type :=
  | node2: A -> A -> node A
  | node3: A -> A -> A -> node A.

  Arguments node2 {A} _ _.
  Arguments node3 {A} _ _ _.

  (** Right-reduce a node *)
  Definition nd_reducer {A B : Type} : (A -> B -> B) -> node A -> B -> B :=
    fun op nd z => match nd with
                | node2 a b => op a (op b z)
                | node3 a b c => op a (op b (op c z))
                end.

  (** Left-reduce a node *)
  Definition nd_reducel {A B : Type} : (B -> A -> B) -> B -> node A -> B :=
    fun op z nd => match nd with
                | node2 b a => op (op z b) a
                | node3 c b a => op (op (op z c) b) a
                end.

  (** Nodes can be reduced *)
  Instance node_reduce : reduce node :=
    {|
      reducer := @nd_reducer;
      reducel := @nd_reducel;
    |}.

  (** Right-reducing a node over an accumulator that is the concatenation
      of two lists xs and ys is the same as using just xs as the accumulator
      and then appending ys. I.e. reducer does not touch the accumulator.
      Only works if the operator associates over append.
  *)
  Lemma nd_reducer_app :
    forall {A B} (op : A -> list B -> list B) (a : node A) (xs ys : list B),
      (forall a (xs ys : list B), op a (xs ++ ys) = (op a xs) ++ ys) ->
      nd_reducer op a (xs ++ ys) = nd_reducer op a xs ++ ys.
  Proof.
    intros. destruct a; simpl; rewrite ?H; reflexivity.
  Qed.

  Definition nd_map {A B : Type} (fn : A -> B) (x : node A) :=
    match x with
    | node2 a b => node2 (fn a) (fn b)
    | node3 a b c => node3 (fn a) (fn b) (fn c)
    end.

  (** Nodes are functors *)
  Instance node_functor : functor node :=
    {|
      map := @nd_map
    |}.
  Proof.
    - intros. destruct f; reflexivity.
    - intros. destruct x; reflexivity.
  Defined.

  (** ============================================================================== *)
  (**                                    digit                                       *)
  (** ============================================================================== *)

  (** Digits hold one to four elements *)
  Inductive digit (A:Type) : Type :=
  | one : A -> digit A
  | two : A -> A -> digit A
  | three : A -> A -> A -> digit A
  | four : A -> A -> A -> A -> digit A.

  Arguments one {A} _.
  Arguments two {A} _ _.
  Arguments three {A} _ _ _.
  Arguments four {A} _ _ _ _.

  (** Digits can be reduced right *)
  Definition digit_reducer {A B : Type} (op: A -> B -> B) dg z :=
    match dg with
    | one a => op a z
    | two a b => op a (op b z)
    | three a b c => op a (op b (op c z))
    | four a b c d => op a (op b (op c (op d z)))
    end.

  (** Digits can be reduced left *)
  Definition digit_reducel {A B : Type} (op: B -> A -> B) z dg :=
    match dg with
    | one a => op z a
    | two b a => op (op z b) a
    | three c b a => op (op (op z c) b) a
    | four d c b a => op (op (op (op z d) c) b) a
    end.

  (** Digits can be reduced *)
  Instance digit_reduce : reduce digit :=
    {|
      reducer := @digit_reducer;
      reducel := @digit_reducel;
    |}.

  Definition digit_map {A B : Type} (fn : A -> B) (x : digit A) :=
    match x with
    | one a => one (fn a)
    | two a b => two (fn a) (fn b)
    | three a b c => three (fn a) (fn b) (fn c)
    | four a b c d => four (fn a) (fn b) (fn c) (fn d)
    end.

  (** Digits are functors *)
  Instance digit_functor : functor digit :=
    {|
      map := @digit_map;
    |}.
  Proof.
    - intros. destruct f; reflexivity.
    - intros. destruct x; reflexivity.
  Defined.

  (** Convert a node to a digit *)
  Fixpoint to_digit {A:Type} (nd:node A) : digit A :=
    match nd with
    | node2 a b => two a b
    | node3 a b c => three a b c
    end.

  (** ============================================================================== *)
  (**                                    fingertree                                  *)
  (** ============================================================================== *)

  (** A fingertree is either empty, a single thing, or a deeper fingertree
      along with a prefix digit and a suffix digit *)
  Inductive fingertree (A:Type) : Type :=
  | empty : fingertree A
  | single : A -> fingertree A
  | deep : digit A -> fingertree (node A) -> digit A -> fingertree A.

  Arguments empty {A}.
  Arguments single {A} _.
  Arguments deep {A} _ _ _.

  Example ft_ex_01 : fingertree nat :=
    deep (two 1 2)
         (deep (two (node2 3 4) (node2 5 6))
               empty
               (two (node3 7 8 9) (node2 10 11))
         )
         (three 12 13 14).

  (** Fingertrees can be reduced right *)
  Fixpoint ft_reducer {A:Type} {B:Type}
             (op: A -> B -> B) (tr : fingertree A) (z : B) : B :=
      match tr with
      | empty => z
      | single x => op x z
      | deep pr m sf =>
        let op' := reducer op in
        let op'' := ft_reducer (reducer op) in
        op' pr (op'' m (op' sf z))
      end.

  (** Fingertrees can be reduced left *)
  Fixpoint ft_reducel {A:Type} {B:Type}
           (op: B -> A -> B) (z : B) (tr : fingertree A) : B :=
      match tr with
      | empty => z
      | single x => op z x
      | deep pr m sf =>
        let op'  := reducel op in
        let op'' := ft_reducel (reducel op) in
        op' (op'' (op' z pr) m) sf
      end.

  (** Fingertrees can be reduced *)
  Instance fingertree_reduce : reduce fingertree :=
    {|
      reducer := @ft_reducer;
      reducel := @ft_reducel;
    |}.

  Example ft_ex_01_to_list : to_list ft_ex_01 = [1;2;3;4;5;6;7;8;9;10;11;12;13;14].
  Proof. reflexivity. Qed.

  (** You can map over a fingertree *)
  Fixpoint ft_map {A B : Type} (fn : A -> B) (tr : fingertree A) : fingertree B :=
    match tr with
    | empty => empty
    | single a => single (fn a)
    | deep pf m sf =>
      deep (map fn pf)
            (ft_map (map fn) m)
            (map fn sf)
    end.

  (** ID law for functors for fingertrees *)
  Lemma ft_map_id : forall (A : Type) (tr : fingertree A),
   ft_map (fun x => x) tr = tr.
  Proof.
    Opaque map.
    induction tr; intros; simpl in *; [reflexivity | reflexivity |].
    rewrite !map_id.
    replace (map (fun x : A => x)) with (fun x : node A => x).
    rewrite IHtr. reflexivity.
    apply functional_extensionality. intros. symmetry. apply map_id.
    Transparent map.
  Qed.

  (** Composition law for functors for fingertrees *)
  Lemma ft_map_comp {A B C: Type} (f: B -> C) (g: A -> B) (tr: fingertree A) :
    ft_map (fun x => f (g x)) tr = ft_map f (ft_map g tr).
  Proof.
    Opaque map.
    intros. generalize dependent B. generalize dependent C.
    induction tr; intros; simpl in *; [reflexivity | reflexivity |].
    rewrite map_comp with (x := d).
    rewrite map_comp with (x := d0).
    replace (map (fun x : A => f (g x))) with (fun n : node A => map f (map g n)).
    rewrite (IHtr _ _ (map f) (map g)). reflexivity.
    apply functional_extensionality.
    intros. symmetry. apply map_comp.
    Transparent map.
  Qed.

  (** Fingertrees are functors *)
  Instance ft_functor : functor fingertree :=
    {|
      map := @ft_map;
      map_id := ft_map_id;
      map_comp := @ft_map_comp;
    |}.

  (** Tree equivalence relation!
      Two trees are equal if they reduce to the same thing no matter what
      operator.
   *)
  Definition tree_eq {A : Type} (t1 t2 : fingertree A) :=
    forall (B : Type) (acc : B) (op : A -> B -> B), reducer op t1 acc = reducer op t2 acc.

  Notation "t1 >=< t2" := (tree_eq t1 t2)
                            (at level 90, right associativity).

  (** ============================================================================== *)
  (**                                    adding                                      *)
  (** ============================================================================== *)

  (** Add to the left of a fingertree *)
  Fixpoint addl {A:Type} (a:A) (tr:fingertree A) : fingertree A  :=
    match tr with
    | empty => single a
    | single b => deep (one a) empty (one b)
    | deep (four b c d e) m sf => deep (two a b) (addl (node3 c d e) m) sf
    | deep (three b c d) m sf => deep (four a b c d) m sf
    | deep (two b c) m sf => deep (three a b c) m sf
    | deep (one b) m sf => deep (two a b) m sf
    end.

  (** Add to the right of a fingertree *)
  Fixpoint addr {A:Type} (tr:fingertree A) (a:A) : fingertree A  :=
    match tr with
    | empty => single a
    | single b => deep (one b) empty (one a)
    | deep pr m (four e d c b) => deep pr (addr m (node3 e d c)) (two b a)
    | deep pr m (three e c b) => deep pr m (four e c b a)
    | deep pr m (two c b) => deep pr m (three c b a)
    | deep pr m (one b) => deep pr m (two b a)
    end.

  (** Notation for adding to the left and right of fingertrees *)
  Notation "x <| t" := (addl x t)
                     (at level 60, right associativity).
  Notation "x |> t" := (addr x t)
                     (at level 61, left associativity).

  (** Mapping f over (x <| tr) is same as applying x to f and then adding it
      to map f tr.
   *)
  Lemma map_addl {A : Type} (tr : fingertree A) :
    forall B (f: A -> B) x, map f (x <| tr) = f x <| map f tr.
  Proof.
    unfold "<|". induction tr; intros; simpl in *; try reflexivity.
    - unfold map. destruct digit_functor.
      destruct d, d0; simpl; try (rewrite IHtr); try reflexivity.
  Qed.

  (** As above but with adding to the right *)
  Lemma map_addr {A : Type} (tr : fingertree A) :
    forall B (f: A -> B) x, ft_map f (tr |> x) = ft_map f tr |> f x .
  Proof.
    induction tr; intros; try reflexivity.
    destruct d, d0; simpl; try (rewrite IHtr); try reflexivity.
  Qed.

  (** Add all the things in a reducible value to the left of the tree *)
  Definition addl' {F: Type -> Type} {r:reduce F} {A:Type} :
    F A -> fingertree A -> fingertree A :=
      reducer addl.

  (** Add all the things in a reducible value to the right of the tree *)
  Definition addr' {F: Type -> Type} {r:reduce F} {A:Type} :
    fingertree A -> F A -> fingertree A :=
      reducel addr.

  (** Convert any reducible to a fingertree! *)
  Definition to_tree {F:Type -> Type} {A:Type} {r:reduce F} (s:F A) :
    fingertree A := addl' s empty.

  (** ============================================================================== *)
  (**                                  viewing                                       *)
  (** ============================================================================== *)

  (** View a tree from the left as empty or (an x and the rest of the tree) *)
  Inductive View_l (S:Type -> Type) (A:Type): Type :=
  | nil_l : View_l S A
  | cons_l : A -> S A -> View_l S A.

  Arguments nil_l {S} {A}.
  Arguments cons_l {S} {A} _ _.

  (** View a tree from the left! *)
  Fixpoint view_l {A:Type} (tr:fingertree A) : View_l fingertree A :=
    match tr with
    | empty => nil_l
    | single x => cons_l x empty
    | deep (one x) m sf =>
      let tail := match view_l m with
                  | nil_l => to_tree sf
                  | cons_l a m' => deep (to_digit a) m' sf
                  end
      in cons_l x tail
    | deep (two x y) m sf => cons_l x (deep (one y) m sf)
    | deep (three x y z) m sf => cons_l x (deep (two y z) m sf)
    | deep (four x y z u) m sf => cons_l x (deep (three y z u) m sf)
    end.

  (** Check if a tree is empty (with a boolean) *)
  Definition is_emptyb {A:Type} (tr:fingertree A) : bool :=
    match view_l tr with
    | nil_l => true
    | cons_l _ _ => false
    end.

  (** Check if a tree is empty (returning a proposition) *)
  Definition is_empty {A:Type} (tr:fingertree A) : Prop :=
    match view_l tr with
    | nil_l => True
    | cons_l _ _ => False
    end.

  (** Iff a view of a tree is empty, then it is empty *)
  Lemma view_l_nil_empty : forall {A : Type} (tr : fingertree A),
      view_l tr = nil_l <-> tr = empty.
  Proof.
    intros. split.
    - intros. destruct tr; [reflexivity | inversion H |]. simpl in H.
      destruct d, (view_l tr), d0; inversion H.
    - intros. destruct tr; [reflexivity | inversion H |].
      destruct d, (view_l tr), d0; inversion H.
  Qed.

  (** Converting an empty list to a tree gives an empty tree *)
  Lemma to_tree_empty : forall {A : Type}, @is_empty A (to_tree []).
  Proof.
    intros. simpl. unfold is_empty. destruct (view_l empty) eqn:Heq.
    - apply I.
    - inversion Heq.
  Qed.

  (** Adding something to the left of a tree can never result in an empty tree *)
  Lemma addl_not_empty : forall {A : Type} (tr : fingertree A) x, ~(addl x tr = empty).
  Proof.
    intros A tr x H. induction tr; inversion H.
    destruct d; inversion H1.
  Qed.

  (** Adding something to the left of a single can never result in a new single *)
  Lemma addl_not_2single : forall {A : Type} (x y z : A), ~(addl x (single y) = single z).
  Proof.
    intros A x y z H. simpl in H. inversion H.
  Qed.

  (** Adding something to the right of a tree can never result in an empty tree *)
  Lemma addr_not_empty : forall {A : Type} (tr : fingertree A) x, ~(addr tr x = empty).
    intros A tr x H. induction tr; inversion H.
    destruct d0; inversion H1.
  Qed.

  (** Viewing the result of adding somehing to a tree can never be nil *)
  Lemma addl_not_nil : forall {A : Type} (tr : fingertree A) x,
      ~(view_l (addl x tr) = nil_l).
  Proof.
    intros A tr x H. induction tr; inversion H.
    destruct d; inversion H1.
  Qed.

  (** Get the left head of a tree *)
  Definition head_l {A:Type} (a:A) (tr:fingertree A) : A :=
    match view_l tr with
    | nil_l => a
    | cons_l x _ => x
    end.

  (** Get the left tail of a tree *)
  Definition tail_l {A:Type} (tr:fingertree A) : fingertree A :=
    match view_l tr with
    | nil_l => tr
    | cons_l _ tl => tl
    end.

  (** If you add an x to the left of a tree tr and then convert it to a list, it is
     the same as converting tr to a list and then consing x.
     This is the general version of the above, i.e
     to_list (x <| tr) = x :: (to_list tr) <=>
     ft_reducer cons (x <| tr) [] = cons x (tr_reducer cons tr [])
  *)
  Lemma ft_reducer_addl : forall {A B : Type}
                         (tr : fingertree A) xs x
                         (op : A -> B -> B),
      ft_reducer op (x <| tr) xs = op x (ft_reducer op tr xs).
  Proof.
    intros A B tr.
    induction tr; intros; try reflexivity.
    destruct d; try reflexivity.  simpl.
    do 2 (apply f_equal).
    apply (IHtr (digit_reducer op d0 xs) (node3 a0 a1 a2) (nd_reducer op)).
  Qed.

  (** Converting a list to a tree and then back again gives you the same list.
      I.e. to_list and to_tree are inverses of each other (on lists).
      So there is an isomorphism between (fingertree A) and (list A).
   *)
  Theorem to_tree_to_list_id : forall {A:Type} (xs : list A),
      to_list (to_tree xs) = xs.
  Proof.
    intros. induction xs; [reflexivity |].
    simpl. rewrite (ft_reducer_addl _ [] a _).
    apply f_equal. simpl in IHxs. assumption.
  Qed.

  (** ============================================================================== *)
  (**                                    append                                      *)
  (** ============================================================================== *)

  (**
     We need this data structure to represent lists that can be converted into
     lists of nodes in a total way.
  **)
  Inductive app3_list (A : Type) : Type :=
  | app3_two   : A -> A -> app3_list A
  | app3_three : A -> A -> A -> app3_list A
  | app3_four  : A -> A -> A -> A -> app3_list A
  | app3_more  : A -> A -> A -> app3_list A -> app3_list A.

  Arguments app3_two {A} _ _.
  Arguments app3_three {A} _ _ _.
  Arguments app3_four {A} _ _ _ _.
  Arguments app3_more {A} _ _ _ _.

  (** app3_lists can be right-reduced *)
  Fixpoint a3_reducer {A B : Type} (op : A -> B -> B) (xs : app3_list A) (ys : B) : B :=
    match xs with
    | app3_two a b => op a (op b ys)
    | app3_three a b c => op a (op b (op c ys))
    | app3_four a b c d => op a (op b (op c (op d ys)))
    | app3_more a b c xs' => op a (op b (op c (a3_reducer op xs' ys)))
    end.

  (** app3_lists can be left-reduced *)
  Fixpoint a3_reducel {A B : Type} (op : B -> A -> B) (ys : B) (xs : app3_list A) : B :=
    match xs with
    | app3_two a b => op (op ys a) b
    | app3_three a b c => op (op (op ys a) b) c
    | app3_four a b c d => op (op (op (op ys a) b) c) d
    | app3_more a b c xs' => a3_reducel op (op (op (op ys a) b) c) xs'
    end.

  (** app3_lists are reducible *)
  Instance a3_reduce : reduce app3_list :=
    {|
      reducer := @a3_reducer;
      reducel := @a3_reducel;
    |}.

  (**
     Yeah, this is a doosie, but I don't know how to define it in more succint terms
     while still retaining its total properties.
     In the original paper, this is much simpler since we do not have to use an
     app3_list and can write partial functions, but we cannot do proper proofs
     if we do this (believe me, I've wasted many hours on trying).
   **)
  Fixpoint dig_app3 {A:Type} (d1 : digit A) (xs : list A) (d2 : digit A): app3_list A :=
    match d1, xs, d2 with
    | one a,        [], one b        => app3_two a b
    | one a,        [], two b c      => app3_three a b c
    | one a,        [], three b c d  => app3_four a b c d
    | one a,        [], four b c d e => app3_more a b c (app3_two d e)

    | two a b,      [], one c        => app3_three a b c
    | two a b,      [], two c d      => app3_four a b c d
    | two a b,      [], three c d e  => app3_more a b c (app3_two d e)
    | two a b,      [], four c d e f => app3_more a b c (app3_three d e f)

    | three a b c,  [], one d        => app3_four a b c d
    | three a b c,  [], two d e      => app3_more a b c (app3_two d e)
    | three a b c,  [], three d e f  => app3_more a b c (app3_three d e f)
    | three a b c,  [], four d e f g => app3_more a b c (app3_four d e f g)

    | four a b c d, [], one e        => app3_more a b c (app3_two d e)
    | four a b c d, [], two e f      => app3_more a b c (app3_three d e f)
    | four a b c d, [], three e f g  => app3_more a b c (app3_four d e f g)
    | four a b c d, [], four e f g h => app3_more a b c (app3_more d e f (app3_two g h))

    | one a,        (x :: xs), _     => dig_app3 (two a x) xs d2
    | two a b,      (x :: xs), _     => dig_app3 (three a b x) xs d2
    | three a b c,  (x :: xs), _     => dig_app3 (four a b c x) xs d2
    | four a b c d, (x :: xs), _     => app3_more a b c (dig_app3 (two d x) xs d2)
    end.

  (**
     group a list of A's into a list of nodes of A'
     uses the app3_list data type to ensure totality and make proofs
     about nodes possible
   **)
  Fixpoint nodes {A : Type} (xs : app3_list A) : list (node A) :=
    match xs with
    | app3_two a b        => [node2 a b]
    | app3_three a b c    => [node3 a b c]
    | app3_four a b c d   => [node2 a b; node2 c d]
    | app3_more a b c xs' => node3 a b c :: nodes xs'
    end.

  (**
     append two fingertrees with a list of "remainder-values".
     This does all the hard work of append. Should be amortized logarithmic time
   **)
  Fixpoint app3 {A:Type} (tr1:fingertree A) (rem : list A) (tr2:fingertree A)
    : fingertree A :=
    match tr1, tr2 with
    | empty, _ => addl' rem tr2
    | _, empty => addr' tr1 rem
    | single x, _ => x <| addl' rem tr2
    | _, single x => addr' tr1 rem |> x
    | deep pr1 m1 sf1, deep pr2 m2 sf2 =>
        let a3l := dig_app3 sf1 rem pr2 in
        deep pr1 (app3 m1 (nodes a3l) m2) sf2
    end.

  (** Two append two trees, we just call app3 with an empty remainder-list *)
  Definition append {A:Type}
           (tr1 : fingertree A) (tr2 : fingertree A) : fingertree A :=
    app3 tr1 [] tr2.

  Notation "t1 >< t2" := (append t1 t2)
                     (at level 62, left associativity).

  (** ============================================================================== *)
  (**                                 proving append                                 *)
  (** ============================================================================== *)

  (** Right-reducing a digit over an accumulator that is the concatenation
      of two lists xs and ys is the same as using just xs as the accumulator
      and then appending ys. I.e. reducer does not touch the accumulator.
      Only works if the operator associates over append.
  *)
  Theorem digit_reducer_app :
    forall {A B : Type} (xs ys : list B) d (op : A -> list B -> list B),
      (forall a xs ys, op a (xs ++ ys) = (op a xs) ++ ys) ->
      (digit_reducer op d (xs ++ ys) = digit_reducer op d xs ++ ys).
  Proof.
    intros.
    destruct d; simpl; rewrite ?H; reflexivity.
  Qed.

  (** Same as above, but with adding to the right of the list/tree *)
  Lemma ft_reducer_addr : forall {A B : Type}
                         (tr : fingertree A) xs x
                         (op : A -> B -> B),
      ft_reducer op (tr |> x) xs = (ft_reducer op tr (op x xs)).
  Proof.
    intros A B tr.
    induction tr; intros; simpl; [reflexivity | reflexivity |].
    destruct d0; simpl; try reflexivity.
    rewrite (IHtr (op a2 (op x xs)) (node3 a a0 a1) (nd_reducer op)).
    reflexivity.
  Qed.

  Lemma addl_addr_assoc {A : Type} (tr : fingertree A) :
    forall x y, x <| (tr |> y) >=< (x <| tr) |> y.
  Proof.
    unfold ">=<". induction tr; simpl in *; intros; [reflexivity | reflexivity |].
    destruct d0,d; simpl in *; try reflexivity.
    - apply f_equal. apply f_equal.
      rewrite IHtr. reflexivity.
  Qed.

  (**
     Reducing a fingertree with an accumulator that is the concatenation of two
     lists xs and ys, is the same as just reducing with xs and then appending ys
     given that the operation we use for reduction has the same property
   **)
  Theorem ft_reducer_app :
    forall {A : Type} {F : Type -> Type}
      (tr : fingertree (F A)) (xs ys : list A)
      (op : F A -> list A -> list A),
      (forall a (xs ys : list A), op a (xs ++ ys) = (op a xs) ++ ys) ->
      ft_reducer op tr (xs ++ ys) = (ft_reducer op tr xs) ++ ys.
  Proof.
    intros A F tr. induction tr; intros; [reflexivity | apply H |]; simpl.
    - rewrite (digit_reducer_app xs ys d0 op H).
      rewrite IHtr.
      + remember (ft_reducer (nd_reducer op) tr (digit_reducer op d0 xs)) as xs'.
        apply (digit_reducer_app xs' ys d op H).
      + intros. apply nd_reducer_app. assumption.
  Qed.

  (** Helper lemma for second single of ft_reducer_addl' *)
  Lemma ft_reducer_addl'_single : forall {A B : Type} a op (xs : list A) (ys : B),
      ft_reducer op (addl' xs (single a)) ys =
      ft_reducer op (to_tree xs) (op a ys).
  Proof.
    induction xs.
    - intros. reflexivity.
    - intros. simpl. rewrite ft_reducer_addl.
      simpl in IHxs. rewrite (ft_reducer_addl _ (op a ys) a0).
      rewrite IHxs. reflexivity.
  Qed.

  (** Helper lemma for second deep of ft_reducer_addl' *)
  Lemma ft_reducer_addl'_deep : forall {A B : Type} op (xs : list A) (ys : B) pf sf m,
      ft_reducer op (addl' xs (deep pf m sf)) ys =
      ft_reducer op (to_tree xs) (ft_reducer op (deep pf m sf) ys).
  Proof.
    induction xs.
    - reflexivity.
    - intros. simpl in *. rewrite (ft_reducer_addl _ ys a op).
      remember (
          digit_reducer op pf (ft_reducer (nd_reducer op) m (digit_reducer op sf ys))
        ) as ys'.
      rewrite (ft_reducer_addl _ ys' a op).
      rewrite IHxs. rewrite Heqys'. reflexivity.
  Qed.

  (** Adding all elements in xs to the left of a fingertree tr and then
      reducing the result from the right, is the same as
      simply reducing the tree-version of xs with an accumulator that
      is tr reduced. Can be seen as another form of the lemma:
      reducer op (tr1 >< tr2) xs = reducer op tr1 (reducer op tr2 xs)
   *)
  Theorem ft_reducer_addl' : forall {A B : Type} op (xs : list A) (ys : B) (tr : fingertree A),
      ft_reducer op (addl' xs tr) ys =
      ft_reducer op (to_tree xs) (ft_reducer op tr ys).
  Proof.
    destruct tr.
    - reflexivity.
    - rewrite ft_reducer_addl'_single. reflexivity.
    - rewrite ft_reducer_addl'_deep. reflexivity.
  Qed.

  (** Same as above, but with addr' instead of addl' *)
  Theorem ft_reducer_addr' : forall {A B : Type} op (xs : list A) (ys : B) (tr : fingertree A),
      ft_reducer op (addr' tr xs) ys =
      ft_reducer op tr (ft_reducer op (to_tree xs) ys).
  Proof.
    induction xs; intros; simpl in *; [reflexivity |].
    destruct tr; simpl.
    - rewrite (ft_reducer_addl (fold_right addl empty xs) ys a op).
      rewrite IHxs. reflexivity.
    - rewrite IHxs. simpl. rewrite (ft_reducer_addl _ ys a op). reflexivity.
    - rewrite IHxs. destruct d0;
                      simpl; rewrite (ft_reducer_addl _ ys a op); try reflexivity.
      rewrite (ft_reducer_addr tr _ (node3 a0 a1 a2) (nd_reducer op)).
      simpl. reflexivity.
  Qed.

  (** Helper lemma *)
  Lemma ft_reducer_deep : forall {A B : Type} op (m : fingertree (node A)) pf sf (ys : B),
      ft_reducer op (deep pf m sf) ys =
      digit_reducer op pf (ft_reducer (nd_reducer op) m (digit_reducer op sf ys)).
  Proof.
    intros. reflexivity.
  Qed.

  (**
     Converting an app3_list of as to a list of node of As and then
     reducing the list of nodes with a node reducer, is the same as
     simply reducing the original app3_list.
  **)
  Lemma nodes_reducer : forall {A B : Type} (xs : app3_list A) (op : A -> B -> B) ys,
      reducer (nd_reducer op) (nodes xs) ys =
      reducer op xs ys.
  Proof.
    induction xs; intros; simpl in *; try reflexivity.
    rewrite IHxs. reflexivity.
  Qed.

  (** Same as above, but with to_tree injected *)
  Lemma nodes_to_list : forall {A B : Type} xs (op : A -> B -> B) ys,
      reducer (nd_reducer op) (to_tree (nodes xs)) ys =
      reducer op (to_tree xs) ys.
  Proof.
    intros A B xs. induction xs; intros; simpl in *; try reflexivity.
    rewrite (ft_reducer_addl _ _ (node3 a a0 a1) _). simpl.
    rewrite 3!(ft_reducer_addl _ _ _ op). rewrite IHxs. reflexivity.
  Qed.

  (** Helper lemma. *)
  Lemma dig_app3_to_list : forall {A B : Type}
                             (m : list A) (op : A -> B -> B) (pf sf : digit A) (ys : B),
      ft_reducer (nd_reducer op) (to_tree (nodes (dig_app3 pf m sf))) ys =
      digit_reducer op pf (ft_reducer op (to_tree m) (digit_reducer op sf ys)).
  Proof.
    intros A B. induction m; intros.
    - destruct pf, sf; try reflexivity.
    - simpl. destruct pf; simpl in *;
               try (rewrite IHm; simpl; rewrite (ft_reducer_addl _ _ a _); reflexivity).
      rewrite (ft_reducer_addl _ _ (node3 a0 a1 a2) _). simpl.
      rewrite (ft_reducer_addl _ _ a _ ). do 3 (apply f_equal).
      simpl in *.  rewrite IHm. reflexivity.
  Qed.

  (**
     Reducing over app3 tr1 xs tr2 "distributes".
     So reducing over appending two trees tr1 and tr2 with some remainder xs,
     is the same as reducing over tr1 with the result of reducing over xs
     with the result of reducing over tr2 with ys as the accumulator.
  **)
  Theorem app3_to_list :
    forall {A B:Type} (op : A -> B -> B) (tr1 tr2 : fingertree A) xs (acc : B),
    ft_reducer op (app3 tr1 xs tr2) acc =
    ft_reducer op tr1 (ft_reducer op (to_tree xs) (ft_reducer op tr2 acc)).
  Proof.
    intros A B op tr1.
    Opaque addl' addr' to_tree. induction tr1 as [| A a | A pf1 m1 IH sf1 ]; intros.
    - simpl. rewrite (ft_reducer_addl' op xs acc tr2). reflexivity.
    - destruct tr2 as [| a0 | pf m sf]; simpl.
      + rewrite (ft_reducer_addr'). reflexivity.
      + rewrite (ft_reducer_addl _ acc a op).
        rewrite (ft_reducer_addl'_single a0 op xs). reflexivity.
      + rewrite (ft_reducer_addl _ acc a op).
        rewrite (ft_reducer_addl'_deep op xs acc pf sf m).
        reflexivity.
    - destruct tr2 as [| a | pf2 m2 sf2 ].
      + simpl. rewrite ft_reducer_addr'. reflexivity.
      + simpl. rewrite (ft_reducer_addr _ _ a op).
        rewrite ft_reducer_addr'. reflexivity.
      + simpl in *. rewrite IH. do 2 (apply f_equal).
        rewrite (@dig_app3_to_list A B). reflexivity.
        Transparent addr' addl' to_tree.
  Qed.

  (**
     Theorem!
     Appending to trees and converting the to lists is the same as converting
     them to lists separately and appending the lists together.
   *)
  Theorem tree_append_hom : forall {A:Type} (tr1 : fingertree A) (tr2 : fingertree A),
    to_list (tr1 >< tr2) = to_list tr1 ++ to_list tr2.
  Proof.
    intros A tr1 tr2. simpl. unfold "><". rewrite app3_to_list. simpl.
    rewrite <- (ft_reducer_app tr1 ); [reflexivity |].
    intros. reflexivity.
  Qed.

  (**
     Theorem!
     Appending two trees is associative with respect to to_list
  *)
  Theorem tree_append_assoc : forall {A : Type} (tr1 tr2 tr3 : fingertree A),
      (tr1 >< (tr2 >< tr3)) >=< ((tr1 >< tr2) >< tr3).
  Proof.
    intros A B tr1. unfold ">=<". unfold "><".
    induction tr1; intros; rewrite ?app3_to_list; reflexivity.
  Qed.

  (** Same as above, but with to_list *)
  Corollary tree_append_assoc_to_list :
    forall {A B : Type} (tr1 tr2 tr3 : fingertree A),
      to_list (tr1 >< (tr2 >< tr3)) = to_list ((tr1 >< tr2) >< tr3).
  Proof.
    intros. simpl. apply tree_append_assoc.
  Qed.

  (** Same as above, but with sums *)
  Corollary tree_append_assoc_sum :
    forall {A : Type} (tr1 tr2 tr3 : fingertree nat),
      reducer plus (tr1 >< (tr2 >< tr3)) 0 = reducer plus ((tr1 >< tr2) >< tr3) 0.
  Proof.
    intros. simpl. apply tree_append_assoc.
  Qed.

  (** ============================================================================== *)
  (**                                    reverse                                     *)
  (** ============================================================================== *)

  (** You can reverse a node *)
  Definition reverse_node {A: Type}
            (f: A -> A) (n: node A): node A  :=
    match n with
    | (node2  a b)  => node2 (f b) (f a)
    | (node3 a b c) => node3 (f c) (f b) (f a)
    end.

  (** You can reverse a digit *)
  Definition reverse_digit {A: Type}
           (f: A -> A) (d: digit A): digit A  :=
    match d with
    | one a        => one (f a)
    | two a b      => two (f b) (f a)
    | three a b c  => three (f c) (f b) (f a)
    | four a b c d => four (f d) (f c) (f b) (f a)
    end.

  (** You can reverse a fingertree *)
  Fixpoint reverse_tree {A: Type}
           (f: A -> A)(tr: fingertree A) : fingertree A :=
    match tr with
    | empty        => empty
    | single x     => single (f x)
    | deep pr m sf =>
      deep (reverse_digit f sf)
           (reverse_tree (reverse_node f) m)
           (reverse_digit f pr)
    end.

  (** the identity function *)
  Definition ident {A:Type} (x:A) :=  x.

  (** Reverse a tree by calling reverse_tree starting with the identity function *)
  Definition reverse {A: Type} : fingertree A -> fingertree A :=
    reverse_tree ident.

  (** Some examples *)
  Example reverse_ex01 :
     reverse (single 1)  = single 1.
  Proof. reflexivity. Qed.

  Example reverse_ex02:forall (A : Type),
      reverse (@empty A)  = (@empty A).
  Proof. reflexivity. Qed.

  Example reverse_ex03 :
    reverse (deep (two 0 1) (single (node2 2 3)) (three 4 5 6)) =
            deep (three 6 5 4) (single (node2 3 2)) (two 1 0).
  Proof. unfold reverse. unfold reverse_tree. unfold reverse_digit.
         simpl. reflexivity. Qed.

  (** ============================================================================== *)
  (**                               proving reverse                                  *)
  (** ============================================================================== *)

  (** Reversing (x <| tr) is the same as reversing tr and adding x to the right*)
  Lemma reverse_addl {A : Type} (tr : fingertree A) :
    forall x fn, reverse_tree fn (x <| tr) = reverse_tree fn tr |> fn x.
  Proof.
    unfold reverse. induction tr; simpl in *; intros; try reflexivity.
    destruct d; try reflexivity.
    simpl in *. rewrite IHtr. reflexivity.
  Qed.

  (**
     Theorem!
     Reversing a tree twice gives you an equivalent tree
   *)
  Theorem reverse_involutive {A B : Type} (tr : fingertree A) :
    forall fn (H : forall x, fn (fn x) = x),
          (reverse_tree fn (reverse_tree fn tr)) = tr.
  Proof.
    induction tr as [| A a | A pf m IH sf] ; intros; simpl in *; [reflexivity | |].
    - rewrite H. reflexivity.
    - rewrite IH.
      + destruct pf, sf; simpl in *;
          rewrite !H; reflexivity.
      + intros. destruct x; simpl; rewrite !H; reflexivity.
  Qed.

  (** Helper lemma *)
  Lemma nd_reducer_cons_app {A:Type} : forall (a1 : node A) (xs ys : list A),
      nd_reducer cons a1 (xs ++ ys) = nd_reducer cons a1 xs ++ ys.
  Proof. destruct a1; reflexivity. Qed.

  (**
    Reversing [x <| tr] is the same as just reversing [tr] and adding [fn x]
    to the right
  *)
  Lemma reverse_tree_addl {A : Type} (tr : fingertree A) (x : A) :
    forall fn, (forall x, fn (fn x) = x) ->
          reverse_tree fn (x <| tr) = reverse_tree fn tr |> fn x .
  Proof.
    induction tr; intros; simpl in *.
    - reflexivity.
    - reflexivity.
    - destruct d; simpl in *; try reflexivity.
      rewrite IHtr. reflexivity.
      intros. destruct x0; simpl; rewrite !H; reflexivity.
  Qed.

  (** [reverse_node] is involutive *)
  Lemma reverse_node_invol {A : Type} :
    forall fn (H: forall x, fn (fn x) = x) (n : node A),
      reverse_node fn (reverse_node fn n) = n.
  Proof.
    destruct n; simpl; intros; rewrite !H; reflexivity.
  Qed.

  (** [reverse_node] is also "cons-like" in the way it interacts with [reverse] *)
  Lemma reverse_node_helper {A B : Type} :
    forall op fn (H: forall x, fn (fn x) = x)
      (H0 : forall (a : A) (acc acc' : list B),
          rev acc' ++ op (fn a) acc = rev (op a acc') ++ acc)
      (n : node A) acc (acc' : list B),
      rev acc' ++ nd_reducer op (reverse_node fn n) acc =
      rev (nd_reducer op n acc') ++ acc.
  Proof.
    intros. destruct n; simpl; rewrite !H0; reflexivity.
  Qed.

  (** reducing a reversed tree to a list is like reducing the tree and
      then reversing the list (generalized)
  *)
  Lemma reverse_reducer
          {A B : Type} (tr : fingertree A) :
    forall acc acc' (fn : A -> A) (op : A -> list B -> list B),
      (forall x, fn (fn x) = x) ->
      (forall a acc acc', rev acc' ++ op (fn a) acc = rev (op a acc') ++ acc) ->
      rev acc' ++ reducer op (reverse_tree fn tr) acc =
      rev (reducer op tr acc') ++ acc.
  Proof.
    induction tr; intros.
    - reflexivity.
    - simpl. apply H0.
    - destruct d,d0; simpl in *; rewrite !H0;
        (rewrite IHtr; [ | apply (reverse_node_invol fn H)
                         | apply (reverse_node_helper op fn H H0)]);
        rewrite !H0; reflexivity.
  Qed.

  (** [cons] is well-behaved with [rev] *)
  Lemma cons_reverse {A : Type} : forall (a : A) (acc acc' : list A),
      rev acc' ++ a :: acc = rev (a :: acc') ++ acc.
  Proof.
    intros. simpl. rewrite <- app_assoc.
    replace ([a] ++ acc) with (a :: acc) by reflexivity.
    reflexivity.
  Qed.

  (**
     Theorem!
     reversing a (tree converted to a list) is the same as
     is reversing the tree and then converting it to a list.
   *)
  Theorem reverse_to_list {A : Type} (tr : fingertree A) :
    rev (to_list tr) = to_list (reverse tr).
  Proof.
    simpl.
    rewrite <- app_nil_r with (l := rev (ft_reducer cons tr [])).
    unfold reverse.
    symmetry.
    specialize (@reverse_reducer A A tr [] [] ident).
    unfold ident in *.
    intros. simpl in H.
    rewrite H; [|intros; reflexivity | apply cons_reverse ].
    reflexivity.
  Qed.

  (* ============================================================================== *)
  (*                      reverse_to_list  with node_lift                           *)
  (* ============================================================================== *)

  (** Lift a type n times into node *)
  Fixpoint node_lift (n:nat) (A:Type) : Type :=
    match n with
    | O => A
    | S n' => node (node_lift n' A)
    end.

  (** Reverse a value of a type lifted into node n times *)
  Fixpoint rev_lift (n:nat) {A:Type} (fn: A -> A) : (node_lift n A -> node_lift n A) :=
    match n with
    | O => fn
    | S n' => reverse_node (rev_lift n' fn)
    end.

  (** Reduce a type lifted into node n times *)
  Fixpoint nd_red_lift {A B : Type} (n:nat) (op : A -> B -> B) :
    (node_lift n A) -> B -> B :=
    match n with
    | O => op
    | S n' => nd_reducer (nd_red_lift n' op)
    end.

  (** (node A) lifted into node n times is the same as node (A lifted into node n times).
      So it describes an unfolding of node_lift.
   *)
  Lemma node_lift_eq (A : Type) (n : nat) :
    node_lift n (node A) = node (node_lift n A).
  Proof.
    induction n.
    - reflexivity.
    - simpl in *. rewrite IHn. reflexivity.
  Qed.

  (** Represent as fingertree of nodes by its node-lifted type. *)
  Program Fixpoint node_lift_tr {A : Type} (n : nat)
             (tr : fingertree (node_lift n (node A))) :
    fingertree (node (node_lift n A)) :=
    match n with
    | O => _
    | S n' => _
    end.
  Next Obligation.
    simpl in *. rewrite node_lift_eq in tr. assumption.
  Defined.

  (** A new induction principle for fingertrees whose types are described in terms of
      a type [A] lifted [n] times into [node].
      We cannot prove it, regrettably, because Coq chokes in the induction hypothesis,
      but we *think* it's consistent.
   *)
  Axiom fingertree_lift_ind
     : forall P : (forall (n : nat) (A : Type), fingertree (node_lift n A) -> Prop),
       (forall (n:nat) (A : Type), P n A empty) ->
       (forall (n:nat) (A : Type) (a : node_lift n A), P n A (single a)) ->
       (forall (n:nat) (A : Type) (d : digit (node_lift n A))
          (f1 : fingertree (node_lift (S n) A)),
           P (S n) A f1 -> forall d0 : digit (node_lift n A), P n A (deep d f1 d0)) ->
       forall (n:nat) (A : Type) (f2 : fingertree (node_lift n A)), P n A f2.

  (** nd_red_lift on cons distributes over append in the accumulator. *)
  Lemma nd_red_lift_app {A:Type} (n : nat) (x y : node_lift n A) :
    forall acc1 acc2,
      nd_red_lift n cons x acc1 ++ nd_red_lift n cons y acc2 =
      nd_red_lift n cons x (acc1 ++ nd_red_lift n cons y acc2).
  Proof.
    induction n; intros; simpl in *.
    - reflexivity.
    - destruct x, y; simpl in *; rewrite ?IHn; reflexivity.
  Qed.

  (** same as above, but specialized to empty lists *)
  Lemma nd_red_lift_app' {A:Type} (n : nat) (x y : node_lift n A) :
    forall acc,
      nd_red_lift n cons x [] ++ nd_red_lift n cons y acc =
      nd_red_lift n cons x (nd_red_lift n cons y acc).
  Proof.
    apply nd_red_lift_app with (acc1 := []).
  Qed.

  (** same as above, but specialized to a single nd_red_lift *)
  Lemma nd_red_lift_app'' {A:Type} (n : nat) (x : node_lift n A) :
    forall xs ys,
      nd_red_lift n cons x xs ++ ys =
      nd_red_lift n cons x (xs ++ ys).
  Proof.
    induction n; intros; simpl in *.
    - reflexivity.
    - destruct x; simpl;
        rewrite !IHn; reflexivity.
  Qed.

  (** specialize above *)
  Lemma nd_red_lift_app''' {A:Type} (n : nat) (x : node_lift n A) :
    forall ys,
      nd_red_lift n cons x [] ++ ys =
      nd_red_lift n cons x ys.
  Proof.
    apply nd_red_lift_app''.
  Qed.

  (**
     Proof of [reducer cons (reverse_node x) acc = rev (reducer cons x []) ++ acc],
     but lifted [n] times into [node].
   *)
  Lemma nd_red_lift_rev {A : Type} (n : nat) (x : node_lift n A) :
    forall acc,
    nd_red_lift n cons (rev_lift n ident x) acc =
    rev (nd_red_lift n cons x []) ++ acc.
  Proof.
    induction n; intros; simpl in *.
    - unfold ident. reflexivity.
    - destruct x; simpl in *.
      + rewrite !IHn. rewrite app_assoc. rewrite <- rev_app_distr.
        rewrite nd_red_lift_app'''. reflexivity.
      + rewrite !IHn. rewrite 2!app_assoc. rewrite <- 2!rev_app_distr.
        rewrite !nd_red_lift_app'''. reflexivity.
  Qed.

  (**
     Proof of
     [rev acc' ++ reducer cons (reverse_node nd) acc =
     rev (reducer cons nd acc') ++ acc]
     but lifted to node n times
   *)
  Lemma rev_node_lem {A : Type} (n : nat) (nd : node (node_lift n A)) :
    forall (acc acc' : list A) ,
      (rev acc') ++ reducer (nd_red_lift n cons) (reverse_node (rev_lift n ident) nd) acc =
      rev (reducer (nd_red_lift n cons) nd acc') ++ acc.
  Proof.
    destruct nd; simpl in *.
    - induction n; simpl in *; intros.
      + rewrite <- !app_assoc. reflexivity.
      +  destruct n0, n1; simpl in *; try (rewrite !IHn; reflexivity);
         rewrite !IHn;
           rewrite <- !nd_red_lift_app';
           remember (nd_red_lift n cons n1 []) as n1s;
           remember (nd_red_lift n cons n2 []) as n2s;
           remember (nd_red_lift n cons n3 []) as n3s;
           remember (nd_red_lift n cons n4 acc') as n4s;
           rewrite <- nd_red_lift_app''' with (x := n0);
           rewrite rev_app_distr with (x := nd_red_lift n cons n0 []);
           rewrite <- !app_assoc;
           apply f_equal; apply nd_red_lift_rev.
    - induction n; simpl in *; intros.
      + rewrite <- !app_assoc. reflexivity.
      +  destruct n0, n1, n2; simpl in *; try (rewrite !IHn; reflexivity);
         rewrite !IHn;
           rewrite <- !nd_red_lift_app';
           (* remember (nd_red_lift n cons n1 []) as n1s; *)
           (* remember (nd_red_lift n cons n2 []) as n2s; *)
           (* remember (nd_red_lift n cons n3 []) as n3s; *)
           (* remember (nd_red_lift n cons n4 []) as n4s; *)
           (* remember (nd_red_lift n cons n5 []) as n5s; *)
           (* remember (nd_red_lift n cons n6 []) as n6s; *)
           try (remember (nd_red_lift n cons n7 acc') as n7s);
           rewrite <- nd_red_lift_app''' with (x := n0);
           try (rewrite <- nd_red_lift_app''' with (x := n3));
           rewrite ?app_nil_r;
           rewrite rev_app_distr with (x := nd_red_lift n cons n0 []);
           try (rewrite rev_app_distr with (x := nd_red_lift n cons n3 []));
           rewrite <- !app_assoc;
           apply f_equal; rewrite !nd_red_lift_rev; rewrite ?app_nil_r;
             reflexivity.
  Qed.

  (** Same as above, just with digits instead *)
  Lemma reverse_rev_digit {A : Type} (n : nat) (d : digit (node_lift n A)) :
    forall (acc acc' : list A),
      (rev acc') ++ digit_reducer (nd_red_lift n cons) (reverse_digit (rev_lift n ident) d) acc =
      rev (digit_reducer (nd_red_lift n cons) d acc') ++ acc.
  Proof.
    unfold ident. remember n as m. induction m;
                    [ destruct d; intros; simpl; rewrite <- !app_assoc; reflexivity |].
    destruct d; intros; simpl in *; rewrite !rev_node_lem; reflexivity.
  Qed.

  (**
     Proof of
     [rev acc' ++ reducer cons (reverse tr) acc =
     rev (reducer cons tr acc') ++ acc]
     but lifted [n] times into [node].
     Uses the custom induction principle.
   *)
  Lemma reverse_reducer_lift {A : Type} (n : nat) (tr : fingertree (node_lift n A)) :
    forall (acc acc' : list A),
      rev acc' ++ ft_reducer (nd_red_lift n cons) (reverse_tree (rev_lift n ident) tr) acc =
      rev (ft_reducer (nd_red_lift n cons) tr acc') ++ acc.
  Proof.
    apply fingertree_lift_ind with (f2 := tr); simpl in *.
    - reflexivity.
    - induction n0; simpl in *.
      + intros. unfold ident. rewrite <- app_assoc. reflexivity.
      + intros. unfold ident. destruct a; simpl in *; rewrite !IHn0; reflexivity.
    - induction n0; intros.
      + simpl in *; unfold ident.
        destruct d; simpl in *;
          [ replace (a :: acc) with ([a] ++ acc)
            by reflexivity
          | replace (a0 :: a :: acc) with ([a0] ++ (a :: acc))
            by reflexivity
          | replace (a1 :: a0 :: a :: acc) with ([a1] ++ (a0 :: a :: acc))
            by reflexivity
          | replace (a2 :: a1 :: a0 :: a :: acc) with ([a2] ++ (a1 :: a0 :: a :: acc))
            by reflexivity
          ];
          rewrite <- H;
          rewrite <- !app_assoc;
          unfold ident;
          rewrite ft_reducer_app by (apply nd_reducer_cons_app);
          (destruct d0;
            simpl; rewrite <- !app_assoc; reflexivity).
      + rewrite reverse_rev_digit.
        rewrite H. rewrite reverse_rev_digit.
        reflexivity.
  Qed.

  (**
     Theorem!
     reversing a (tree converted to a list) is the same as
     is reversing the tree and then converting it to a list.
   *)
  Theorem reverse_to_list_lift {A : Type} (tr : fingertree A) :
    rev (to_list tr) = to_list (reverse tr).
  Proof.
    simpl.
    specialize @reverse_reducer_lift with (A := A) (n := O) (acc' := []) (acc := []).
    intros. simpl in H.
    rewrite <- app_nil_r with (l := rev (ft_reducer cons tr [])).
    rewrite <- H with (tr := tr) (acc := []) (acc' := []).
    reflexivity.
  Qed.

  (* ============================================================================== *)
  (*                   reverse_to_list with sequential induction                    *)
  (* ============================================================================== *)

  Axiom ft_left_ind :
    forall (P : (forall (A : Type), fingertree A -> Prop)),
           (forall (A : Type), P A empty) ->
           (forall (A : Type) (tr : fingertree A) (x : A), P A tr -> P A (x <| tr)) ->
           forall (A : Type) (tr : fingertree A), P A tr.

  Lemma reverse_reducer_left_ind {A : Type} (tr : fingertree A) :
    forall acc acc' fn, (forall x, fn (fn x) = x) ->
                   rev acc' ++ reducer cons (reverse_tree fn tr) acc =
                   rev (reducer cons (map fn tr) acc') ++ acc.
  Proof.
    induction tr using ft_left_ind; intros; simpl in *.
    - reflexivity.
    - rewrite reverse_tree_addl; [| apply H].
      rewrite ft_reducer_addr. rewrite IHtr; [| apply H].
      rewrite map_addl.
      rewrite ft_reducer_addl. simpl.
      rewrite <- app_assoc. reflexivity.
  Qed.

  Theorem reverse_to_list_left_ind {A : Type} (tr : fingertree A) :
    rev (to_list tr) = to_list (reverse tr).
  Proof.
    Opaque map.
    simpl.
    specialize (reverse_reducer_left_ind tr [] [] ident).
    intros. simpl in H.
    rewrite <- app_nil_r with (l := rev (ft_reducer cons tr [])).
    unfold reverse. unfold ident in *. rewrite map_id in H.
    symmetry.
    rewrite H; [|intros; reflexivity].
    reflexivity.
    Transparent map.
  Qed.

End FingerTrees.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Definition synth (lf2 : natural) : natural := plus lf2 (Succ Zero).


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq div prime.
From mathcomp Require Import path fintype bigop.
Add LoadPath "~/git/git.graillo.tf/stage/2019-06/src".
Require Import seq2 arith.

Lemma legendre_formula :
  forall n p, prime p
  -> logn p (n`!) = \sum_(1 <= a < (trunc_log p n).+1) n %/ p ^ a.
Proof.
  move=> n p p_prime.
  assert (
    \sum_(1 <= a < (trunc_log p n).+1) n %/ p ^ a
    = \sum_(1 <= a < (trunc_log p n).+1) \sum_(1 <= i < n.+1) (p ^ a %| i)
    ) as step1.
  apply eq_big ; first by [].
  move=> i _ ; rewrite divn_count_dvd //.
  rewrite step1.
  rewrite exchange_big /= fact_prod logn_prod_f.
  apply eq_big_nat.
  move=> m H.
  move/andP in H.
  destruct H as [m_gt_0 m_lt_Sn].
  rewrite (big_cat_nat _ _ _ (ltn0Sn (trunc_log p m))) /=.
  rewrite -(addn0 (logn p m)).
  congr addn.
  rewrite logn_count_dvd //.
  rewrite (big_cat_nat _ _ _ (ltn0Sn (trunc_log p m))) /=.
  rewrite -{2}(addn0 (\sum_(1 <= i < (trunc_log p m).+1) (p ^ i %| m))).
  congr addn.
  apply/eqP.
  rewrite eqn_0_sum.
  apply/allP.
  move=> f f_in.
  move/nthP in f_in.
  destruct (f_in 0) as [i Hi Hf].
  rewrite size_map in Hi.
  rewrite (nth_map 0) // in Hf.
  rewrite size_iota in Hi.
  rewrite nth_iota // in Hf.
  rewrite eqnE eq_sym -Hf pfactor_dvdn //.
  assert (forall b : bool, (nat_of_bool b == 0) = ~~ b) as H by by case.
  rewrite H -ltnNge.
  apply ltn_addr.
  rewrite ltnS.
  apply leq_logn_trunc_log ; first by [].
  by apply prime_gt1.
  apply expn_ltn_exp with p ; first by apply prime_gt1.
  by apply trunc_logP ; first by apply prime_gt1.
  apply/eqP.
  rewrite eq_sym eqn_0_sum.
  apply/allP.
  move=> f f_in.
  move/nthP in f_in.
  destruct (f_in 0) as [i Hi Hf].
  rewrite size_map in Hi.
  rewrite (nth_map 0) // in Hf.
  rewrite size_iota in Hi.
  rewrite nth_iota // in Hf.
  rewrite eqnE eq_sym -Hf pfactor_dvdn //.
  assert (forall b : bool, (nat_of_bool b == 0) = ~~ b) as H by by case.
  rewrite H -ltnNge.
  apply ltn_addr.
  rewrite ltnS.
  apply leq_logn_trunc_log ; first by [].
  by apply prime_gt1.
  apply leq_trunc_log ; first by apply prime_gt1.
  apply/andP ; by split.
  apply/allP.
  move=> i Hi.
  rewrite map_id mem_iota in Hi.
  move/andP in Hi.
  by destruct Hi.
Qed.


(* https://lawrencecpaulson.github.io/2022/08/31/Ackermann-not-PR-I.html *)
Require Import Arith Lia.
From Equations Require Import Equations.

Equations ack (p : nat * nat) : nat by wf p (lexprod _ _ lt lt) :=
ack (0, n) := S n;
ack (S m, 0) := ack (m, 1);
ack (S m, S n) := ack (m, ack (S m, n)).

Import Nat Peano.

Lemma lt_ack2 i j: j < ack(i,j).
Proof. funelim (ack (i, j)).
- constructor.
- eapply lt_trans. 2: exact H. constructor.
- exact (le_lt_trans _ _ _ H H0).
Qed.

Lemma ack_lt_ack_S2 i j: ack(i, j) < ack (i, S j).
Proof. induction i, j; simp ack; apply lt_ack2. Qed.

Lemma ack_lt_mono2 i j k: j < k -> ack(i,j) < ack(i,k).
Proof. intro H. induction H.
- apply ack_lt_ack_S2.
- eapply lt_trans. exact IHle. apply ack_lt_ack_S2.
Qed.

Lemma lt_mono_imp_le_mono f (LTM: forall n m, n < m -> f n < f m):
forall n m, n <= m -> f n <= f m.
Proof. intros n m H. induction H.
- constructor.
- eapply le_trans. exact IHle. apply lt_le_incl, LTM, lt_succ_diag_r.
Qed.

Lemma ack_le_mono2 k i j: j <= k -> ack(i,j) <= ack(i,k).
Proof. apply (lt_mono_imp_le_mono (fun n => ack(i,n))). apply ack_lt_mono2. Qed.

Lemma ack2_le_ack1 i j: ack (i, S j) <= ack (S i, j).
Proof. induction j; simp ack.
- constructor.
- apply ack_le_mono2. eapply le_trans. exact (lt_ack2 i (S j)). exact IHj.
Qed.

Lemma S_less_ack_S1 i j: S j < ack(S i, j).
Proof. induction j; simp ack.
- apply lt_ack2.
- eapply lt_le_trans. apply lt_ack2. exact (ack_le_mono2 _ _ _ IHj).
Qed.

Lemma ack_lt_ack_S1 i j: ack(i,j) < ack(S i, j).
Proof. induction j; simp ack; apply ack_lt_mono2.
- exact lt_0_1.
- apply S_less_ack_S1.
Qed.

Lemma lt_ack1 i j: i < ack(i,j).
Proof. induction i; simp ack.
- apply lt_0_succ.
- eapply le_lt_trans. exact IHi. apply ack_lt_ack_S1.
Qed.

Lemma ack_1 j: ack(1,j) = j + 2.
Proof. induction j; simp ack.
- constructor.
- now rewrite IHj.
Qed.

Lemma ack_2 j: ack(2,j) = 2 * j + 3.
Proof. induction j; simp ack.
- trivial.
- rewrite IHj, ack_1. lia.
Qed.

Lemma ack_lt_mono1 k i j: i < j -> ack(i, k) < ack(j, k).
Proof. intro H. induction H.
- apply ack_lt_ack_S1.
- eapply lt_trans. apply IHle. apply ack_lt_ack_S1.
Qed.

Lemma ack_le_mono1 k i j: i <= j -> ack(i, k) <= ack(j, k).
Proof. apply (lt_mono_imp_le_mono (fun n => ack(n, k))). apply ack_lt_mono1. Qed.

Lemma ack_nest_bound i1 i2 j: ack(i1, ack(i2,j)) < ack(2 + i1 + i2, j).
Proof.
assert (ack (i1, ack (i2, j)) < ack(i1 + i2, ack(S (i1 + i2), j))). {
eapply Nat.le_lt_trans. apply ack_le_mono1. 2: apply ack_lt_mono2.
- apply le_add_r.
- apply ack_lt_mono1. auto with arith.
}
eapply Nat.lt_le_trans. apply H. rewrite <- ack_equation_3.
apply ack2_le_ack1.
Qed.

Lemma ack_add_bound i1 i2 j: ack(i1,j) + ack(i2,j) < ack (4 + i1 + i2, j).
Proof.
apply (lt_trans _ (ack(2, ack(i1 + i2, j))) _).
- rewrite ack_2.
pose (H1 := ack_le_mono1 j i1 (i1 + i2)).
pose (H2 := ack_le_mono1 j i2 (i1 + i2)).
lia.
- apply ack_nest_bound.
Qed.

Lemma ack_add_bound2 i j k (H: i < ack(k,j)): i + j < ack (4 + k, j).
Proof.
replace (4 + k) with (4 + k + 0) by apply add_0_r.
eapply lt_trans. 2: apply (ack_add_bound k 0 j).
rewrite ack_equation_1. apply add_lt_mono.
- exact H.
- apply lt_succ_diag_r.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Definition synth (lf1 : natural) : natural := Succ (plus Zero lf1).


Require Export Coq.Sets.Ensembles.
Require Export Coq.Lists.List.
Require Import Logic.lib.Coqlib.

Class Language: Type := {
  expr: Type
}.

Definition context {L: Language}: Type := expr -> Prop. (* better to be (Ensemble model) if Ensemble is polymorphic *)

Definition empty_context {L: Language}: context := Empty_set _.

Class Provable (L: Language): Type := {
  provable: expr -> Prop
}.

Class Derivable (L: Language): Type := {
  derivable: context -> expr -> Prop
}.

Class Derivable1 (L:Language): Type := {
  derivable1: expr -> expr -> Prop
}.

Class LogicEquiv (L:Language): Type := {
  logic_equiv: expr -> expr -> Prop
}.

Class Model: Type := {
  model: Type
}.

Class Semantics (L: Language) (MD: Model): Type := {
  denotation: expr -> model -> Prop (* better to be (expr -> Ensemble model) if Ensemble is polymorphic *)
}.

Definition satisfies {L: Language} {MD: Model} {SM: Semantics L MD}: model -> expr -> Prop :=
  fun (m: model) (x: expr) => denotation x m.

Definition ModelClass (MD: Model) := model -> Prop.

Class KripkeModel (MD: Model): Type := {
  Kmodel: Type;
  Kworlds: Kmodel -> Type;
  build_model: forall M: Kmodel, Kworlds M -> model
}.

Definition Kdenotation {L: Language} {MD: Model} {kMD: KripkeModel MD} (M: Kmodel) {SM: Semantics L MD}: expr -> Ensemble (Kworlds M) := fun x m => denotation x (build_model M m).

Definition unit_MD: Model := Build_Model unit.

Definition unit_kMD (MD: Model): KripkeModel MD :=
  Build_KripkeModel MD unit (fun _ => model) (fun _ m => m).

Definition AllModel (MD: Model): ModelClass MD := fun _ => True.

Inductive KripkeModelClass (MD: Model) {kMD: KripkeModel MD} (H: Kmodel -> Prop): ModelClass MD :=
| Build_KripkeModelClass: forall (M: Kmodel) (m: Kworlds M), H M -> KripkeModelClass MD H (build_model M m).

Definition consistent {L: Language} {Gamma: Derivable L}: context -> Prop :=
  fun Phi =>
    exists x: expr, ~ derivable Phi x.

Definition satisfiable {L: Language} {MD: Model} {SM: Semantics L MD}: ModelClass MD -> context -> Prop :=
  fun MC Phi =>
    exists m: model, MC m /\ forall x: expr, Phi x -> satisfies m x.

Definition consequence {L: Language} {MD: Model} {MD: Model} {SM: Semantics L MD}: ModelClass MD -> context -> expr -> Prop :=
  fun MC Phi y =>
    forall m: model, MC m -> (forall x, Phi x -> satisfies m x) -> satisfies m y.

Definition valid {L: Language} {MD: Model} {SM: Semantics L MD}: ModelClass MD -> expr -> Prop :=
  fun MC x =>
    forall m: model, MC m -> satisfies m x.

Definition provable_sound {L: Language} (Gamma: Provable L) {MD: Model} (SM: Semantics L MD) (MC: ModelClass MD): Prop :=
  forall x: expr, provable x -> valid MC x.

Definition derivable_sound {L: Language} (Gamma: Derivable L) {MD: Model} (SM: Semantics L MD) (MC: ModelClass MD): Prop :=
  forall Phi x, derivable Phi x -> consequence MC Phi x.

Definition weakly_complete {L: Language} (Gamma: Provable L) {MD: Model} (SM: Semantics L MD) (MC: ModelClass MD): Prop :=
  forall x: expr, valid MC x -> provable x.

Definition strongly_complete {L: Language} (Gamma: Derivable L) {MD: Model} (SM: Semantics L MD) (MC: ModelClass MD): Prop :=
  forall (Phi: context) (x: expr), consequence MC Phi x -> derivable Phi x.

Declare Scope logic_base.
Declare Scope syntax.
Declare Scope kripke_model.
Declare Scope kripke_model_class.

Notation "m  |=  x" := (satisfies m x) (at level 70, no associativity) : logic_base.
Notation "|--  x" := (provable x) (at level 71, no associativity) : logic_base.
Notation "Phi |---  x" := (derivable Phi x) (at level 70, no associativity) : logic_base.
Notation "Phi ;; x" := (Union _ Phi (Singleton _ x)) (at level 69, left associativity) : logic_base.
Notation "x --||-- y" := (logic_equiv x  y) (at level 71, no associativity): logic_base.
Notation "x |-- y" := (derivable1 x y) (at level 70, no associativity) : logic_base.

Module KripkeModelFamilyNotation.
Notation "'KRIPKE:'  M , m" := (build_model M m) (at level 59, no associativity) : kripke_model.
End KripkeModelFamilyNotation.

Module KripkeModelSingleNotation.
Notation "'KRIPKE:'  m" := (@build_model _ (unit_kMD _) tt m) (at level 59, no associativity) : kripke_model.
End KripkeModelSingleNotation.

Module KripkeModelClass.

Definition kripke_model_class_join {MD: Model} {kMD: KripkeModel MD} (X Y: Kmodel -> Prop): Kmodel -> Prop := fun M => X M /\ Y M.

Notation "x + y" := (kripke_model_class_join x y) : kripke_model_class.

End KripkeModelClass.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Cat.Cat.
Require Import Ext_Cons.Prod_Cat.Prod_Cat.

Local Obligation Tactic := idtac.

Local Open Scope functor_scope.

Program Definition Prod_Functor
        {C1 C2 C1' C2' : Category} (F : C1 –≻ C2) (F' : C1' –≻ C2')
  : (C1 × C1') –≻ (C2 × C2') :=
{|
  FO := fun a => (F _o (fst a), F' _o (snd a))%object;
  FA := fun _ _ f => (F _a (fst f), F' _a (snd f))%morphism
|}.

Next Obligation.
  intros; cbn; repeat rewrite F_id; trivial.
Qed.

Next Obligation.
  intros; cbn; repeat rewrite F_compose; trivial.
Qed.

Definition Bi_Func_1 {Cx C1 C1' Cy : Category} (F : Cx –≻ C1) (F' : (C1 × C1') –≻ Cy)
  : (Cx × C1') –≻ Cy :=
  F' ∘ (Prod_Functor F (@Functor_id C1')).

Definition Bi_Func_2 {Cx C1 C1' Cy : Category} (F : Cx –≻ C1') (F' : (C1 × C1') –≻ Cy) : (C1 × Cx) –≻ Cy :=
  Functor_compose (Prod_Functor (@Functor_id C1) F) F'.

Local Hint Extern 2 => cbn.

Local Obligation Tactic := basic_simpl; do 2 auto.

Program Definition Fix_Bi_Func_1 {C1 C1' Cy : Category} (x : C1) (F : (C1 × C1') –≻ Cy)
  : C1' –≻ Cy :=
{|
  FO := fun a => (F _o (x, a))%object;
  FA := fun _ _ f => (F @_a (_, _) (_, _) (@id _ x, f))%morphism
|}.

Program Definition Fix_Bi_Func_2 {C1 C1' Cy : Category} (x : C1') (F : (C1 × C1') –≻ Cy)
  : C1 –≻ Cy :=
{|
  FO := fun a => (F _o (a, x))%object;
  FA := fun _ _ f => (F @_a (_, _) (_, _) (f, @id _ x))%morphism
|}.

Program Definition Diag_Func (C : Category) : C –≻ (C × C) :=
{|
  FO := fun a => (a, a);
  FA := fun _ _ f => (f, f);
  F_id := fun _ => idpath;
  F_compose := fun _ _ _ _ _ => idpath
|}.

Theorem Prod_Functor_Cat_Proj {C D D' : Category} (F : C –≻ (D × D')) : ((Prod_Functor ((Cat_Proj1 _ _) ∘ F) ((Cat_Proj2 _ _) ∘ F)) ∘ (Diag_Func C))%functor = F.
Proof.
  Func_eq_simpl; trivial.
Qed.

Program Definition Twist_Func (C C' : Category) : (C × C') –≻ (C' × C) :=
{|
  FO := fun a => (snd a, fst a);
  FA := fun _ _ f => (snd f, fst f);
  F_id := fun _ => idpath;
  F_compose := fun _ _ _ _ _ => idpath
|}.

Section Twist_Prod_Func_Twist.
  Context {C C' : Category} (F : C –≻ C') {D D' : Category} (G : D –≻ D').

  Theorem Twist_Prod_Func_Twist : (((Twist_Func _ _) ∘ (Prod_Functor F G)) ∘ (Twist_Func _ _))%functor = Prod_Functor G F.
  Proof.
    Func_eq_simpl; trivial.
  Qed.

End Twist_Prod_Func_Twist.

Section Prod_Functor_compose.
  Context {C D E: Category} (F : C –≻ D) (G : D –≻ E)
          {C' D' E': Category} (F' : C' –≻ D') (G' : D' –≻ E').

  Theorem Prod_Functor_compose : ((Prod_Functor G G') ∘ (Prod_Functor F F') = Prod_Functor (G ∘ F) (G' ∘ F'))%functor.
  Proof.
    Func_eq_simpl; trivial.
  Qed.

End Prod_Functor_compose.


(* begin hide *)
Require Import CoList.
Require Import CoTree.
Require Import PArith.
Require Import QArith.
(* end hide *)

(** * Enumerating The Rationals: Naive Tree *)

(** _Current Status: it seems to be quite diffucult to prove the correctness
    of [find] on a specific tree. The problem with an induction proof here is
    that the tree's structure is hard-coded in the [find] function, but is
    passed as an argument to the [lookup] function_.
  *)

(** Though not presented in the paper, we have constructed this simple
    example to test the CoTree module, and the general proof strategy.

    The properties of this naive approach are even worse than those of
    the naive enumeration presented in [NaiveEnum], as the tree will
    contain many duplicates of the same _unreduced_ rational.
  *)

Module Naive.

  (** The [next] function for this tree can be seen as the equivalent Haskell function below.
<<
    next (n,d) = ((n + 1, d), n / d, (n, d + 1))
>>
      Below you can find the Coq translation of this function, as well as the [tree] and [enum]
      definition using this function.
    *)

  Definition next (p: positive*positive) : (positive*positive)*Q*(positive*positive) :=
    match p with (n,d) => ((Pos.succ n, d), Z.pos n # d, (n, Pos.succ d)) end.

  Definition tree := CoTree.unfold next (1,1)%positive.

  Definition enum := CoTree.bf tree.

  (** Next, we define a [find] function that maps rationals to their position in the
      tree--in this case, it maps it to the rightmost version.
      The idea is that proving the correctness of this function will bring us a long
      way towards proving our enumeration.
    *)

  Definition findp (n d: positive) : path :=
    Pos.peano_rec
      (*Type*) (fun _ => path)
      (*Zero*) (Pos.peano_rec
               (*Type*) (fun _ => path)
               (*Zero*) (CoTree.Here)
               (*Succ*) (fun _ p => CoTree.Right p)
               (*Args*) d
               )
      (*Succ*) (fun _ p => CoTree.Left p)
      (*Args*) n.

  Lemma findp_l (n d: positive) : findp (Pos.succ n) d = CoTree.Left (findp n d).
  Proof.
    unfold findp,Pos.peano_rec.
    rewrite Pos.peano_rect_succ.
    reflexivity.
  Qed.

  Lemma findp_r (d: positive) : findp 1 (Pos.succ d) = CoTree.Right (findp 1 d).
  Proof.
    unfold findp,Pos.peano_rec.
    rewrite Pos.peano_rect_succ.
    reflexivity.
  Qed.

  (** We have to somehow prove a duality between [next] and [findp],
      where in [next] if [n] increases we consume a [Left] path, if [d]
      increases we consume a [Right] path, and in [findp] we generate
      a [Left] path as long as we can consume successors of [n], and
      [Right] paths as long as we can consume successors of [d].
    *)

  Lemma findp_correct (n d: positive) : CoTree.lookup (findp n d) tree = 'n # d.
  Proof.
    unfold tree.
    induction n as [|n] using Pos.peano_ind.
    - induction d as [|d] using Pos.peano_ind.
      * reflexivity.
      * rewrite findp_r.
  Admitted.

  Definition find (q: Q) : 0 < q -> CoTree.path.
    intros Hq.
    destruct q as [n d].
    destruct n as [|n|n]; try discriminate Hq.
    apply (findp n d).
  Defined.

  Theorem find_correct (q: Q) (H: 0 < q) : CoTree.lookup (find q H) tree = q.
  Proof.
    case q as [n d].
    case n as [|n|n].
    - inversion H.
    - unfold find; apply findp_correct.
    - inversion H.
  Qed.
End Naive.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (z : natural) (lf2 : natural) (lf1 : natural)
  : natural := lf1.


From mathcomp Require Import ssreflect.
Require Import NPeano ZArith.
From Coquelicot Require Import Coquelicot.
Require Import Reals Field Psatz Plouffe CPlouffe Million0.

(*
Time Eval native_compute in sumV cprecision cdigit 6.
*)

Definition comp4 := 173751857.

Lemma comp4_def : comp4 = sumV cprecision cdigit 6.
Proof.
native_cast_no_check (refl_equal comp4).
Time Qed.


Require Import Problem.

Theorem solution: task.
Proof.
  unfold task.
  intro.
  apply gcd_swap.
  apply gcd_step.
  induction n; [apply gcd_O|].
  apply gcd_swap.
  replace (S n) with (1 + n) by auto.
  apply gcd_step.
  apply gcd_swap.
  auto.
Qed.