(**
7.2 母関数の基本操作
========================

@suharahiromichi

2021_04_03
*)

From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.
Require Import ssromega.                    (* ssromega タクティク *)
Require Import ssrinv.                      (* inv *)
Require Import Recdef.                      (* Function コマンド *)

Import GRing.Theory.         (* mulrA などを使えるようにする。 *)
Import Num.Theory.           (* unitf_gt0 などを使えるようにする。 *)
Import intZmod.              (* addz など *)
Import intRing.              (* mulz など *)

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

(**
# nat で bool の補題
*)
Section BOOL_NAT.

(**
## bool の and と nat の sub の関係
*)
  Lemma band_nsub (b1 b2 : bool) : (b1 && ~~b2) = (b1 - b2) :> nat.
  Proof.
    by case: b1; case: b2.
  Qed.

(**
## n が 1 のときに 1 を返す ``n == 1`` 関数の定義
*)
  Lemma band_1_0__1' (n : nat) : (n <= 1) && ~~(n <= 0) = (n == 1).
  Proof.
    apply/idP/idP.
    - move/andP => [H1 H2].
        by ssromega.
    - by move/eqP => ->.
  Qed.

  Lemma band_1_0__1 (n : nat) : (n.-1 <= 0) && ~~(n <= 0) = (n == 1).
  Proof.
    apply/idP/idP.
    - move/andP => [H1 H2].
        by ssromega.
    - by move/eqP => ->.
  Qed.

  Lemma nsub_1_0__1' (n : nat) : ((n <= 1) - (n <= 0)) = (n == 1).
  Proof.
    rewrite -band_1_0__1'.
      by rewrite band_nsub.
  Qed.

  Lemma nsub_1_0__1 (n : nat) : ((n.-1 <= 0) - (n <= 0)) = (n == 1).
  Proof.
    rewrite -band_1_0__1.
      by rewrite band_nsub.
  Qed.

End BOOL_NAT.

Open Scope ring_scope.                   (* %R を省略時解釈とする。 *)

Variable fT : fieldType.
Variable z : fT.
Variable Ztr : (nat -> nat) -> fT.
Notation "\Z_ ( n ) F" := (Ztr (fun n => F)) (at level 36).

Section TEST.

  Definition F1 (z : fT) : fT := 1 / (1 - z).
  Definition F2 (z : fT) : fT := 1 / (1 + z).

  Lemma test (z : fT) : F1 z * F2 z = 1 / (1 - z ^+ 2).
  Proof.
    rewrite /F1 /F2.
    rewrite mulf_div !mul1r.
    rewrite -subr_sqr expr1n.
    done.
  Qed.

End TEST.

(**
# 7.2 Basic Maneuvers 基本操作
*)
Section Basic_Maneuvers.

  Section TEST.
    Variables f g : nat -> nat.
    Check \Z_(n)(f n) : fT.
  End TEST.

(**
## 母関数への操作（公理として与える）
*)
  Axiom ztr_equal : forall f g, f =1 g -> \Z_(n)(f n) = \Z_(n)(g n).
  Axiom ztr_unit : \Z_(n)(n <= 0)%N = 1.
(**
``[n == 0]`` としてもよいが、``[-1 == 0]`` も成り立つので、誤解ないように上記の定義とする。
*)
  Axiom ztr_sum : forall f g, \Z_(n)(f n + g n)%N = \Z_(n)(f n) + \Z_(n)(g n).
  Axiom ztr_dif : forall f g, \Z_(n)(f n - g n)%N = \Z_(n)(f n) - \Z_(n)(g n).
  Axiom ztr_distl : forall a f, \Z_(n)(a * f n)%N = a%:R * \Z_(n)(f n).
  Axiom ztr_distr : forall f a, \Z_(n)(f n * a)%N = \Z_(n)(f n) * a%:R.
(**
``n < 0`` の場合, ``f n = f0`` とする。
n が負の部分が \Z に沸いて出るので、その分を加算しないといけない。

``fib -1 = fib 0 = 0`` なので問題ないのだが、ユニット関数 ``[n == 0]`` では成立しない。
*)
  Axiom ztr_shift1 : forall f, \Z_(n)(f n.-1)%N = z * \Z_(n)(f n) + (f 0%N)%:R.

(**
1回シフトの式から、2回シフトの式を求めておく。
*)
  Lemma ztr_shift2 f : \Z_(n)(f n.-2)%N = z^2 * \Z_(n)(f n) + (z + 1) * (f 0%N)%:R.
  Proof.
    rewrite (ztr_shift1 (fun (n : nat) => f n.-1)) /=.
    rewrite ztr_shift1.
    rewrite mulrDr mulrA.                     (* 右辺 *)
    rewrite mulrDl addrA mul1r exprSz expr1z. (* 左辺 *)
    done.
  Qed.

(**
任意回のシフトの式は、以下の式になるが、Σの中に「体型」が書けないので、難しい。

``\Z_(n)(f (n - m)) = z^m * \Z_(n)(f n) + \sum_(0 <= i < m) z^m * (f 0)``
*)

(**
## ``n = 1`` のときだけ 1 になる関数
*)
  Compute (0.-1 <= 0)%N.                    (* true *)
  Compute (1.-1 <= 0)%N.                    (* true *)
  Compute (2.-1 <= 0)%N.                    (* false *)

  Compute ((0.-1 <= 0) - (0 <= 0))%N.       (* 0 *)
  Compute ((1.-1 <= 0) - (1 <= 0))%N.       (* 1 *)
  Compute ((2.-1 <= 0) - (2 <= 0))%N.       (* 0 *)

  Lemma ztr_z : \Z_(n) (n.-1 <= 0)%N = z + 1.
  Proof.
    Check @ztr_shift1 (fun (n : nat) => n <= 0)%N.
    rewrite (@ztr_shift1 (fun (n : nat) => n <= 0)%N).
    rewrite ztr_unit.
      by rewrite mulr1.
  Qed.

  Lemma ztr_z' : \Z_(n) (n == 1)%N = z.
  Proof.
    Check ztr_equal nsub_1_0__1.
    rewrite -(ztr_equal nsub_1_0__1).
    rewrite ztr_dif.
    rewrite ztr_z.
    rewrite ztr_unit.
    rewrite -addrA.
    have H : 1 - 1 = 0.
    - move=> t.
      apply/eqP.
      by rewrite subr_eq add0r.
    - rewrite H addr0.
      done.
  Qed.

(**
## フィボナッチ数列の一般項
*)
  Fixpoint fib (n : nat) : nat :=
    match n with
    | 0 => 0
    | 1 => 1
    | (ppn.+1 as pn).+1 => fib ppn + fib pn (* fib n.-2 + fib n.-1 *)
    end.
(*
  Variable fib : nat -> nat.
 *)

  Lemma fib0 : fib 0 = 0%N.
  Proof.
    done.
  Qed.

  Lemma fib_n n : fib n.+2 = (fib n + fib n.+1)%N.
  Proof.
    done.
  Qed.

  Lemma fibE (n : nat) : fib n = (fib n.-1 + fib n.-2 + (n == 1))%N.
  Proof.
    case: n => [| n] //.                    (* fib 0 *)
    case: n => [| n] //.                    (* fib 1 *)
    have -> : n.+2.-1 = n.+1 by done.
    have -> : n.+1.-1 = n by done.
    have -> : (n.+2 == 1%N) = false by done.
    rewrite fib_n addn0 addnC.              (* fib 2 *)
    done.
  Qed.

  (**
## フィボナッチ数列の母関数
*)
  Definition G := \Z_(n) (fib n).

  Lemma fib_gen' : G = z * G + z^2 * G + z.
  Proof.
    rewrite /G.
    rewrite [LHS](ztr_equal fibE).
    rewrite 2!ztr_sum.
    rewrite ztr_shift1 fib0 addr0.
    rewrite ztr_shift2.
    rewrite fib0 mulr0 addr0.
    rewrite ztr_z'.
    done.
  Qed.

  Lemma l_a_a_0 (a : fT) : -a + a = 0.
  Proof.
    rewrite addrC.
    rewrite -[LHS]add0r addrA.
    rewrite addrK.
    done.
  Qed.

  (* z を含む式は 0 ではない。 *)
  Axiom l_z_z2_n_0 : 1 - z - z ^ 2 != 0.

  Lemma fib_gen : G = z / (1 - z - z^2).
  Proof.
    rewrite -[LHS]mulr1.
    rewrite -[in LHS](mulfV l_z_z2_n_0).
    rewrite [LHS]mulrA.                     (* 「/」 にも使える。 *)
    congr (_ / _).
    rewrite mulrC.
    rewrite 2!mulrBl mul1r.
    rewrite {1}fib_gen'.
    rewrite [_ - z * G]addrC ?addrA.    (* - z * G を先頭にする。 *)
    rewrite l_a_a_0 add0r.              (* 相殺する。 *)
    rewrite [_ - z^2 * G]addrC ?addrA.  (* - z^2 * G を先頭にする。 *)
    rewrite l_a_a_0 add0r.              (* 相殺する。 *)
    done.
  Qed.

End Basic_Maneuvers.

(**
## 任意回数のシフト
*)
Section Shift.

(*
  Definition zs (m : nat) :=
    foldr (@GRing.add fT) 1 (map (exprz z \o Posz) (iota 1 m)).
 *)

  Fixpoint zs (m : nat) : fT :=
    match m with
    | 0 => 1
    | m.+1 => 1 + z * (zs m)
    end.
  Notation "z^^ m" := (zs m) (at level 30, right associativity).

  Goal z^^0 = 1.
  Proof.
    rewrite /zs.
    done.
  Qed.

  Goal z^^1 = 1 + z.
  Proof.
    rewrite /zs.
    rewrite mulr1.
    done.
  Qed.

  Goal z^^2 = 1 + z + z^2.
  Proof.
    rewrite /zs.
    rewrite mulr1 mulrDr mulr1 addrA.
    rewrite exprSz expr1z.
    done.
  Qed.

  Goal 1 + z * z^^3 = z^^4.
  Proof.
    rewrite /zs.
    done.
  Qed.

  Lemma ez_shift (m : nat) : 1 + z * z^^m = z^^m.+1.
  Proof.
    done.
  Qed.

  Lemma ztr_shift f m :
    \Z_(n)(f (n - m.+1)%N) = z^m.+1 * \Z_(n)(f n) + z^^m * (f 0%N)%:R.
  Proof.
    elim: m.
    - rewrite /= mul1r expr1z.
      have H : forall n, f (n - 1)%N = f n.-1.
      + move=> n.
          by rewrite subn1.
      + rewrite (ztr_equal H).
        rewrite -ztr_shift1.
        done.
    - move=> /= m IHm.
      rewrite exprSz mulrDl mul1r addrCA -2!mulrA -mulrDr addrC.
      rewrite -IHm.
      have H1 : forall n, f (n - m.+2)%N = f ((n - m.+1).-1)%N.
      + move=> n.
        f_equal.
          by ssromega.
      have H2 : forall n, f (n.-1 - m.+1)%N = f (n - m.+1).-1%N.
      + move=> n.
        f_equal.
          by ssromega.
      + rewrite (ztr_equal H1).
        rewrite -(ztr_equal H2).
        rewrite -(ztr_shift1 (fun (n : nat) => f (n - m.+1)%N)).
        done.
  Qed.

  Lemma ztr_shift' f m :
    (1 <= m)%N ->
    \Z_(n)(f (n - m)%N) = z^m * \Z_(n)(f n) + z^^m.-1 * (f 0%N)%:R.
  Proof.
    move=> Hm.
    have H : forall n, f (n - m)%N = f (n - m.-1.+1)%N.
    - move=> n.
      f_equal.
        by ssromega.
    - rewrite (ztr_equal H).
      rewrite (ztr_shift f m.-1%N).
        by rewrite prednK.
  Qed.

End Shift.

(* END *)


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.

Require Import basics.
Require Import categories.
Require Import preord.
Require Import sets.
Require Import finsets.
Require Import atoms.

Require Import List.

(**  * Support and finite permutations
  *)

(**  The [supported] record equips types with an operation to get a
     finite set of atoms; this finite set is called the "support."
     This record contains no axioms about the support, but is inteded
     to be used with nominal types, as defined in nominal.v.  We define
     [supported] here because it is convenient to have notation for the
     support of a finite permuatation and disjointness of support
     before we can define the nominal types.

     When [x] is an element of a supported type, we write [‖x‖] for
     the support of [x], and when [y] is also an element of a possibly
     different supported type, we write [x♯y] to mean that the
     support of [x] and [y] are disjoint.
  *)
Module Support.
  Record supported :=
  Supported
  { carrier :> Type
  ; support : carrier -> finset atom
  }.

  Definition disjoint (A B:supported) (a:A) (b:B) :=
    forall v, v ∈ support A a -> v ∈ support B b -> False.
End Support.

Arguments Support.support : simpl never.

Notation supported := Support.supported.
Notation Supported := Support.Supported.
Notation "‖ x ‖" := (Support.support _ x) (at level 20, format "‖ x ‖").
Notation "a ♯ b" := (Support.disjoint _ _ a b)
   (at level 25, no associativity, format "a ♯ b").

Canonical Structure atom_supp :=
  Supported atom (fun x => x::nil).

Definition concat A := fold_right (@app A) nil.

Notation "'fresh' '[' x , .. , z ']'" :=
  (fresh_atom (concat atom
   (cons (Support.support _ x) .. (cons (Support.support _ z) nil) ..))).

(**  Here we define finitely supported permuatations of atoms.  Such
     permutations play an important role in the developement of nominal types.
     The support of a permutation is a finite set that contains all the
     atoms _not_ fixed by the permutation.  Note: the support may be larger
     than necessary; that is, it may contain atoms that are nonetheless
     fixed by the permutation.  In other words, for a permutation [p] every
     atom [v] is either in the support of [p] or else [p v = v]; but it
     is possible that [v] may both be in the support of [p] and also that [p v = v].

     Permutations form a groupoid category (with a single object; hence a group).
     When [p] and [q] are permuatations, we write [p ∘ q] for the composition,
     and [p⁻¹] represents the inverse permuatation.  [u ⇋ v] is the permuatation
     that swaps atoms [u] and [v].

     Because we only deal with the finitely supported permutations, we can
     prove interesting "swap induction" principles, where the inductive
     step must only consider only swapping of two variables.  These induction
     principles witness the fact that every finitely supported permutation
     is equivelant to a finite composition of swappings.
  *)
Module Perm.

Record perm (A B:unit) :=
  Perm
  { f : atom -> atom
  ; g : atom -> atom
  ; support : finset atom
  ; gf : forall x, g (f x) = x
  ; fg : forall x, f (g x) = x
  ; support_axiom : forall v, v ∈ support \/ f v = v
  }.
Arguments f [A B] _ _.
Arguments g [A B] _ _.
Arguments support [A B] _.
Arguments fg [A B] _ _.
Arguments gf [A B] _ _.
Arguments support_axiom [A B] _ _.

Canonical Structure perm_support (A B:unit)  : supported :=
  Supported (perm A B) (@support A B).

Program Definition eq_mixin (A B:unit) : Eq.mixin_of (perm A B) :=
  Eq.Mixin (perm A B) (fun a b => forall x, f a x = f b x) _ _ _.
Solve Obligations with intuition eauto.
Next Obligation.
  simpl; intros. rewrite H. auto.
Qed.

Canonical Structure eq (A B:unit) : Eq.type :=
  Eq.Pack (perm A B) (eq_mixin A B).

Definition ident A : perm A A :=
  Perm A A (fun x => x) (fun x => x) nil
  (fun x => Logic.eq_refl x)
  (fun x => Logic.eq_refl x)
  (fun x => or_intror (Logic.eq_refl x)).

Program Definition compose A B C (p1:perm B C) (p2:perm A B) : perm A C :=
  Perm A C
       (fun x => f p1 (f p2 x))
       (fun x => g p2 (g p1 x))
       (‖p1‖ ++ ‖p2‖)
       _ _ _.
Next Obligation.
  simpl; intros.
  rewrite (gf p1).
  rewrite (gf p2). auto.
Qed.
Next Obligation.
  simpl; intros.
  rewrite (fg p2).
  rewrite (fg p1). auto.
Qed.
Next Obligation.
  simpl; intros.
  destruct (support_axiom p2 v).
  left. apply app_elem; auto.
  rewrite H.
  destruct (support_axiom p1 v).
  left. apply app_elem; auto.
  right; auto.
Qed.

Definition comp_mixin : Comp.mixin_of unit perm
  := Comp.Mixin unit perm ident compose.

Canonical Structure comp : Comp.type :=
  Comp.Pack unit perm comp_mixin.

Lemma category_axioms : Category.axioms unit perm eq_mixin comp_mixin.
Proof.
  constructor; simpl; intros; auto.
  hnf; simpl; auto.
  hnf; simpl; auto.
  hnf; simpl; auto.
  hnf; simpl; intro.
  rewrite H. rewrite H0. auto.
Qed.

Canonical Structure PERM : category
  := Category unit perm eq_mixin comp_mixin category_axioms.

Program Definition inv A B (p:perm A B) : perm B A:=
  Perm B A (g p) (f p) (support p) (fg p) (gf p) _.
Next Obligation.
  intros.
  destruct (support_axiom p v); auto.
  right. rewrite <- H at 1.
  apply gf.
Qed.

Lemma inv_id1 : forall A B (p:perm A B),
  p ∘ (inv A B p) ≈ id(B).
Proof.
  repeat intro. simpl.
  apply fg.
Qed.

Lemma inv_id2 : forall A B (p:perm A B),
  inv A B p ∘ p ≈ id(A).
Proof.
  repeat intro. simpl.
  apply gf.
Qed.

Program Definition groupoid_mixin
  := Groupoid.Mixin
       unit perm
       eq_mixin
       comp_mixin
       inv _.
Next Obligation.
  constructor.
  apply inv_id1.
  apply inv_id2.
Qed.

Definition groupoid :=
  Groupoid
       unit perm
       eq_mixin
       comp_mixin
       category_axioms
       groupoid_mixin.

Lemma f_inj : forall (p:perm tt tt) x y,
  f p x = f p y -> x = y.
Proof.
  intros.
  rewrite <- (gf p x).
  rewrite <- (gf p y).
  rewrite H; auto.
Qed.

Lemma g_inj : forall (p:perm tt tt) x y,
  g p x = g p y -> x = y.
Proof.
  intros.
  rewrite <- (fg p x).
  rewrite <- (fg p y).
  rewrite H; auto.
Qed.

Program Definition swap (x y:atom) : perm tt tt  :=
  Perm tt tt
       (fun z => if string_dec x z then y
                   else if string_dec y z then x else z)
       (fun z => if string_dec x z then y
                   else if string_dec y z then x else z)
       (x::y::nil)
       _ _ _.
Next Obligation.
  simpl; intros. rename x0 into z.
  destruct (string_dec x z).
  destruct (string_dec x y). congruence.
  destruct (string_dec y y); congruence.
  destruct (string_dec y z); try congruence.
  destruct (string_dec x x); congruence.
  destruct (string_dec x z). congruence.
  destruct (string_dec y z); try congruence.
Qed.
Next Obligation.
  simpl; intros. rename x0 into z.
  destruct (string_dec x z).
  destruct (string_dec x y).
  congruence.
  destruct (string_dec y y); congruence.
  destruct (string_dec y z).
  destruct (string_dec x x); congruence.
  destruct (string_dec x z). congruence.
  destruct (string_dec y z); congruence.
Qed.
Next Obligation.
  simpl; intros.
  destruct (string_dec x v).
  left.
  apply cons_elem; auto.
  left. rewrite e; auto.
  destruct (string_dec y v).
  left.
  rewrite e.
  apply cons_elem; right.
  apply cons_elem; auto.
  auto.
Qed.

Lemma swap_swap (p q:atom) :
  swap p q ≈ swap q p.
Proof.
  hnf; simpl; intros.
  destruct (string_dec p x).
  destruct (string_dec q x); auto. congruence.
  destruct (string_dec q x); auto.
Qed.

Lemma assoc (f g h : perm tt tt) :
  f ∘ (g ∘ h) ≈ (f ∘ g) ∘ h.
Proof.
  hnf; simpl; intros. auto.
Qed.

Lemma swap_self_inv p q :
  swap p q ∘ swap p q ≈ id(tt).
Proof.
  hnf; simpl; intros.
  apply (fg (swap p q)).
Qed.

Lemma swap_same_id p :
  swap p p ≈ id(tt).
Proof.
  hnf; simpl; intros.
  destruct (string_dec p x); auto.
Qed.

Lemma swap_swizzle (p q r:atom)
  (Hrp : r <> p) (Hrq : r <> q) (Hpq : p <> q) :
  swap p r ∘ swap r q ≈
  swap r q ∘ swap p q.
Proof.
  intros. hnf. simpl. intros.
  destruct (string_dec r x). subst x.
  destruct (string_dec p q); auto.
  elim Hpq; auto.
  destruct (string_dec r q). elim Hrq; auto.
  destruct (string_dec p r). elim Hrp; auto.
  destruct (string_dec p r). elim Hrp; auto.
  destruct (string_dec q r). elim Hrq; auto.
  destruct (string_dec r r); auto. elim n4; auto.
  destruct (string_dec q x). subst x.
  destruct (string_dec r r). 2: elim n0.
  destruct (string_dec p q).
  elim Hpq; auto.
  destruct (string_dec p r). elim Hrp; auto.
  destruct (string_dec r p). elim Hrp; auto.
  destruct (string_dec q p). elim Hpq; auto.
  auto.
  auto.
  destruct (string_dec p x). subst x.
  destruct (string_dec r q); auto.
  destruct (string_dec q q); auto. elim n2; auto.
  destruct (string_dec r x). contradiction.
  destruct (string_dec q x); auto. contradiction.
Qed.

Lemma support_perm (p:perm tt tt) (v:atom) :
  v ∈ support p <-> f p v ∈ support p.
Proof.
  split; intros.
  destruct (support_axiom p (f p v)); auto.
  apply f_inj in H0. rewrite H0. auto.
  destruct (support_axiom p v); auto.
  rewrite <- H0. auto.
Qed.

Lemma support_perm' (p:perm tt tt) (v:atom) :
  v ∈ support p <-> f (inv tt tt p) v ∈ support p.
Proof.
  split; intros.
  apply support_perm.
  simpl. rewrite fg. auto.
  apply support_perm in H.
  simpl in H. rewrite fg in H. auto.
Qed.

End Perm.

Canonical Structure Perm.eq.
Canonical Structure Perm.comp.
Canonical Structure Perm.perm_support.
Canonical Structure Perm.PERM.
Canonical Structure Perm.groupoid.

Notation perm := (Perm.perm tt tt).
Notation PERM := Perm.PERM.
Coercion Perm.f : Perm.perm >-> Funclass.

Notation "u ⇋ v" := (Perm.swap u v) (at level 20, no associativity).

(**  Permutations with disjoint support commute. *)
Lemma perm_commute (p q:perm) :
  p♯q -> p ∘ q ≈ q ∘ p.
Proof.
  intro.
  hnf; simpl; intros.
  destruct (Perm.support_axiom p x).
  destruct (Perm.support_axiom q x).
  elim (H x); auto.
  rewrite H1.
  destruct (Perm.support_axiom q (p x)).
  elim (H (p x)); auto.
  rewrite <- Perm.support_perm; auto.
  auto.
  rewrite H0.
  destruct (Perm.support_axiom p (q x)).
  destruct (Perm.support_axiom q x).
  elim (H (q x)); auto.
  rewrite <- Perm.support_perm; auto.
  rewrite H2. auto.
  auto.
Qed.

(**  Swappings commute with any permutation by
     applying the permuatation to the swapped atoms.
  *)
Lemma swap_commute u w (p:perm) :
  (p u ⇋ p w) ∘ p ≈ p ∘ (u ⇋ w).
Proof.
  hnf; simpl; intros.
  destruct (string_dec u x).
  destruct (string_dec (p u) (p x)); auto.
  elim n. rewrite e; auto.
  destruct (string_dec (p u) (p x)); auto.
  elim n.
  apply (Perm.f_inj p) in e. auto.
  destruct (string_dec w x).
  destruct (string_dec (p w) (p x)); auto.
  elim n1. rewrite e; auto.
  destruct (string_dec (p w) (p x)); auto.
  elim n1.
  apply (Perm.f_inj p) in e. auto.
Qed.

Lemma swap_commute' u w (p:perm) :
  (u ⇋ w) ∘ p ≈ p ∘ (p⁻¹ u ⇋ p⁻¹ w).
Proof.
  rewrite <- swap_commute.
  simpl.
  rewrite Perm.fg.
  rewrite Perm.fg.
  reflexivity.
Qed.

(**  Here we prove the swapping induction principles.  The first
     decomposes a permutation on the left; the second decomposes
     on the right.

     These induction principles are proved by induction on the
     size of the support set of a permutation.  At each step
     we can reduce the support by applying a swap.
  *)
Require Import Arith.

Lemma swap_induction (P:perm -> Prop) :
  (forall p p', p ≈ p' -> P p -> P p') ->
  P id ->
  (forall u v (p:perm), p u = u -> u <> v -> P p -> P (u ⇋ v ∘ p)) ->
  forall p, P p.
Proof.
  intros Heq Hbase Hind.
  induction p using (induction_ltof1 perm (fun p => length (Perm.support p))).
  case_eq (Perm.support p); intros.
  apply Heq with id(tt).
  hnf; simpl.
  intro x.
  destruct (Perm.support_axiom p x); auto.
  rewrite H0 in H1.
  apply nil_elem in H1. elim H1.
  apply Hbase.

  set (f' x := (c ⇋ (p c)) (p x)).
  set (g' x := Perm.g p ((c ⇋ (p c)) x)).
  assert (Hgf : forall x, g' (f' x) = x).
    unfold g'; unfold f'. simpl.
    intro x.
    destruct (string_dec c (p x)).
    destruct (string_dec c (p c)).
    rewrite <- e0.
    rewrite e.
    apply Perm.gf.
    destruct (string_dec (p c) (p c)); auto.
    rewrite e.
    apply Perm.gf.
    elim n0; auto.
    destruct (string_dec (p c) (p x)); auto.
    destruct (string_dec c c); auto.
    rewrite e.
    apply Perm.gf.
    elim n0. auto.
    destruct (string_dec c (p x)).
    contradiction.
    destruct (string_dec (p c) (p x)); auto.
    contradiction.
    apply Perm.gf.

  assert (Hfg : forall x, f' (g' x) = x).
    unfold g'; unfold f'. simpl.
    intro x.
    destruct (string_dec c x).
    subst x.
    rewrite Perm.fg.
    destruct (string_dec (p c) (p c)).
    destruct (string_dec c (p c)); auto.
    elim n; auto.
    rewrite Perm.fg.
    destruct (string_dec (p c) x).
    rewrite e.
    destruct (string_dec c c); auto.
    elim n0. auto.
    destruct (string_dec c x); auto.
    contradiction.
    destruct (string_dec (p c) x); auto.
    contradiction.
  assert (Hsupport : forall v, v ∈ (l:finset atom) \/ f' v = v).
    intros.
    destruct (Perm.support_axiom p v); auto.
    rewrite H0 in H1.
    apply cons_elem in H1.
    destruct H1.
    right.
    apply atom_strong_eq in H1. subst v.
    unfold f'. simpl.
    destruct (string_dec (p c) (p c)).
    destruct (string_dec c (p c)); auto.
    elim n; auto.
    auto.
    right. unfold f'.
    simpl. rewrite H1.
    destruct (string_dec c v).
    subst v; auto.
    destruct (string_dec (p c) v).
    rewrite <- H1 in e.
    apply Perm.f_inj in e. auto.
    auto.

  set (p' := Perm.Perm tt tt f' g' l Hgf Hfg Hsupport : perm).
  destruct (string_dec c (p c)).
  apply Heq with p'.
  hnf; simpl.
  unfold f'; simpl; intros.
  destruct (string_dec c (p x)).
  rewrite <- e. rewrite <- e0. auto.
  destruct (string_dec (p c) (p x)).
  rewrite <- e0; auto. auto.

  apply H.
  hnf; simpl.
  rewrite H0. simpl. auto.

  apply Heq with (c ⇋ (p c) ∘ p').
  hnf; simpl.
  intro x. unfold f'. simpl.
  destruct (string_dec c (p x)).
  destruct (string_dec c (p c)).
  rewrite <- e. rewrite <- e0. auto.
  rewrite <- e.
  destruct (string_dec (p c) (p c)); auto.
  elim n1; auto.
  destruct (string_dec (p c) (p x)); auto.
  destruct (string_dec c c); auto.
  elim n1. auto.
  destruct (string_dec (p c) (p x)); auto.
  contradiction.
  destruct (string_dec c (p x)).
  contradiction.
  auto.

  apply Hind.
  simpl. unfold f'.
  simpl.
  destruct (string_dec c (p c)); auto.
  destruct (string_dec (p c) (p c)); auto.
  elim n1; auto.
  auto.

  apply H.
  hnf; simpl.
  rewrite H0. simpl. auto.
Qed.

Lemma swap_induction' (P:perm -> Prop) :
  (forall p p', p ≈ p' -> P p -> P p') ->
  P id ->
  (forall u v (p:perm), p u = u -> u <> v -> P p -> P (p ∘ u ⇋ v)) ->
  forall p, P p.
Proof.
  intros.
  apply swap_induction; auto.
  intros.
  apply H with
    (p0 ∘ (Perm.g p0 u) ⇋ (Perm.g p0 v)).
  2: apply H1; auto.
  symmetry; apply swap_commute'.
  rewrite Perm.fg.
  rewrite <- H2 at 2.
  rewrite Perm.gf.
  auto.
  intro. apply Perm.g_inj in H5. elim H3; auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e194m33_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e488m17_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Section fix_syntax.

Variable domain : Set.
Variable env : Set.
Notation formula := (domain -> env -> Prop).
Notation patternless := (env -> Prop).

Notation system := (formula -> formula -> Prop).

Section fix_system.

Variable SF : system.

Variable SF_wf : forall phi phi', SF phi phi' ->
  forall gamma rho,
    phi gamma rho -> exists gamma', phi' gamma' rho.

Definition ts : domain -> domain -> Prop :=
  fun gamma gamma' => exists phi, exists phi',
    SF phi phi' /\ exists rho, phi gamma rho /\ phi' gamma' rho.

CoInductive reach : domain -> formula -> Prop :=
  | done : forall (gamma : domain) (phi : formula),
      (exists rho, phi gamma rho) -> reach gamma phi
  | step : forall gamma gamma' phi,
      ts gamma gamma' -> reach gamma' phi -> reach gamma phi.

Definition lift (psi : patternless) : formula := fun _ => psi.

Definition and (phi phi' : formula) : formula :=
  fun gamma rho => phi gamma rho /\ phi' gamma rho.
Definition or (phi phi' : formula) : formula :=
  fun gamma rho => phi gamma rho \/ phi' gamma rho.
Definition implies (phi phi' : formula) : formula :=
  fun gamma rho => phi gamma rho -> phi' gamma rho.

Definition Valid (phi : formula) : Prop :=
  forall gamma rho, phi gamma rho.

Section IPS.
  Variable CPS : system.

  Inductive IPS : system :=
  | ps_axiom : forall (phi phi' : formula) (psi : patternless),
    SF phi phi' -> IPS (and phi (lift psi)) (and phi' (lift psi))
  | ps_trans : forall (phi phi' phi'' : formula),
      IPS phi phi' -> CPS phi' phi'' -> IPS phi phi''
  | ps_conseq : forall (phi phi' phi2 phi2' : formula),
    Valid (implies phi phi') ->
    IPS phi' phi2 ->
    Valid (implies phi2 phi2') ->
    IPS phi phi2'
  | ps_case : forall (phi phi1 phi' : formula),
    IPS phi phi' -> IPS phi1 phi' -> IPS (or phi phi1) phi'
  .
  (* toss in abs for quantifiers? *)
End IPS.

CoInductive CPS : system :=
| ps_refl : forall phi phi',
  Valid (implies phi phi') -> CPS phi phi'
| ps_release : forall phi phi', IPS CPS phi phi' -> CPS phi phi'
.

Lemma cps_conseq : forall (phi phi' phi2 phi2' : formula),
    Valid (implies phi phi') ->
    CPS phi' phi2 ->
    Valid (implies phi2 phi2') ->
    CPS phi phi2'.
Proof.
  destruct 2.
  intro. apply ps_refl.
  unfold Valid, implies in * |- *.
  firstorder.

  intro. apply ps_release.
  eauto using ps_conseq.
Qed.

Lemma cps_trans : forall (phi phi' phi'' : formula),
  CPS phi phi' -> CPS phi' phi'' -> CPS phi phi''.
Proof.
  destruct 1.

  (* If it was just a validity step, use weakening *)
  assert (Valid (implies phi'' phi'')) by firstorder.
  eauto using cps_conseq.

  (* otherwise it's a wrapped IPS, and we can build
     a wrapped ps_trans *)
  intro. apply ps_release.
  eauto using ps_trans.
Qed.

Lemma istep : forall phi phi',
  IPS CPS phi phi' ->
  forall gamma rho,
    phi gamma rho ->
    exists phi2, exists gamma2,
      ts gamma gamma2 /\ phi2 gamma2 rho /\ CPS phi2 phi'.
Proof.
induction 1; intros.

(* axiom *)
exists (and phi' (lift psi)).
destruct (SF_wf _ _ H _ _ (proj1 H0)).
exists x.
firstorder.
apply ps_refl.
clear; firstorder.

(* trans *)
specialize (IHIPS gamma rho H1).
destruct IHIPS as [phi2 [gamma2 [Hts [Hsat HCPS]]]].
exists phi2. exists gamma2.
intuition.
eauto using cps_trans.

(* conseq *)
specialize (H _ _ H2).
specialize (IHIPS _ _ H).
destruct IHIPS as [phiMid [x [Hts [Hsat Hcps]]]].
exists phiMid. exists x.
intuition.
assert (Valid (implies phiMid phiMid)) by (clear;firstorder).
eauto using cps_conseq.

(* case *)
destruct H1;[apply IHIPS1|apply IHIPS2]; assumption.
Qed.

Lemma sound : forall phi phi', CPS phi phi' ->
  forall gamma rho, phi gamma rho -> reach gamma phi'.
Proof.
cofix.
destruct 1.
clear sound.
intros. apply done. exists rho. firstorder.

intros.
pose proof (istep _ _ H gamma rho H0).
destruct H1 as [phi2 [gamma2 [Hts [Hsat HCPS]]]].
apply step with gamma2.
assumption.
apply sound with (phi:=phi2)(rho:=rho);assumption.
Qed.

End fix_system.
End fix_syntax.

(* Now this should be connected to the more syntactic circulariy *)
Notation domain := nat.
Notation env := nat.
Notation formula := (domain -> env -> Prop).
Notation patternless := (env -> Prop).
Notation system := (formula -> formula -> Prop).

Inductive dec_sys : system :=
  dec_step : dec_sys
  (fun gamma n => gamma = S n)
  (fun gamma n => gamma = n).

Lemma reduces : CPS nat nat dec_sys
  (fun gamma n => gamma = n)
  (fun gamma n => gamma = 0).
Proof.
  apply ps_release.
  apply ps_conseq with
    (phi' :=
      or _ _ (fun gamma n => exists m, n = S m /\ gamma = n)
         (fun gamma n => n = 0 /\ gamma = n))
    (phi2 := (fun gamma _ : env => gamma = 0)).

unfold Valid, implies, or.
intros. subst gamma. destruct rho; intuition eauto.

Focus 2. unfold Valid, implies. trivial.

apply ps_case.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e468m17_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e389m21_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Coq.Program.Basics.
Require Import Coq.Program.Equality.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Logic.Decidable.
Require Import Coq.Bool.Bool.
Require Import BohmTrees.

(* for reference
Inductive Term {Vs : Set} : Set :=
  | term_top : Term
  | term_bot : Term
  | term_join : Term -> Term -> Term
  | term_rand : Term -> Term -> Term
  | term_app : Term -> Term -> Term
  | term_var : Vs -> Term
  | term_lambda : @Term (option Vs) -> Term.
Arguments Term : default implicits.
Hint Constructors Term.

Inductive normal {Vs : Set} : Term Vs -> Prop :=
  | normal_bot : normal BOT
  | normal_join x y : normal x -> normal y -> normal (x || y)
  | normal_rand x y : normal x -> normal y -> normal (x (+) y)
  | normal_app x y : inert x -> normal y -> normal (x * y)
  | normal_lambda x : @normal (option Vs) x -> normal (LAMBDA x)
  | normal_var v : normal (VAR v)
with inert {Vs : Set} : Term Vs -> Set :=
  | inert_var v : inert (VAR v)
  | inert_app x y : inert x -> normal y -> inert (x * y).
Hint Constructors normal inert.
*)

Inductive Normal {Vs : Set} : Set :=
  | Normal_bot : Normal
  | Normal_join : Normal -> Normal -> Normal
  | Normal_rand : Normal -> Normal -> Normal
  | Normal_app : Inert -> Normal -> Normal
  | Normal_lambda : @Normal (option Vs) -> Normal
  | Normal_var : Vs -> Normal
with Inert {Vs : Set} : Set :=
  | Inert_var : Vs -> Inert
  | Inert_app : Inert -> Normal -> Inert.
Hint Constructors Normal Inert.
Arguments Normal : default implicits.
Arguments Inert : default implicits.

(*
Fixpoint force_normal {Vs : Set} (t : Term Vs) : Normal Vs.  Admitted.
Fixpoint forget_normal {Vs : Set} (n : Normal Vs) : Term Vs.  Admitted.
Lemma force_forget {Vs : Set} (n : Normal Vs) :
  force_normal (forget_normal n) = n.
*)

Inductive Tp {Vs : Set} : Set :=
  | Tp_var : Vs -> Tp
  | Tp_exp : Tp -> Tp -> Tp
  | Tp_hole : Tp
  | Tp_error : Tp.
Hint Constructors Tp.
Arguments Tp : default implicits.

Definition delta (Var : Set) := forall x y : Var, {x = y} + {~ x = y}.

Definition sumbool_if {p q : Prop} {t : Type} : {p} + {q} -> t -> t -> t :=
  fun b x y =>
  match b with
  | left _ => x
  | right _ => y
  end.

(* TODO this does not specialize *)
Fixpoint unify {Vs : Set} (d : delta Vs) (a b : Tp Vs) : Tp Vs :=
  match a, b with
  | Tp_hole, c => c
  | c, Tp_hole => c
  | Tp_var v, Tp_var v' => sumbool_if (d v v') a Tp_error
  | Tp_exp a1 a2, Tp_exp b1 b2 =>
    let c1 := unify d a1 b1 in
    let c2 := unify d a2 b2 in
    match c1, c2 with
    | Tp_error, _ => Tp_error
    | _, Tp_error => Tp_error
    |_, _ => Tp_exp c1 c2
    end
  | _, _ => Tp_error
  end.

Inductive TNormal {Ts Vs : Set} : Set :=
  | TNormal_bot : Tp Ts -> TNormal
  | TNormal_join : Tp Ts -> TNormal -> TNormal -> TNormal
  | TNormal_rand : Tp Ts -> TNormal -> TNormal -> TNormal
  | TNormal_app : Tp Ts -> TInert -> TNormal -> TNormal
  | TNormal_lambda : Tp Ts -> @TNormal Ts (option Vs) -> TNormal
  | TNormal_var : Tp Ts -> Vs -> TNormal
with TInert {Ts Vs : Set} : Set :=
  | TInert_var : Tp Ts -> Vs -> TInert
  | TInert_app : Tp Ts -> TInert -> TNormal -> TInert.
Hint Constructors TNormal TInert.
Arguments TNormal : default implicits.
Arguments TInert : default implicits.

Fixpoint annotate_any {Ts Vs : Set} (n : Normal Vs) : TNormal Ts Vs :=
  match n with
  | Normal_bot => TNormal_bot Tp_hole
  | Normal_join x y => TNormal_join Tp_hole (annotate_any x) (annotate_any y)
  | Normal_rand x y => TNormal_rand Tp_hole (annotate_any x) (annotate_any y)
  | Normal_app x y => TNormal_app Tp_hole (annotate_any' x) (annotate_any y)
  | Normal_lambda x => TNormal_lambda Tp_hole (annotate_any x)
  | Normal_var v => TNormal_var Tp_hole v
  end
with annotate_any' {Ts Vs : Set} (i : Inert Vs) : TInert Ts Vs :=
  match i with
  | Inert_var v => TInert_var Tp_hole v
  | Inert_app x y => TInert_app Tp_hole (annotate_any' x) (annotate_any y)
  end.

(* TODO
Inductive inhabits {Ts Vs : Set} : Normal Vs -> Tp Ts -> Prop :=
  | inhabits_bot t : inhabits Normal_bot t
.

Inductive infers {Ts Vs : Set} : relation (TNormal Ts Vs) :=
  | infers_bot t : infers (TNormal_bot Tp_hole) (TNormal_bot t)
  | infers_join t tx x ty y :
      infers tx x
.
*)


Require Import Frap Pset12Sig.

Theorem deadlock_freedom :
  forall h p,
    Forall (fun c => goodCitizen {} c {}) p ->
    invariantFor (trsys_of h {} p) (fun h_l_p =>
                                      let '(_, _, p') := h_l_p in
                                      Forall finished p'
                                      \/ exists h_l_p', step h_l_p h_l_p').
Proof.
  (* To begin with, we weaken the invariant to the one proved in Pset11Sig. *)
  simplify.
  eapply invariant_weaken.
  eauto using a_useful_invariant.

  (* What's left is to prove that that invariant implies deadlock-freedom. *)
  first_order.
  cases s.
  cases p0.
  invert H0.

  (* We don't actually need to use the [disjointLocks] property.  It was only
   * important in strengthening the induction to prove that other invariant.
   * Also, the original hypothesis won't be needed anymore.*)
  clear H H6.
Admitted.


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Contractible Basics.Equivalences.
Require Import Types.Prod Types.Forall.
Require Export Tactics.BinderApply.

(** * Extra tactics for homotopy type theory. *)

(** ** Tactics for dealing with [Funext] *)
(** *** Tactics about [transport]ing with [path_forall] *)

(** Given using the variable names from [transport : forall {A : Type} (P : A -> Type) {x y : A}, x = y -> P x -> P y] and [path_forall : {Funext} -> forall {A B} (f g : forall x : A, B x), (forall x : A, f x = g x) -> f = g]:

The high-level idea is that we don't really need functional extensionality if we end up just applying the functions to arguments anyway.  That is, if we have that [forall x, f x = g x], and we only talk about [f y] and [f z], then we don't actually need to transport across [f = g], just [f y = g y] and [f z = g z].

In a bit more detail, if we are transporting across [path_forall f g H], and in the function [P], all instances of [f] are applied to some expressions, say we only see [f x], [f y], ..., [f z], then we can eliminate the [path_forall] by explicitly transporting across [H x], [H y], ..., [H z].  The lemma [path_forall_1_beta] expresses this fact in the case that we see [f] applied to only a single argument in [P], and the tactic [transport_path_forall_hammer] is some fancy Ltac to auto-infer what [P] is and what the argument to [f] is.

The way the tactic does this is by creating an evar for [P] and an evar for the argument to [f], and then using a combination of [assert], [pattern], etc to figure out what each should be.  If you want to see how it works, you can step through each step of [transport_path_forall_hammer] when trying to prove [path_forall_2_beta]. *)

(** First, we prove some helpful lemmas about [path_forall] and [transport] *)
Local Ltac path_forall_beta_t :=
  lazymatch goal with
    | [ |- context[@path_forall ?H ?A ?B ?f ?g ?e] ]
      => let X := fresh in
         pose proof (eissect (@path_forall H A B f g) e) as X;
           case X;
           generalize (@path_forall H A B f g e);
           clear X; clear e;
           intro X; destruct X;
           cbn;
           unfold apD10;
           rewrite !(path_forall_1 f)
  end;
  reflexivity.

(** The basic idea is expressed in the type of this lemma. *)
Lemma path_forall_1_beta `{Funext} A B x P f g e Px
: @transport (forall a : A, B a) (fun f => P (f x)) f g (@path_forall _ _ _ _ _ e) Px
  = @transport (B x) P (f x) (g x) (e x) Px.
Proof.
  path_forall_beta_t.
Defined.

(** The powerful recursive case *)
Lemma path_forall_recr_beta' `{Funext} A B x0 P f g e Px
: @transport (forall a : A, B a)
             (fun f => P f (f x0))
             f
             g
             (@path_forall _ _ _ _ _ e)
             Px
  = @transport ((forall a, B a) * B x0)%type
               (fun x => P (fst x) (snd x))
               (f, f x0)
               (g, g x0)
               (path_prod' (@path_forall _ _ _ _ _ e) (e x0))
               Px.
Proof.
  path_forall_beta_t.
Defined.

(** Rewrite the recursive case after clean-up *)
Lemma path_forall_recr_beta `{Funext} A B x0 P f g e Px
: @transport (forall a : A, B a)
             (fun f => P f (f x0))
             f
             g
             (@path_forall _ _ _ _ _ e)
             Px
  = @transport (forall x : A, B x)
               (fun x => P x (g x0))
               f
               g
               (@path_forall H A B f g e)
               (@transport (B x0)
                           (fun y => P f y)
                           (f x0)
                           (g x0)
                           (e x0)
                           Px).
Proof.
  etransitivity.
  - apply path_forall_recr_beta'.
  - refine (transport_path_prod' _ _ _ _).
Defined.

(** The sledge-hammer for computing with [transport]ing across a [path_forall].  Note that it uses [rewrite], and so should only be used in opaque proofs. *)

(** This helper tactic takes a [term] and a function [f], finds [f x] in [term] and patterns that, returning a pair [(x, term')] such that [term' (f x) ≡ term]. *)
Ltac pull_app term f :=
  let term' := (eval cbv beta in term) in
  match term' with
    | context[f ?x]
      => match eval pattern (f x) in term' with
           | ?term' (f x) => constr:((x, term'))
         end
  end.

Ltac infer_path_forall_recr_beta term :=
  let path_forall_recr_beta' :=
      match term with
        | @transport _ (fun x => @?P0 x) _ _ (@path_forall ?H ?A ?B ?f ?g ?e) _
          => constr:(fun x0 P Px => @path_forall_recr_beta H A B x0 P f g e Px)
      end in
  let Px := match term with @transport _ _ _ _ _ ?Px => constr:(Px) end in
  let P0 := match term with @transport _ (fun f => @?P0 f) _ _ _ _ => constr:(P0) end in
  (** pattern some [f x0] in [P0] *)
  (** Hopefully, no goal will have a variable called [WORKAROUND_FOR_BUG_3458] in the context.  At least not until bug #3458 is fixed. *)
  let P0f := constr:(fun WORKAROUND_FOR_BUG_3458 => ltac:(
                                                      let ret := pull_app (P0 WORKAROUND_FOR_BUG_3458) WORKAROUND_FOR_BUG_3458 in
                                                      exact ret)) in
  let x0 := match P0f with fun f => (?x0, @?P f) => constr:(x0) end in
  let P := match P0f with fun f => (?x0, @?P f) => constr:(P) end in
  let ret := constr:(path_forall_recr_beta' x0 P Px) in
  let retT := type of ret in
  let ret' := (eval cbv beta in ret) in
  let retT' := (eval cbv beta in retT) in
  constr:(ret' : retT').

Ltac transport_path_forall_hammer_helper :=
  let term := match goal with
                | |- context[@transport ?At (fun x => @?Bt x) ?ft ?gt (@path_forall ?H ?A ?B ?f ?g ?e) ?Px]
                  => constr:(@transport At Bt ft gt (@path_forall H A B f g e) Px)
              end in
  let lem := infer_path_forall_recr_beta term in
  pattern term;
    refine (transport _ lem^ _);
    cbv beta.

Ltac transport_path_forall_hammer :=
  transport_path_forall_hammer_helper;
  rewrite ?transport_const;
  repeat (
      transport_path_forall_hammer_helper;
      rewrite ?transport_const
    ).

(** An example showing that it works *)
Lemma path_forall_2_beta' `{Funext} A B x0 x1 P f g e Px
: @transport (forall a : A, B a) (fun f => P (f x0) (f x1)) f g (@path_forall _ _ _ _ _ e) Px
  = @transport (B x0 * B x1)%type (fun x => P (fst x) (snd x)) (f x0, f x1) (g x0, g x1) (path_prod' (e x0) (e x1)) Px.
Proof.
  transport_path_forall_hammer.
  repeat match goal with
           | [ |- context[e ?x] ] => induction (e x)
         end;
    cbn.
  reflexivity.
Qed.

Lemma path_forall_2_beta `{Funext} A B x0 x1 P f g e Px
: @transport (forall a : A, B a) (fun f => P (f x0) (f x1)) f g (@path_forall _ _ _ _ _ e) Px
  = transport (fun y : B x1 => P (g x0) y) (e x1)
     (transport (fun y : B x0 => P y (f x1)) (e x0) Px).
Proof.
  transport_path_forall_hammer.
  reflexivity.
Qed.

(** ** A more powerful variant of [path_induction] *)
(** We first define some helper tactics, and then define [path_induction_hammer], which has poor computational behavior, but is vastly more powerful than [path_induction], and removes paths which are discoverably contractible, and paths which only appear in the goal, etc. *)

(** A variant of [induction] which also tries [destruct] and [case], and may be extended to using other [destruct]-like tactics. *)
Ltac induction_hammer H :=
  destruct H || induction H || (case H; clear H).

(** Takes a term of type [_ = _], and tries to replace it by [idpath] by trying to prove that it's an hProp.  The ordering of attempts is tuned for speed. *)
Ltac clear_contr_path p :=
  let H := fresh in
  let T := type of p in
  progress (
      first [ assert (H : idpath = p) by exact (center _)
            | assert (H : idpath = p)
              by (
                  let a := match goal with |- @paths (?x = ?y) ?a ?b => constr:(a) end in
                  let b := match goal with |- @paths (?x = ?y) ?a ?b => constr:(b) end in
                  let x := match goal with |- @paths (?x = ?y) ?a ?b => constr:(x) end in
                  let y := match goal with |- @paths (?x = ?y) ?a ?b => constr:(y) end in
                  apply (@equiv_inv _ _ _ (@equiv_ap _ _ _ (@isequiv_apD10 _ _ _ x y) a b));
                  exact (center _)
                )
            | pose proof (@path_contr T _ idpath p) as H ];
      destruct H;
      (* now reduce any matches on [idpath] (and on other things too) *)
      cbv iota in *
    ).

(** Use both [induction_hammer] and [clear_contr_path] on a path, to try to get rid of it *)
Ltac clear_path_no_check p :=
  induction_hammer p || clear_contr_path p.
Ltac clear_path p :=
  let t := type of p in
  lazymatch eval hnf in t with
    | @paths _ _ _ => clear_path_no_check p || fail 1 "cannot clear path" p
    | _ => fail 0 "clear_path only works on paths;" p "is not a path"
  end.

(** Run [clear_path] on hypotheses *)
(** We don't match only on things of type [_ = _], because maybe that's the head normal form, but it's hiding behind something else; [clear_path] will make sure it's of the right type.  We include some redundant cases at the top, for speed; it is faster to try to destruct everything first, and then do the full battery of tactics, than to just run the hammer. *)
Ltac step_clear_paths :=
  idtac;
  match goal with
    | [ p : _ = _ |- _ ] => destruct p
    | [ p : _ = _ |- _ ] => clear_path_no_check p
    | [ p : _ |- _ ] => clear_path p
  end.
Ltac clear_paths := progress repeat step_clear_paths.

(** Run [clear_path] on anything inside a [match] *)
Ltac step_clear_paths_in_match :=
  idtac;
  match goal with
    | [ |- context[match ?p with idpath => _ end] ] => progress destruct p
    | [ |- context[match ?p with idpath => _ end] ] => clear_path_no_check p
  end.
Ltac clear_paths_in_match := progress repeat step_clear_paths_in_match.

(** Now some lemmas about trivial [match]es *)
Definition match_eta {T} {x y : T} (H0 : x = y)
: (H0 = match H0 in (_ = y) return (x = y) with
          | idpath => idpath
        end)
  := match H0 with idpath => idpath end.

Definition match_eta1 {T} {x : T} (E : x = x)
: (match E in (_ = y) return (x = y) with
     | idpath => idpath
   end = idpath)
  -> idpath = E
  := fun H => ((H # match_eta E) ^)%path.

Definition match_eta2 {T} {x : T} (E : x = x)
: (idpath
   = match E in (_ = y) return (x = y) with
       | idpath => idpath
     end)
  -> idpath = E
  := fun H => match_eta1 E (H ^)%path.

(** And now the actual tactic.  Note that the order of the cases in the [match goal with ... end] is somewhat finely tuned for speed. *)
Ltac step_path_induction_hammer :=
  idtac;
  match goal with
    | _ => reflexivity
    | _ => intro
    | _ => progress cbn in *
    | _ => exact (contr _)
    | [ p : _ = _ |- _ ]
      => progress destruct p (* placed up here for speed *)
    | [ H : _ |- _ ]
      => let H' := fresh in assert (H' := match_eta1 _ H); destruct H'
    | [ H : _ |- _ ]
      => let H' := fresh in assert (H' := match_eta2 _ H); destruct H'
    | _ => step_clear_paths
    | _ => expand; step_clear_paths_in_match
    | _ => progress auto with path_hints
    | _ => done
    | _ => exact (center _)
  end.

Ltac path_induction_hammer := progress repeat step_path_induction_hammer.

(** * Miscellaneous tactics *)

(** Substitute all hypotheses with bodies, i.e., of the form [H := _]. *)
Ltac subst_body :=
  repeat match goal with
           | [ H := _ |- _ ] => subst H
         end.

(** Some tactics to do things with some arbitrary hypothesis in the context.  These tactics are similar to, e.g., [assumption]. *)

Ltac do_with_hyp tac :=
  idtac;
  match goal with
    | [ H : _ |- _ ] => tac H
  end.

Ltac rewrite_hyp' := do_with_hyp ltac:(fun H => rewrite H).
Ltac rewrite_hyp := repeat rewrite_hyp'.
Ltac rewrite_rev_hyp' := do_with_hyp ltac:(fun H => rewrite <- H).
Ltac rewrite_rev_hyp := repeat rewrite_rev_hyp'.

Ltac apply_hyp' := do_with_hyp ltac:(fun H => apply H).
Ltac apply_hyp := repeat apply_hyp'.
Ltac eapply_hyp' := do_with_hyp ltac:(fun H => eapply H).
Ltac eapply_hyp := repeat eapply_hyp'.

(** Run [simpl] on a hypothesis before rewriting with it. *)
Ltac simpl_do_clear tac term :=
  let H := fresh in
  assert (H := term);
    cbn in H |- *;
    tac H;
    clear H.

(** The behavior of [simpl rewrite] with respect to implicit arguments is slightly different from that of [rewrite].  In some ways, it is a little more like [erewrite], but in fact both [rewrite] and [erewrite] use magic that we are unable to exactly duplicate with a user-defined tactic.

The point is that for a user-defined tactic, Coq has to resolve the meaning of the term passed to it in some way before the tactic begins executing.  In particular, if that term involves maximally inserted implicit arguments, then it will have to fill them in; but often there will be no way to do that.  If we declared the argument of [simpl rewrite] as a [constr], then this would cause it to fail.  Instead, we declare it as an [open_constr], which allows Coq to fill in those implicit arguments with existential variables, which can then be instantiated later during the rewriting. *)

Tactic Notation "simpl" "rewrite"      open_constr(term) := simpl_do_clear ltac:(fun H => rewrite    H) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> H) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- H) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite    H in hyp) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> H in hyp) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- H in hyp) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite    H in * ) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> H in * ) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- H in * ) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite    H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- H in hyp |- * ) term.

Tactic Notation "simpl" "rewrite"      open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite    H in * |- ) term.
Tactic Notation "simpl" "rewrite" "->" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> H in * |- ) term.
Tactic Notation "simpl" "rewrite" "<-" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- H in * |- ) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite    !H) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> !H) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- !H) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite    !H in hyp) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> !H in hyp) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- !H in hyp) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite    !H in * ) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> !H in * ) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- !H in * ) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite    !H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> !H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- !H in hyp |- * ) term.

Tactic Notation "simpl" "rewrite"      "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite    !H in * |- ) term.
Tactic Notation "simpl" "rewrite" "->" "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> !H in * |- ) term.
Tactic Notation "simpl" "rewrite" "<-" "!" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- !H in * |- ) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite    ?H) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite -> ?H) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) := simpl_do_clear ltac:(fun H => rewrite <- ?H) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite    ?H in hyp) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite -> ?H in hyp) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" hyp(hyp) := simpl_do_clear ltac:(fun H => rewrite <- ?H in hyp) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite    ?H in * ) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite -> ?H in * ) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" "*" := simpl_do_clear ltac:(fun H => rewrite <- ?H in * ) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite    ?H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite -> ?H in hyp |- * ) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" hyp(hyp) "|-" "*" := simpl_do_clear ltac:(fun H => rewrite <- ?H in hyp |- * ) term.

Tactic Notation "simpl" "rewrite"      "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite    ?H in * |- ) term.
Tactic Notation "simpl" "rewrite" "->" "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite -> ?H in * |- ) term.
Tactic Notation "simpl" "rewrite" "<-" "?" open_constr(term) "in" "*" "|-" := simpl_do_clear ltac:(fun H => rewrite <- ?H in * |- ) term.

Ltac head_hnf expr := let expr' := eval hnf in expr in head expr'.

(* given a [matcher] that succeeds on some hypotheses and fails on
   others, destruct any matching hypotheses, and then execute [tac]
   after each [destruct].

   The [tac] part exists so that you can, e.g., [simpl in *], to
   speed things up. *)
Ltac destruct_all_matches_then matcher tac :=
  repeat match goal with
           | [ H : ?T |- _ ] => matcher T; destruct H; tac
         end.

Ltac destruct_all_matches matcher := destruct_all_matches_then matcher ltac:(simpl in *).
Ltac destruct_all_matches' matcher := destruct_all_matches_then matcher idtac.

(** matches anything whose type has a [T] in it *)
Ltac destruct_type_matcher T HT :=
  match HT with
    | context[T] => idtac
  end.
Ltac destruct_type T := destruct_all_matches ltac:(destruct_type_matcher T).
Ltac destruct_type' T := destruct_all_matches' ltac:(destruct_type_matcher T).

Ltac destruct_head_matcher T HT :=
  match head HT with
    | T => idtac
  end.
Ltac destruct_head T := destruct_all_matches ltac:(destruct_head_matcher T).
Ltac destruct_head' T := destruct_all_matches' ltac:(destruct_head_matcher T).

Ltac destruct_head_hnf_matcher T HT :=
  match head_hnf HT with
    | T => idtac
  end.
Ltac destruct_head_hnf T := destruct_all_matches ltac:(destruct_head_hnf_matcher T).
Ltac destruct_head_hnf' T := destruct_all_matches' ltac:(destruct_head_hnf_matcher T).

(** Turns a context object, obtained via, e.g., [match goal with |- context G[...] => ... end], into a lambda / gallina function. *)
Ltac context_to_lambda G :=
  let ret := constr:(fun x => let k := x in
                              ltac:(
                                let ret := context G[k] in
                                exact ret)) in
  (eval cbv zeta in ret).


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

Require Import ZArith OrdersFacts Nnat NAxioms NSig Lia.

(** * The interface [NSig.NType] implies the interface [NAxiomsSig] *)

Module NTypeIsNAxioms (Import NN : NType').

#[global]
Hint Rewrite
 spec_0 spec_1 spec_2 spec_succ spec_add spec_mul spec_pred spec_sub
 spec_div spec_modulo spec_gcd spec_compare spec_eqb spec_ltb spec_leb
 spec_square spec_sqrt spec_log2 spec_max spec_min spec_pow_pos spec_pow_N
 spec_pow spec_even spec_odd spec_testbit spec_shiftl spec_shiftr
 spec_land spec_lor spec_ldiff spec_lxor spec_div2 spec_of_N
 : nsimpl.
Ltac nsimpl := autorewrite with nsimpl.
Ltac ncongruence := unfold eq, to_N; repeat red; intros; nsimpl; congruence.
Ltac zify := unfold eq, lt, le, to_N in *; nsimpl.
Ltac omega_pos n := generalize (spec_pos n); lia.

Local Obligation Tactic := ncongruence.

#[global]
Instance eq_equiv : Equivalence eq.
Proof. split; ncongruence. Qed.

#[global]
Program Instance succ_wd : Proper (eq==>eq) succ.
#[global]
Program Instance pred_wd : Proper (eq==>eq) pred.
#[global]
Program Instance add_wd : Proper (eq==>eq==>eq) add.
#[global]
Program Instance sub_wd : Proper (eq==>eq==>eq) sub.
#[global]
Program Instance mul_wd : Proper (eq==>eq==>eq) mul.

Theorem pred_succ : forall n, pred (succ n) == n.
Proof.
intros. zify. omega_pos n.
Qed.

Theorem one_succ : 1 == succ 0.
Proof.
now zify.
Qed.

Theorem two_succ : 2 == succ 1.
Proof.
now zify.
Qed.

Definition N_of_Z z := of_N (Z.to_N z).

Lemma spec_N_of_Z z : (0<=z)%Z -> [N_of_Z z] = z.
Proof.
 unfold N_of_Z. zify. apply Z2N.id.
Qed.

Section Induction.

Variable A : NN.t -> Prop.
Hypothesis A_wd : Proper (eq==>iff) A.
Hypothesis A0 : A 0.
Hypothesis AS : forall n, A n <-> A (succ n).

Let B (z : Z) := A (N_of_Z z).

Lemma B0 : B 0.
Proof.
unfold B, N_of_Z; simpl.
rewrite <- (A_wd 0); auto.
red; rewrite spec_0, spec_of_N; auto.
Qed.

Lemma BS : forall z : Z, (0 <= z)%Z -> B z -> B (z + 1).
Proof.
intros z H1 H2.
unfold B in *. apply -> AS in H2.
setoid_replace (N_of_Z (z + 1)) with (succ (N_of_Z z)); auto.
unfold eq. rewrite spec_succ, 2 spec_N_of_Z; auto with zarith.
Qed.

Lemma B_holds : forall z : Z, (0 <= z)%Z -> B z.
Proof.
exact (natlike_ind B B0 BS).
Qed.

Theorem bi_induction : forall n, A n.
Proof.
intro n. setoid_replace n with (N_of_Z (to_Z n)).
apply B_holds. apply spec_pos.
red. now rewrite spec_N_of_Z by apply spec_pos.
Qed.

End Induction.

Theorem add_0_l : forall n, 0 + n == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m).
Proof.
intros. zify. auto with zarith.
Qed.

Theorem sub_0_r : forall n, n - 0 == n.
Proof.
intros. zify. omega_pos n.
Qed.

Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m).
Proof.
intros. zify. lia.
Qed.

Theorem mul_0_l : forall n, 0 * n == 0.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m.
Proof.
intros. zify. ring.
Qed.

(** Order *)

Lemma eqb_eq x y : eqb x y = true <-> x == y.
Proof.
 zify. apply Z.eqb_eq.
Qed.

Lemma leb_le x y : leb x y = true <-> x <= y.
Proof.
 zify. apply Z.leb_le.
Qed.

Lemma ltb_lt x y : ltb x y = true <-> x < y.
Proof.
 zify. apply Z.ltb_lt.
Qed.

Lemma compare_eq_iff n m : compare n m = Eq <-> n == m.
Proof.
 intros. zify. apply Z.compare_eq_iff.
Qed.

Lemma compare_lt_iff n m : compare n m = Lt <-> n < m.
Proof.
 intros. zify. reflexivity.
Qed.

Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m.
Proof.
 intros. zify. reflexivity.
Qed.

Lemma compare_antisym n m : compare m n = CompOpp (compare n m).
Proof.
 intros. zify. apply Z.compare_antisym.
Qed.

Include BoolOrderFacts NN NN NN [no inline].

#[global]
Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

#[global]
Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

#[global]
Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

#[global]
Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

#[global]
Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
Proof.
intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
Qed.

Theorem lt_succ_r : forall n m, n < succ m <-> n <= m.
Proof.
intros. zify. lia.
Qed.

Theorem min_l : forall n m, n <= m -> min n m == n.
Proof.
now intros n m; zify; lia.
Qed.

Theorem min_r : forall n m, m <= n -> min n m == m.
Proof.
now intros n m; zify; lia.
Qed.

Theorem max_l : forall n m, m <= n -> max n m == n.
Proof.
now intros n m; zify; lia.
Qed.

Theorem max_r : forall n m, n <= m -> max n m == m.
Proof.
now intros n m; zify; lia.
Qed.

(** Properties specific to natural numbers, not integers. *)

Theorem pred_0 : pred 0 == 0.
Proof.
zify. auto.
Qed.

(** Power *)

#[global]
Program Instance pow_wd : Proper (eq==>eq==>eq) pow.

Lemma pow_0_r : forall a, a^0 == 1.
Proof.
 intros. now zify.
Qed.

Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b.
Proof.
 intros a b. zify. intros. now Z.nzsimpl.
Qed.

Lemma pow_neg_r : forall a b, b<0 -> a^b == 0.
Proof.
 intros a b. zify. intro Hb. exfalso. omega_pos b.
Qed.

Lemma pow_pow_N : forall a b, a^b == pow_N a (to_N b).
Proof.
 intros. zify. f_equal.
 now rewrite Z2N.id by apply spec_pos.
Qed.

Lemma pow_N_pow : forall a b, pow_N a b == a^(of_N b).
Proof.
 intros. now zify.
Qed.

Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p).
Proof.
 intros. now zify.
Qed.

(** Square *)

Lemma square_spec n : square n == n * n.
Proof.
 now zify.
Qed.

(** Sqrt *)

Lemma sqrt_spec : forall n, 0<=n ->
 (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)).
Proof.
 intros n. zify. apply Z.sqrt_spec.
Qed.

Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0.
Proof.
 intros n. zify. intro H. exfalso. omega_pos n.
Qed.

(** Log2 *)

Lemma log2_spec : forall n, 0<n ->
 2^(log2 n) <= n /\ n < 2^(succ (log2 n)).
Proof.
 intros n. zify. change (Z.log2 [n]+1)%Z with (Z.succ (Z.log2 [n])).
 apply Z.log2_spec.
Qed.

Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0.
Proof.
 intros n. zify. apply Z.log2_nonpos.
Qed.

(** Even / Odd *)

Definition Even n := exists m, n == 2*m.
Definition Odd n := exists m, n == 2*m+1.

Lemma even_spec n : even n = true <-> Even n.
Proof.
 unfold Even. zify. rewrite Z.even_spec.
 split; intros (m,Hm).
 - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n.
 - exists [m]. revert Hm; now zify.
Qed.

Lemma odd_spec n : odd n = true <-> Odd n.
Proof.
 unfold Odd. zify. rewrite Z.odd_spec.
 split; intros (m,Hm).
 - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n.
 - exists [m]. revert Hm; now zify.
Qed.

(** Div / Mod *)

#[global]
Program Instance div_wd : Proper (eq==>eq==>eq) div.
#[global]
Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.

Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b).
Proof.
intros a b. zify. intros. apply Z.div_mod; auto.
Qed.

Theorem mod_bound_pos : forall a b, 0<=a -> 0<b ->
 0 <= modulo a b /\ modulo a b < b.
Proof.
intros a b. zify. apply Z.mod_bound_pos.
Qed.

(** Gcd *)

Definition divide n m := exists p, m == p*n.
Local Notation "( x | y )" := (divide x y) (at level 0).

Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m].
Proof.
 intros n m. split.
 - intros (p,H). exists [p]. revert H; now zify.
 - intros (z,H). exists (of_N (Z.abs_N z)). zify.
   rewrite N2Z.inj_abs_N.
   rewrite <- (Z.abs_eq [m]), <- (Z.abs_eq [n]) by apply spec_pos.
   now rewrite H, Z.abs_mul.
Qed.

Lemma gcd_divide_l : forall n m, (gcd n m | n).
Proof.
 intros n m. apply spec_divide. zify. apply Z.gcd_divide_l.
Qed.

Lemma gcd_divide_r : forall n m, (gcd n m | m).
Proof.
 intros n m. apply spec_divide. zify. apply Z.gcd_divide_r.
Qed.

Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m).
Proof.
 intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest.
Qed.

Lemma gcd_nonneg : forall n m, 0 <= gcd n m.
Proof.
 intros. zify. apply Z.gcd_nonneg.
Qed.

(** Bitwise operations *)

#[global]
Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit.

Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true.
Proof.
 intros. zify. apply Z.testbit_odd_0.
Qed.

Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false.
Proof.
 intros. zify. apply Z.testbit_even_0.
Qed.

Lemma testbit_odd_succ : forall a n, 0<=n ->
 testbit (2*a+1) (succ n) = testbit a n.
Proof.
 intros a n. zify. apply Z.testbit_odd_succ.
Qed.

Lemma testbit_even_succ : forall a n, 0<=n ->
 testbit (2*a) (succ n) = testbit a n.
Proof.
 intros a n. zify. apply Z.testbit_even_succ.
Qed.

Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false.
Proof.
 intros a n. zify. apply Z.testbit_neg_r.
Qed.

Lemma shiftr_spec : forall a n m, 0<=m ->
 testbit (shiftr a n) m = testbit a (m+n).
Proof.
 intros a n m. zify. apply Z.shiftr_spec.
Qed.

Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m ->
 testbit (shiftl a n) m = testbit a (m-n).
Proof.
 intros a n m. zify. intros Hn H. rewrite Z.max_r by auto with zarith.
 now apply Z.shiftl_spec_high.
Qed.

Lemma shiftl_spec_low : forall a n m, m<n ->
 testbit (shiftl a n) m = false.
Proof.
 intros a n m. zify. intros H. now apply Z.shiftl_spec_low.
Qed.

Lemma land_spec : forall a b n,
 testbit (land a b) n = testbit a n && testbit b n.
Proof.
 intros a n m. zify. now apply Z.land_spec.
Qed.

Lemma lor_spec : forall a b n,
 testbit (lor a b) n = testbit a n || testbit b n.
Proof.
 intros a n m. zify. now apply Z.lor_spec.
Qed.

Lemma ldiff_spec : forall a b n,
 testbit (ldiff a b) n = testbit a n && negb (testbit b n).
Proof.
 intros a n m. zify. now apply Z.ldiff_spec.
Qed.

Lemma lxor_spec : forall a b n,
 testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
Proof.
 intros a n m. zify. now apply Z.lxor_spec.
Qed.

Lemma div2_spec : forall a, div2 a == shiftr a 1.
Proof.
 intros a. zify. now apply Z.div2_spec.
Qed.

(** Recursion *)

Definition recursion (A : Type) (a : A) (f : NN.t -> A -> A) (n : NN.t) :=
  N.peano_rect (fun _ => A) a (fun n a => f (NN.of_N n) a) (NN.to_N n).
Arguments recursion [A] a f n.

#[global]
Instance recursion_wd (A : Type) (Aeq : relation A) :
 Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A).
Proof.
unfold eq.
intros a a' Eaa' f f' Eff' x x' Exx'.
unfold recursion.
unfold NN.to_N.
rewrite <- Exx'; clear x' Exx'.
induction (Z.to_N [x]) using N.peano_ind.
simpl; auto.
rewrite 2 N.peano_rect_succ. now apply Eff'.
Qed.

Theorem recursion_0 :
  forall (A : Type) (a : A) (f : NN.t -> A -> A), recursion a f 0 = a.
Proof.
intros A a f; unfold recursion, NN.to_N; rewrite NN.spec_0; simpl; auto.
Qed.

Theorem recursion_succ :
  forall (A : Type) (Aeq : relation A) (a : A) (f : NN.t -> A -> A),
    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
      forall n, Aeq (recursion a f (succ n)) (f n (recursion a f n)).
Proof.
unfold eq, recursion; intros A Aeq a f EAaa f_wd n.
replace (to_N (succ n)) with (N.succ (to_N n)) by
 (zify; now rewrite <- Z2N.inj_succ by apply spec_pos).
rewrite N.peano_rect_succ.
apply f_wd; auto.
zify. now rewrite Z2N.id by apply spec_pos.
fold (recursion a f n). apply recursion_wd; auto. red; auto.
Qed.

End NTypeIsNAxioms.

Module NType_NAxioms (NN : NType)
 <: NAxiomsSig <: OrderFunctions NN <: HasMinMax NN
 := NN <+ NTypeIsNAxioms.


Require Import Braun.monad.monad Braun.common.util Braun.common.le_util.
Require Import Braun.common.big_oh Braun.common.braun Braun.fold.fold.
Require Import Braun.make_array.rows Braun.make_array.take_drop_split.
Require Import Braun.make_array.build.
Require Import Arith Arith.Le Arith.Lt Peano Arith.Min.
Require Import Coq.Arith.Compare_dec List.
Require Import Program.Wf Init.Wf.

Include WfExtensionality.

Fixpoint foldr_build_time (l : list (nat * nat)) :=
  match l with
    | nil => 3
    | cons (pair k len) rst =>
      build_time k len +
      9 +
      foldr_build_time rst
  end.
Hint Unfold foldr_build_time.

Definition foldr_build_result
           (A:Set)
           (base : list (@bin_tree A))
           (l : list (nat * (list A)))
           (res : list (@bin_tree A))
           c :=
  (forall k l2, In (pair k l2) l -> length l2 <= k)
  -> c = foldr_build_time
           (map (fun x => (pair (fst x) (length (snd x))))
                l).
Hint Unfold foldr_build_result.

Load "foldr_build_gen.v".

Next Obligation.
Proof.
  clear am H3 am0 H2.
  rename H0 into BR.
  rename H1 into FBR.

  unfold build_result in *.
  unfold foldr_build_result in *.
  intros LES.
  simpl.
  simpl in BR.
  assert (length l0 <= n) as L0N.
  remember (LES n l0).
  apply l.
  constructor.
  reflexivity.
  apply BR in L0N.
  assert (an0 = foldr_build_time (map (fun x => (fst x, length (snd x))) xs)).
  apply FBR.
  intros k l2.
  remember (LES k l2).
  intros IN.
  apply l.
  right; auto.
  omega.
Qed.

Definition make_array_linear_time len :=
  rows1_time len +
  foldr_build_time (rows_sizes 1 len) +
  10.

Definition make_array_linear_result (A:Set) (xs:list A) (res:@bin_tree A) c :=
  c = make_array_linear_time (length xs).
Hint Unfold make_array_linear_result.

Load "make_array_linear_gen.v".

Lemma make_array_linear_time_helper :
  forall (A : Set)
         (xs : list A)
         (the_rows : list (nat * list A))
         (an : nat)
         (FBR : foldr_build_result A (bt_mt :: nil) the_rows nil an)
         (an0 : nat)
         (RR : rows1_result A xs the_rows an0),
    make_array_linear_result A xs bt_mt (an0 + (an + 10)).
Proof.
  intros.

  unfold foldr_build_result in *.
  unfold rows1_result in *.
  unfold make_array_linear_result.
  unfold make_array_linear_time.
  destruct RR as [AN0 [INSTUFF MAPEQ]].
  rewrite MAPEQ in FBR.
  assert (an = foldr_build_time (rows_sizes 1 (length xs))) as ANEQ.
  apply FBR; auto.
  omega.
Qed.

Next Obligation.
Proof.
  clear am0 am H2 H3.
  rename H0 into FBR.
  rename H1 into RR.
  apply (make_array_linear_time_helper A xs the_rows an FBR an0 RR).
Qed.

Next Obligation.
Proof.
  clear am0 am H2 H3.
  rename H0 into FBR.
  rename H1 into RR.
  apply (make_array_linear_time_helper A xs the_rows an FBR an0 RR).
Qed.

Program Fixpoint fbt_rs_1 k len {measure len} :=
  match k with
    | 0 => 3
    | S _ =>
      match len with
        | 0 => 3
        | S _ =>
          build_time k (min k len) +
          9 +
          fbt_rs_1 (2*k) (len-k)
      end
  end.
Next Obligation.
Proof.
  omega.
Qed.

Lemma fbt_rs_1_0n :
  forall n,
    fbt_rs_1 0 n = 3.
Proof.
  intros n.
  unfold fbt_rs_1.
  unfold_sub fbt_rs_1_func
             (fbt_rs_1_func
                (existT (fun _ : nat => nat) 0 n)).
  simpl.
  reflexivity.
Qed.

Lemma fbt_rs_1_S0 :
  forall k',
    fbt_rs_1 (S k') 0 = 3.
Proof.
  intros k'.
  unfold fbt_rs_1.
  unfold_sub fbt_rs_1_func
             (fbt_rs_1_func
                (existT (fun _ : nat => nat) (S k') 0) = 3).
  simpl.
  reflexivity.
Qed.

Lemma fbt_rs_1_SS :
  forall k' len',
    fbt_rs_1 (S k') (S len') =
    build_time (S k') (min (S k') (S len')) +
    9 +
    fbt_rs_1 (2*(S k')) ((S len')-(S k')).
Proof.
  intros k' len'.
  unfold fbt_rs_1 at 1.
  unfold_sub fbt_rs_1_func
             (fbt_rs_1_func
                (existT (fun _ : nat => nat) (S k') (S len'))).
  simpl.
  fold_sub fbt_rs_1_func.
  reflexivity.
Qed.

Lemma fbt_rs_01 :
  forall k,
    big_oh (fun n => foldr_build_time (rows_sizes k n))
           (fun n => fbt_rs_1 k n).
Proof.
  intros k.
  exists 0.
  exists 1.
  intros n LT; clear LT.
  unfold mult; rewrite plus_0_r.
  replace (foldr_build_time (rows_sizes k n))
  with (fbt_rs_1 k n).
  omega.
  generalize dependent k.
  apply (well_founded_induction
           lt_wf
           (fun n =>
              forall k,
                fbt_rs_1 k n =
                foldr_build_time (rows_sizes k n))).
  clear n; intros n IND.

  intros k.
  destruct k.
  rewrite fbt_rs_1_0n.
  simpl.
  reflexivity.

  destruct n.
  rewrite fbt_rs_1_S0.
  simpl.
  reflexivity.

  rewrite fbt_rs_1_SS.
  rewrite IND; try omega.
  rewrite rows_sizes_SS.
  simpl.
  omega.
Qed.

Program Fixpoint fbt_rs_2 k len {measure len} :=
  match k with
    | 0 => 3
    | S _ =>
      match len with
        | 0 => 3
        | S _ =>
          build_time k k +
          9 +
          fbt_rs_2 (2*k) (len-k)
      end
  end.
Next Obligation. omega. Qed.

Lemma fbt_rs_2_0n :
  forall n,
    fbt_rs_2 0 n = 3.
Proof.
  intros n.
  unfold fbt_rs_2.
  unfold_sub fbt_rs_2_func
             (fbt_rs_2_func
                (existT (fun _ : nat => nat) 0 n)).
  simpl.
  reflexivity.
Qed.

Lemma fbt_rs_2_S0 :
  forall k',
    fbt_rs_2 (S k') 0 = 3.
Proof.
  intros k'.
  unfold fbt_rs_2.
  unfold_sub fbt_rs_2_func
             (fbt_rs_2_func
                (existT (fun _ : nat => nat) (S k') 0) = 3).
  simpl.
  reflexivity.
Qed.

Lemma fbt_rs_2_SS :
  forall k' len',
    fbt_rs_2 (S k') (S len') =
    build_time (S k') (S k') +
    9 +
    fbt_rs_2 (2*(S k')) ((S len')-(S k')).
Proof.
  intros k' len'.
  unfold fbt_rs_2 at 1.
  unfold_sub fbt_rs_2_func
             (fbt_rs_2_func
                (existT (fun _ : nat => nat) (S k') (S len'))).
  simpl.
  fold_sub fbt_rs_2_func.
  reflexivity.
Qed.

Lemma fbt_rs_12 :
  forall k,
    big_oh (fun n => fbt_rs_1 k n)
           (fun n => fbt_rs_2 k n).
Proof.
  intros k.
  exists 0.
  exists 2.
  intros n LT.
  clear LT.
  generalize dependent k.
  apply (well_founded_induction
           lt_wf
           (fun n =>
              forall k,
                fbt_rs_1 k n <= 2 * fbt_rs_2 k n)).
  clear n; intros n IND k.

  destruct k.
  rewrite fbt_rs_1_0n.
  rewrite fbt_rs_2_0n.
  omega.

  destruct n.
  rewrite fbt_rs_1_S0.
  rewrite fbt_rs_2_S0.
  omega.

  rewrite fbt_rs_1_SS.
  rewrite fbt_rs_2_SS.

  apply (le_trans (build_time (S k) (min (S k) (S n)) + 9 + fbt_rs_1 (2 * S k) (S n - S k))
                  (build_time (S k) (min (S k) (S n)) + 9 + 2* (fbt_rs_2 (2 * S k) (S n - S k)))
                  (2 * (build_time (S k) (S k) + 9 + fbt_rs_2 (2 * S k) (S n - S k)))).
  apply le_plus_right.
  apply IND.
  omega.
  rewrite mult_plus_distr_l.
  apply le_plus_left.
  rewrite mult_plus_distr_l.
  replace (2*9) with (9+9);[|omega].
  rewrite plus_assoc.
  apply le_plus_left.
  unfold mult.
  rewrite plus_0_r.
  unfold build_time.
  repeat (rewrite <- plus_assoc).
  repeat (apply le_plus_right).
  unfold zip_with_3_bt_node_time.
  destruct (le_lt_dec k n).
  rewrite min_l.
  omega.
  omega.
  rewrite min_r; try omega.
Qed.

Program Fixpoint fbt_rs_3 k len {measure len} :=
  match k with
    | 0 => 1
    | S _ =>
      match len with
        | 0 => 1
        | S _ => k + fbt_rs_3 (2*k) (len-k)
      end
  end.
Next Obligation.
Proof.
  omega.
Qed.

Lemma fbt_rs_3_S0 :
  forall k',
    fbt_rs_3 (S k') 0 = 1.
Proof.
  intros.
  unfold fbt_rs_3.
  unfold_sub fbt_rs_3_func
             (fbt_rs_3_func (existT (fun _ : nat => nat) (S k') 0)).
  simpl.
  reflexivity.
Qed.

Lemma fbt_rs_3_SS :
  forall k' len',
    fbt_rs_3 (S k') (S len') =
    (S k') + fbt_rs_3 (2*(S k')) ((S len')-(S k')).
Proof.
  intros k' len'.
  unfold fbt_rs_3 at 1.
  unfold_sub fbt_rs_3_func
             (fbt_rs_3_func
                (existT (fun _ : nat => nat) (S k') (S len'))).
  simpl.
  fold_sub fbt_rs_3_func.
  reflexivity.
Qed.

Lemma fbt_rs_23 :
  forall k,
    big_oh (fun n => fbt_rs_2 k n)
           (fun n => fbt_rs_3 k n).
Proof.
  intros k.
  exists 0.
  exists 104.
  intros n LT. clear LT.
  generalize dependent k.
  apply (well_founded_induction
           lt_wf
           (fun n =>
              forall k,
                fbt_rs_2 k n <= 104 * fbt_rs_3 k n)).
  clear n; intros n IND k.

  destruct k.
  rewrite fbt_rs_2_0n.
  simpl.
  omega.

  destruct n.
  rewrite fbt_rs_2_S0.
  simpl.
  omega.

  rewrite fbt_rs_2_SS.
  apply (le_trans (build_time (S k) (S k) + 9 + fbt_rs_2 (2 * S k) (S n - S k))
                  (build_time (S k) (S k) + 9 + 104 * fbt_rs_3 (2 * S k) (S n - S k))
                  (104 * fbt_rs_3 (S k) (S n))).
  apply le_plus_right.
  apply IND.
  omega.

  rewrite fbt_rs_3_SS.
  rewrite mult_plus_distr_l.
  apply le_plus_left.
  unfold build_time.
  unfold pad_drop_time.
  unfold split_time.
  unfold take_time.
  dispatch_if COND COND'; intuition.
  unfold drop_time.
  dispatch_if COND2 COND2'; intuition.
  unfold zip_with_3_bt_node_time.
  omega.
Qed.

Lemma fbt_rs_3_n_lt_k : forall k n,  k <> 0 -> n <= k -> fbt_rs_3 k n <= k + 1.
Proof.
  intros k n K0 LT.
  destruct k.
  assert False;intuition.
  clear K0.
  destruct n.
  rewrite fbt_rs_3_S0.
  omega.
  rewrite fbt_rs_3_SS.
  replace (S n - S k) with 0;[|omega].
  replace (2 * S k) with (S (S (2 * k)));[|omega].
  rewrite fbt_rs_3_S0.
  omega.
Qed.

Lemma fbt_rs_3_lt_n2_plus_k_plus_1 :
  forall k n, k <> 0 -> fbt_rs_3 k n <= n * 2 + k + 1.
Proof.
  intros k n K0.
  generalize dependent k.
  apply (well_founded_induction
           lt_wf
           (fun n =>
              forall k,
                k <> 0 ->
                fbt_rs_3 k n <= n * 2 + k + 1)).
  clear n; intros n IND k K0.
  destruct k.
  assert False ; intuition.
  clear K0.

  destruct n.
  rewrite fbt_rs_3_S0.
  omega.

  destruct (le_lt_dec n k).
  apply (le_trans (fbt_rs_3 (S k) (S n))
                  (S k + 1)
                  (S n * 2 + S k + 1)).
  apply fbt_rs_3_n_lt_k;omega.
  omega.

  rewrite fbt_rs_3_SS.

  apply (le_trans (S k + fbt_rs_3 (2 * S k) (S n - S k))
                  (S k + ((S n - S k) * 2 + (2 * S k) + 1))
                  (S n * 2 + S k + 1)).
  apply le_plus_right.
  apply IND; omega.
  omega.
Qed.

Lemma fbt_rs_3_linear : big_oh (fun n => fbt_rs_3 1 n) (fun n => n).
Proof.
  exists 1.
  exists 4.
  intros n LT.
  apply (le_trans (fbt_rs_3 1 n)
                  (n * 2 + 1 + 1)
                  (4 * n)).
  apply fbt_rs_3_lt_n2_plus_k_plus_1.
  omega.
  destruct n; intuition.
Qed.

Lemma foldr_build_linear :
  big_oh (fun n : nat => foldr_build_time (rows_sizes 1 n))
         (fun n : nat => n).
Proof.
  apply (big_oh_trans (fun n : nat => foldr_build_time (rows_sizes 1 n))
                      (fun n => fbt_rs_1 1 n)
                      (fun n : nat => n)).
  apply fbt_rs_01.
  apply (big_oh_trans (fun n => fbt_rs_1 1 n)
                      (fun n => fbt_rs_2 1 n)
                      (fun n : nat => n)).
  apply fbt_rs_12.
  apply (big_oh_trans (fun n => fbt_rs_2 1 n)
                      (fun n => fbt_rs_3 1 n)
                      (fun n : nat => n)).
  apply fbt_rs_23.
  apply fbt_rs_3_linear.
Qed.

Theorem make_array_linear_linear : big_oh make_array_linear_time (fun n => n).
Proof.
  unfold make_array_linear_time.
  apply big_oh_plus;auto.
  apply big_oh_plus.
  apply rows1_time_linear.
  apply foldr_build_linear.
Qed.


Require Import FP.Data.Ascii.
Require Import FP.Data.Function.
Require Import FP.Relations.RelDec.
Require Import FP.Structures.Additive.
Require Import FP.Structures.EqDec.
Require Import FP.Structures.Eqv.
Require Import FP.Structures.Lattice.
Require Import FP.Structures.Monoid.
Require Import FP.Structures.Multiplicative.
Require Import FP.Structures.Ord.
Require Import FP.Structures.Show.
Require Import FP.Structures.Comonad.
Require Import FP.Structures.Foldable.
Require Import FP.Structures.Functor.
Require Import FP.Structures.Iterable.
Require Import FP.Structures.Peano.

Import CharNotation.
Import MonoidNotation.
Import FunctionNotation.
Import ComonadNotation.
Import OrdNotation.

Section EqDec.
  Global Instance nat_EqDec : EqDec nat := { eq_dec := EqNat.beq_nat }.
  Global Instance nat_Eq_RelDecCorrect : RelDecCorrect nat eq eq_dec.
  Proof. constructor ; apply EqNat.beq_nat_true_iff. Qed.
End EqDec.

Section Eqv.
  Global Instance nat_Eqv : Eqv nat := { eqv := eq }.
End Eqv.

Section EqvDec.
  Global Instance nat_EqvDec : EqvDec nat := { eqv_dec := eq_dec }.
  Global Instance nat_Eqv_RelDecCorrect : RelDecCorrect nat eqv eqv_dec.
  Proof. apply nat_Eq_RelDecCorrect. Qed.
End EqvDec.

Section Ord.
  Global Instance nat_Ord : Ord nat := { lt := Peano.lt }.
End Ord.

Section OrdDec.
  Global Instance nat_OrdDec : OrdDec nat := { ord_dec := Compare_dec.nat_compare  }.
End OrdDec.

Section Lattice.
  Global Instance nat_Lattice : Lattice nat :=
    { lmeet := Peano.min
    ; ljoin := Peano.max
    }.
End Lattice.

Section Show.
  Require Coq.Program.Wf.
  Require Omega.

  Section nat_show.

    Variable (R:Type) (SR:ShowResult R).

    Definition digit2char (n:nat) : Ascii.ascii :=
      match n with
        | 0 => "0"%char
        | 1 => "1"%char
        | 2 => "2"%char
        | 3 => "3"%char
        | 4 => "4"%char
        | 5 => "5"%char
        | 6 => "6"%char
        | 7 => "7"%char
        | 8 => "8"%char
        | _ => "9"%char
      end.

    Program Fixpoint nat_show (n:nat) {measure n} : R :=
      if Compare_dec.le_gt_dec n 9 then
        raw_char (digit2char n)
      else
        let n' := NPeano.div n 10 in
        nat_show n' ** raw_char (digit2char (n - 10 * n')).
    Next Obligation.
      assert (NPeano.div n 10 < n) ; eauto.
      eapply NPeano.Nat.div_lt ; omega.
    Defined.
  End nat_show.

  Global Instance nat_Show : Show nat := { show := nat_show }.
End Show.

Section Additive.
  Definition nat_additive_DivMonoid : DivMonoid nat :=
    {| div_monoid_times := Peano.plus
     ; div_monoid_unit := O
     ; div_monoid_div := Peano.minus
    |}.
  Global Instance nat_MinusAdditive : MinusAdditive nat :=
    { minus_additive_DivMonoid := nat_additive_DivMonoid }.
End Additive.
Section Multiplicative.
  Definition nat_multiplicative_DivMonoid : DivMonoid nat :=
    {| div_monoid_times := Peano.mult
     ; div_monoid_unit := S O
     ; div_monoid_div := NPeano.div
    |}.
  Global Instance nat_DivMultiplicative : DivMultiplicative nat :=
    { div_multiplicative_DivMonoid := nat_multiplicative_DivMonoid }.
End Multiplicative.

Fixpoint nat_cofold {m} {C:Comonad m} {A} (f:nat -> m A -> A) (aM:m A) (n:nat) : A :=
  match n with
  | O => f O aM
  | S n =>
      let aM := codo aM => nat_cofold f aM n in
      f (S n) aM
  end.
Instance nat_Foldable : Foldable nat nat :=
  { cofold := @nat_cofold }.

Fixpoint nat_coiter {m} {C:Comonad m} {A} (f:m A -> nat -> A) (aM:m A) (n:nat) : A :=
  match n with
  | O => f aM O
  | S n =>
      let aM := codo aM => f aM (S n) in
      nat_coiter f aM n
  end.
Instance nat_Iterable : Iterable nat nat :=
  { coiter := @nat_coiter }.

Fixpoint nat_coloopr {m} {M:Comonad m} {A} (f:m A -> A) (aM:m A) (n:nat) : A :=
  match n with
  | O => coret aM
  | S n =>
      let aM := codo aM => nat_coloopr f aM n in
      f aM
  end.
Fixpoint nat_coloopl {m} {M:Comonad m} {A} (f:m A -> A) (aM:m A) (n:nat) : A :=
  match n with
  | O => coret aM
  | S n =>
      let aM := codo aM => f aM in
      nat_coloopl f aM n
  end.
Instance nat_Peano : Peano nat :=
  { pzero := O
  ; psucc := S
  ; coloopr := @nat_coloopr
  ; coloopl := @nat_coloopl
  }.


Require Import String List.

Set Implicit Arguments.

(** Mode of a message-passing channel *)
Inductive direction := Send | Recv.

(** Description of available channels *)
Definition channel := string.
Definition channels := channel -> Type.

(** Message-passing processes *)
Section process.
  Variable chs : channels.

  CoInductive process :=
  | DoSend (ch : channel) (v : chs ch) (k : process)
  | DoRecv (ch : channel) (k : chs ch -> process)
  | Parallel (pr1 pr2 : process)
  | Restrict (which : direction * channel -> Prop) (k : process)
  | Done.

  Definition trace := list (direction * sigT chs).

  (** Interleave two traces, possibly doing matchmaking of sends and recvs. *)
  Inductive interleave : trace -> trace -> trace -> Prop :=
  | IntNil1 : forall tr, interleave nil tr tr
  | IntNil2 : forall tr, interleave tr nil tr
  | IntCons1 : forall v tr1 tr2 tr,
    interleave tr1 tr2 tr
    -> interleave (v :: tr1) tr2 (v :: tr)
  | IntCons2 : forall v tr1 tr2 tr,
    interleave tr1 tr2 tr
    -> interleave tr1 (v :: tr2) (v :: tr)
  | IntMatch1 : forall v tr1 tr2 tr,
    interleave tr1 tr2 tr
    -> interleave ((Send, v) :: tr1) ((Recv, v) :: tr2) tr
  | IntMatch2 : forall v tr1 tr2 tr,
    interleave tr1 tr2 tr
    -> interleave ((Recv, v) :: tr1) ((Send, v) :: tr2) tr.

  (** Ensure that a predicate holds for all trace elements. *)
  Definition traceAll (which : direction * channel -> Prop) : trace -> Prop :=
    List.Forall (fun v => which (fst v, projT1 (snd v))).

  (** Traces generated by a process *)
  Inductive traceOf : process -> trace -> Prop :=
  | TrSend : forall ch v k tr,
    traceOf k tr
    -> traceOf (@DoSend ch v k) ((Send, existT _ ch v) :: tr)
  | TrRecv : forall ch v k tr,
    traceOf (k v) tr
    -> traceOf (@DoRecv ch k) ((Recv, existT _ ch v) :: tr)
  | TrParallel : forall pr1 tr1 pr2 tr2 tr,
    traceOf pr1 tr1
    -> traceOf pr2 tr2
    -> interleave tr1 tr2 tr
    -> traceOf (Parallel pr1 pr2) tr
  | TrRestrict : forall which pr tr,
    traceOf pr tr
    -> traceAll which tr
    -> traceOf (Restrict which pr) tr
  | TrDone : forall pr, traceOf pr nil. (* Scheduler might always give up on a process. *)

  (** Consider all traces of two processes. *)
  Definition refines (pr1 pr2 : process) :=
    forall tr, traceOf pr1 tr
      -> traceOf pr2 tr.

  Definition expand (pr : process) : process :=
    match pr with
      | DoSend ch v k => DoSend (ch := ch) v k
      | DoRecv ch k => DoRecv (ch := ch) k
      | Parallel pr1 pr2 => Parallel pr1 pr2
      | Restrict which k => Restrict which k
      | Done => Done
    end.

  Theorem expand_ok : forall pr, pr = expand pr.
  Proof.
    destruct pr; auto.
  Qed.
End process.

Implicit Arguments Done [chs].

Notation "#! chs [ ch , v ] , k" := (DoSend (chs := chs) ch v k) (at level 100, chs at level 0).
Notation "#? chs [ ch , x ] , k" := (DoRecv (chs := chs) ch (fun x => k)) (at level 100, chs at level 0).
Notation "## [ x1 , .. , xN ] , k" := (Restrict (fun p => In p (cons x1 (.. (cons xN nil) ..))) k) (at level 100).
Infix "||" := Parallel.
Export String.
Global Open Scope string_scope.

Hint Constructors interleave traceOf.
Hint Unfold traceAll.


(* The decidable equality for JobIn checks whether the Job
   and the arrival times are the same. *)
Definition jobin_eqdef (arr_seq: arrival_sequence Job) :=
      (fun j1 j2: JobIn arr_seq =>
         (_job_in arr_seq j1 == _job_in arr_seq j2) &&
         (_arrival_time arr_seq j1 == _arrival_time arr_seq j2)).
    Lemma eqn_jobin : forall arr_seq, Equality.axiom (jobin_eqdef arr_seq).
    Proof.
      unfold Equality.axiom; intros arr_seq x y.
      destruct (jobin_eqdef arr_seq x y) eqn:EQ.
      {
        apply ReflectT.
        unfold jobin_eqdef in *.
        move: EQ => /andP [/eqP EQjob /eqP EQarr].
        destruct x, y; ins; subst.
        f_equal; apply bool_irrelevance.
      }
      {
        apply ReflectF.
        unfold jobin_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        move: EQ => /orP [/negP DIFFjob | /negP DIFFarr].
          by apply DIFFjob; inversion BUG; subst; apply/eqP.
          by apply DIFFarr; inversion BUG; subst; apply/eqP.
      }
    Qed.

Canonical jobin_eqMixin arr_seq := EqMixin (eqn_jobin arr_seq).
Canonical jobin_eqType arr_seq := Eval hnf in EqType (JobIn arr_seq) (jobin_eqMixin arr_seq).


Require Import Coq.ZArith.BinIntDef.
Require Import Crypto.Arithmetic.Core. Import B.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Compilers.Tuple.
Require Import Crypto.Compilers.ExprInversion.
Require Import Crypto.Compilers.Z.Syntax.Util.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Tuple.
Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Specific.Framework.ArithmeticSynthesis.Base.
Require Import Crypto.Util.Notations.
Import CurveParameters.Notations.

Local Coercion Z.to_nat : Z >-> nat.
Local Notation interp_flat_type := (interp_flat_type interp_base_type).

Section gen.
  Context (curve : RawCurveParameters.CurveParameters).

  Section gen_base_type.
    Context (b : base_type).

    Definition m := Z.to_pos (curve.(s) - Associational.eval curve.(c))%Z.
    Definition rT := ((Tbase b)^curve.(sz))%ctype.
    Definition T' := (interp_flat_type rT).
    Definition RT := (Unit -> rT)%ctype.
    Definition wt := (wt_gen curve.(base)).
    Definition encode : F m -> Expr RT
      := fun v var
         => Abs
              (fun _
               => SmartPairf
                    (flat_interp_untuple
                       (T:=Tbase _)
                       (Tuple.map
                          (fun v => Op (OpConst v) TT)
                          (@Positional.Fencode wt curve.(sz) m (@modulo_cps) (@div_cps) v)))).
    Definition decode : T' -> F m
      := fun v => @Positional.Fdecode
                    wt (curve.(sz)) m
                    (Tuple.map interpToZ (flat_interp_tuple (T:=Tbase _) v)).
  End gen_base_type.

  Local Notation TW := (TWord (Z.log2_up curve.(bitwidth))).
  Local Notation RTZ := (RT TZ).
  Local Notation rTZ := (rT TZ).
  Local Notation RTW := (RT TW).
  Local Notation rTW := (rT TW).

  Record SynthesisOutput :=
    {
      zeroZ : Expr RTZ;
      oneZ : Expr RTZ;
      addZ : Expr (rTZ * rTZ -> rTZ); (* does not include carry *)
      subZ : Expr (rTZ * rTZ -> rTZ); (* does not include carry *)
      carry_mulZ : Expr (rTZ * rTZ -> rTZ); (* includes carry *)
      carry_squareZ : Expr (rTZ -> rTZ); (* includes carry *)
      oppZ : Expr (rTZ -> rTZ); (* does not include carry *)
      carryZ : Expr (rTZ -> rTZ);
      carry_addZ : Expr (rTZ * rTZ -> rTZ)
      := (carryZ ∘ addZ)%expr;
      carry_subZ : Expr (rTZ * rTZ -> rTZ)
      := (carryZ ∘ subZ)%expr;
      carry_oppZ : Expr (rTZ -> rTZ)
      := (carryZ ∘ oppZ)%expr;

      zeroW : Expr RTW;
      oneW : Expr RTW;
      carry_addW : Expr (rTW * rTW -> rTW); (* includes carry *)
      carry_subW : Expr (rTW * rTW -> rTW); (* includes carry *)
      carry_mulW : Expr (rTW * rTW -> rTW); (* includes carry *)
      carry_squareW : Expr (rTW -> rTW); (* includes carry *)
      carry_oppW : Expr (rTW -> rTW); (* does not include carry *)

      PZ : T' TZ -> Prop;
      PW : T' TW -> Prop
      := fun v => PZ (tuple_map (A:=Tbase TW) (B:=Tbase TZ) (SmartVarfMap (@interpToZ)) v);

      encodeZ_valid : forall v, _;
      encodeZ_sig := fun v => exist PZ (Interp (encode TZ v) tt) (encodeZ_valid v);
      encodeZ_correct : forall v, decode TZ (Interp (encode TZ v) tt) = v;

      decodeZ_sig := fun v : sig PZ => decode TZ (proj1_sig v);

      zeroZ_correct : zeroZ = encode _ 0%F; (* which equality to use here? *)
      oneZ_correct : oneZ = encode _ 1%F; (* which equality to use here? *)
      zeroZ_sig := encodeZ_sig 0%F;
      oneZ_sig := encodeZ_sig 1%F;

      oppZ_valid : forall x, PZ x -> PZ (Interp carry_oppZ x);
      oppZ_sig := fun x => exist PZ _ (@oppZ_valid (proj1_sig x) (proj2_sig x));

      addZ_valid : forall x y, PZ x -> PZ y -> PZ (Interp carry_addZ (x, y));
      addZ_sig := fun x y => exist PZ _ (@addZ_valid (proj1_sig x) (proj1_sig y) (proj2_sig x) (proj2_sig y));

      subZ_valid : forall x y, PZ x -> PZ y -> PZ (Interp carry_subZ (x, y));
      subZ_sig := fun x y => exist PZ _ (@subZ_valid (proj1_sig x) (proj1_sig y) (proj2_sig x) (proj2_sig y));

      mulZ_valid : forall x y, PZ x -> PZ y -> PZ (Interp carry_mulZ (x, y));
      mulZ_sig := fun x y => exist PZ _ (@mulZ_valid (proj1_sig x) (proj1_sig y) (proj2_sig x) (proj2_sig y));

      squareZ_correct : forall x, PZ x -> Interp carry_squareZ x = Interp carry_mulZ (x, x);

      encodeW_valid : forall v, _;
      encodeW_sig := fun v => exist PW (Interp (encode TW v) tt) (encodeW_valid v);
      encodeW_correct : forall v, decode TW (Interp (encode TW v) tt) = v;

      decodeW_sig := fun v : sig PW => decode TW (proj1_sig v);

      zeroW_correct : zeroW = encode _ 0%F; (* which equality to use here? *)
      oneW_correct : oneW = encode _ 1%F; (* which equality to use here? *)
      zeroW_sig := encodeW_sig 0%F;
      oneW_sig := encodeW_sig 1%F;

      oppW_valid : forall x, PW x -> PW (Interp carry_oppW x);
      oppW_sig := fun x => exist PW _ (@oppW_valid (proj1_sig x) (proj2_sig x));

      addW_valid : forall x y, PW x -> PW y -> PW (Interp carry_addW (x, y));
      addW_sig := fun x y => exist PW _ (@addW_valid (proj1_sig x) (proj1_sig y) (proj2_sig x) (proj2_sig y));

      subW_valid : forall x y, PW x -> PW y -> PW (Interp carry_subW (x, y));
      subW_sig := fun x y => exist PW _ (@subW_valid (proj1_sig x) (proj1_sig y) (proj2_sig x) (proj2_sig y));

      mulW_valid : forall x y, PW x -> PW y -> PW (Interp carry_mulW (x, y));
      mulW_sig := fun x y => exist PW _ (@mulW_valid (proj1_sig x) (proj1_sig y) (proj2_sig x) (proj2_sig y));

      squareW_correct : forall x, PW x -> Interp carry_squareW x = Interp carry_mulW (x, x);

      T_Z := { v : T' TZ | PZ v };
      eqTZ : T_Z -> T_Z -> Prop
      := fun x y => eq (decode _ (proj1_sig x)) (decode _ (proj1_sig y));
      ringZ : @Hierarchy.ring
                T_Z eqTZ zeroZ_sig oneZ_sig oppZ_sig addZ_sig subZ_sig mulZ_sig;
      encodeZ_homomorphism
      : @Ring.is_homomorphism
          (F m) eq 1%F F.add F.mul
          T_Z eqTZ oneZ_sig addZ_sig mulZ_sig
          encodeZ_sig;
      decodeZ_homomorphism
      : @Ring.is_homomorphism
          T_Z eqTZ oneZ_sig addZ_sig mulZ_sig
          (F m) eq 1%F F.add F.mul
          decodeZ_sig;

      T_W := { v : T' TW | PW v };
      eqTW : T_W -> T_W -> Prop
      := fun x y => eq (decode _ (proj1_sig x)) (decode _ (proj1_sig y));
      ringW : @Hierarchy.ring
                T_W eqTW zeroW_sig oneW_sig oppW_sig addW_sig subW_sig mulW_sig;
      encodeW_homomorphism
      : @Ring.is_homomorphism
          (F m) eq 1%F F.add F.mul
          T_W eqTW oneW_sig addW_sig mulW_sig
          encodeW_sig;
      decodeW_homomorphism
      : @Ring.is_homomorphism
          T_W eqTW oneW_sig addW_sig mulW_sig
          (F m) eq 1%F F.add F.mul
          decodeW_sig
    }.
End gen.