From Equations Require Import Equations.
Require Import Coq.Program.Equality.
Require Import MirrorSolve.HLists.

Import HListNotations.

Set Universe Polymorphism.

Definition arity sorts := list sorts.

(* a FOL signature is a:
   1) set of sorts (e.g. Z, B, BV(n)),
   2) function symbols indexed by argument sorts and return sort (e.g. plus: Z -> Z -> Z)
   3) relation symbols indexed by argument sorts
*)
Record signature: Type :=
  { sig_sorts: Type;
    sig_funs: arity sig_sorts -> sig_sorts -> Type;
    sig_rels: arity sig_sorts -> Type }.

Section FOL.
  Variable sig: signature.

  (* de Bruijn variable context (i.e. sorts for variables) *)
  Definition ctx := snoc_list sig.(sig_sorts).

  Notation CSnoc := (Snoc sig.(sig_sorts)).
  Notation CEmp := (SLNil sig.(sig_sorts)).

  Import HListNotations.

  (* de Bruijn variables. *)

  Inductive var: ctx -> sig.(sig_sorts) -> Type :=
  | VHere:
    forall ctx s,
      var (CSnoc ctx s) s
  | VThere:
    forall ctx s s',
      var ctx s' ->
      var (CSnoc ctx s) s'.
  Derive Signature NoConfusion for var.

  (* First-order terms (either functions or variables). *)
  Inductive tm: ctx -> sig.(sig_sorts) -> Type :=
  | TVar:
    forall c s,
      var c s ->
      tm c s
  | TFun:
    forall c args ret,
      sig.(sig_funs) args ret ->
      HList.t (tm c) args ->
      tm c ret.
  Derive Signature for tm.

  Section Tm_Ind.

    Variable (P: forall (c: ctx) (srt: sig_sorts sig), tm c srt -> Prop).

    (* custom induction principle that processes the arguments of functions *)
    Definition tm_ind'
      (PV : forall c s v, P c s (TVar c s v))
      (PF: forall c args ret srt (hl : HList.t (tm c) args),
        HList.all (fun srt => P c srt) hl ->
        P c ret (TFun c args ret srt hl)) :
      forall c srt tm, P c srt tm :=
      fix tirec (c: ctx) (srt: sig_sorts sig) (t: tm c srt) {struct t} :=
      match t with
      | TVar c' s' v => PV c' s' v
      | TFun c' args ret srt' hl => PF _ _ _ _ _
        ((fix hlrec l h {struct h} :=
          match h as h' return
            HList.all (fun srt : sig_sorts sig => P c' srt) h' with
          | hnil => I
          | x ::: hlt => conj (tirec _ _ x) (hlrec _ hlt)
          end
        ) args hl)
      end.
  End Tm_Ind.

  (* First-order formulas. *)
  Inductive fm: ctx -> Type :=
  (* True and False *)
  | FTrue: forall c, fm c
  | FFalse: forall c, fm c
  (* Equality *)
  | FEq:
    forall c s,
      tm c s ->
      tm c s ->
      fm c
  (* A relation (with arguments) *)
  | FRel:
      forall c args,
        sig.(sig_rels) args ->
        HList.t (tm c) args ->
        fm c
  (* Negation, disjunction, conjunction, and implication *)
  | FNeg: forall c, fm c -> fm c
  | FOr: forall c, fm c -> fm c -> fm c
  | FAnd: forall c, fm c -> fm c -> fm c
  | FImpl: forall c, fm c -> fm c -> fm c
  (* Quantification *)
  | FForall:
    forall c s,
      fm (CSnoc c s) ->
      fm c.
  Derive Signature for fm.

  (* A model defines how to *interpret* the sorts, function symbols, and the relation symbols. *)
  Record model :=
    { mod_sorts: sig.(sig_sorts) -> Type;
      mod_fns:
        forall args ret,
          sig.(sig_funs) args ret ->
          HList.t mod_sorts args ->
          mod_sorts ret;
      mod_rels:
        forall args,
          sig.(sig_rels) args ->
          HList.t mod_sorts args ->
          Prop
    }.

  Section Interp.
    Variable (m: model).

    (* Variable environments, indexed by a typing context *)

    Inductive valu : ctx -> Type :=
    | VEmp: valu CEmp
    | VSnoc:
      forall s c,
        valu c ->
        m.(mod_sorts) s ->
        valu (CSnoc c s).
    Derive Signature for valu.

    (* Variable evaluation. Because variables are type-indexed by their context, we can implement a total function. *)

    Equations find {c s} (x: var c s) (v: valu c) : m.(mod_sorts) s :=
      { find (VHere _ _) (VSnoc _ _ _ val) := val;
        find (VThere _ _ _ x') (VSnoc _ _ v' _) := find x' v' }.

    (* term evaluation *)

    Equations interp_tm (c: ctx) (s: sig_sorts sig) (v: valu c) (t: tm c s) : m.(mod_sorts) s
      by struct t :=
      { interp_tm _ _ v (TVar c s x) :=
          find x v;
        interp_tm _ _ v (TFun c typs rets fn args) :=
          m.(mod_fns) typs rets fn (interp_tms _ _ v args) }
    where interp_tms (c: ctx) typs (v: valu c) (args: HList.t (tm c) typs) : HList.t m.(mod_sorts) typs
      by struct args :=
      { interp_tms _ _ _ hnil := hnil;
        interp_tms _ _ _ (tm ::: args') :=
          interp_tm _ _ v tm ::: interp_tms _ _ v args' }.

    (* formula evaluation as a Prop *)

    Equations interp_fm (c: ctx) (v: valu c) (f: fm c) : Prop
      by struct f :=
      { interp_fm _ v (FTrue _) := True;
        interp_fm _ v (FFalse _) := False;
        interp_fm _ v (FRel c typs rel args) :=
          m.(mod_rels) typs rel (interp_tms c _ v args);
        interp_fm _ v (FEq c s t1 t2) :=
          interp_tm c s v t1 = interp_tm c s v t2;
        interp_fm _ v (FNeg _ f) :=
          ~ interp_fm _ v f;
        interp_fm _ v (FOr _ f1 f2) :=
          interp_fm _ v f1 \/ interp_fm _ v f2;
        interp_fm _ v (FAnd _ f1 f2) :=
          interp_fm _ v f1 /\ interp_fm _ v f2;
        interp_fm _ v (FImpl _ f1 f2) :=
          interp_fm _ v f1 -> interp_fm _ v f2;
        interp_fm _ v (FForall c s f) :=
          forall val: m.(mod_sorts) s,
            interp_fm (CSnoc c s) (VSnoc _ _ v val) f }.

    (* A few tactics for converting between normal Prop goals and interp_fm goals  *)
    Lemma eq_interp:
      forall c srt v l r,
        (interp_tm c srt v l = interp_tm c srt v r)
          <->
        interp_fm c v (FEq _ _ l r).
    Proof.
      intros.
      autorewrite with interp_fm.
      apply iff_refl.
    Qed.

    Lemma neg_interp:
      forall c v f,
        (~ interp_fm c v f)
          <->
        interp_fm c v (FNeg _ f).
    Proof.
      intros.
      autorewrite with interp_fm.
      apply iff_refl.
    Qed.

    Variable (mv_dec:
      forall (s: sig_sorts sig),
        forall (x y: m.(mod_sorts) s), {x = y} + {x <> y}
    ).

    Variable (rel_interp_dec:
      forall args hargs (r: sig_rels sig args),
        mod_rels m args r hargs \/ ~ mod_rels m args r hargs
    ).

    Variable (distinct_mv:
      forall s (x: m.(mod_sorts) s),
        (exists (y: m.(mod_sorts) s), x <> y) \/
        (forall (y: m.(mod_sorts) s), x = y)
    ).

    Lemma refute_dec:
      forall c v s f,
        (exists (x: m.(mod_sorts) s), ~ interp_fm (CSnoc c _) (VSnoc _ _ v x) f) \/
        forall (x: m.(mod_sorts) s), interp_fm _ (VSnoc _ _ v x) f.
    Proof.
      dependent induction f.
      - right;
        intros;
        autorewrite with interp_fm; trivial.
      - left;
        eexists;
        autorewrite with interp_fm;
        intuition.
      - admit.
      - admit.
    Admitted.

    Lemma interp_dec:
      forall c v f,
        interp_fm c v f \/ ~ interp_fm c v f.
    Proof.
      induction f;
      autorewrite with interp_fm in *;
      try (now intuition).
      - destruct (mv_dec _ (interp_tm c s v t) (interp_tm c s v t0)); [
            left | right
        ];
        intuition.
      - destruct (@IHf v).
        + right; intuition.
        + left; intuition.
      - destruct (@IHf1 v); [
            left; left; eauto
          |
        ].
        destruct (@IHf2 v).
        + left; right; eauto.
        + right; intuition.
      - destruct (@IHf1 v);
        destruct (@IHf2 v);
        try now (right; intuition).
        left; intuition.
      - destruct (@IHf1 v);
        destruct (@IHf2 v);
        try now (left; intuition);
        try now (right; intuition).
        right; intuition.
      - pose proof refute_dec.
        destruct (H c v s f).
        + right.
          destruct H0.
          intuition eauto.
        + left; intuition eauto.
    Qed.

    (* Require Import Coq.Logic.JMeq.
    Lemma forall_interp:
      forall c srt v (F : mod_sorts m srt -> fm (CSnoc c srt)) t',
        (forall t,
          F (interp_tm (CSnoc c _) srt (VSnoc _ _ t v) (TVar (CSnoc c _) _ (VHere c _ ))) = t' ->
          interp_fm _ v (FForall _ _ t')) <-> forall t, interp_fm _ (VSnoc _ _ t v) (F t).
    Admitted. *)
  End Interp.

  Fixpoint app_ctx (c1 c2: ctx): ctx :=
    match c2 with
    | SLNil _ => c1
    | Snoc _ c2' sort => CSnoc (app_ctx c1 c2') sort
    end.

  Fixpoint ccons s (c: ctx) :=
    match c with
    | SLNil _ => CSnoc CEmp s
    | Snoc _ c s0 => CSnoc (ccons s c) s0
    end.

  Fixpoint app_ctx' (c1 c2: ctx): ctx :=
    match c1 with
    | SLNil _ => c2
    | Snoc _ c1' sort => app_ctx' c1' (ccons sort c2)
    end.

  Equations app_valu
             {m: model}
             {c c': ctx}
             (v: valu m c)
             (v': valu m c')
    : valu m (app_ctx c c') :=
    { app_valu v (VEmp _) := v;
      app_valu v (VSnoc _ _ _ v' x) := VSnoc _ _ _ (app_valu v v') x }.

  Equations vcons {c s m} (x: mod_sorts m s) (v: valu m c) : valu m (ccons s c) :=
    { vcons x (VEmp _) := VSnoc _ _ _ (VEmp _) x;
      vcons x (VSnoc _ _ _ v y) := VSnoc _ _ _ (vcons x v) y }.

  Equations app_valu'
             {m: model}
             {c c': ctx}
             (v: valu m c)
             (v': valu m c')
    : valu m (app_ctx' c c') :=
    { app_valu' (VEmp _) v' := v';
      app_valu' (VSnoc _ _ _ v x) v' := app_valu' v (vcons x v') }.

  Lemma app_ctx_emp_l:
    forall c,
      c = app_ctx CEmp c.
  Proof.
    induction c.
    - reflexivity.
    - simpl.
      congruence.
  Defined.

  Lemma app_ctx_app_ctx':
    forall c1 c2,
      app_ctx c1 c2 = app_ctx' c1 c2.
  Proof.
    induction c1; induction c2; intros; simpl.
    - reflexivity.
    - rewrite <- app_ctx_emp_l.
      reflexivity.
    - rewrite <- IHc1.
      simpl.
      reflexivity.
    - rewrite IHc2.
      simpl.
      rewrite <- IHc1.
      cbn.
      rewrite <- IHc1.
      simpl.
      reflexivity.
  Defined.

  Lemma app_ctx'_app_ctx:
    forall c1 c2,
      app_ctx' c1 c2 = app_ctx c1 c2.
  Proof.
    intros.
    apply eq_sym.
    apply app_ctx_app_ctx'.
  Defined.

  Fixpoint quantify {c0: ctx} (c: ctx): fm (app_ctx c0 c) -> fm c0 :=
    match c as c' return fm (app_ctx c0 c') -> fm c0 with
    | SLNil _ => fun f => f
    | Snoc _ c' sort => fun f => quantify c' (FForall _ _ f)
    end.

  Lemma quantify_correct:
    forall m c c' (v': valu m c') phi,
     interp_fm m c' v' (quantify c phi) <->
     forall valu,
       interp_fm m (app_ctx c' c) (app_valu v' valu) phi.
  Proof.
    induction c.
    - cbn.
      intuition.
      + dependent destruction valu0.
        assumption.
      + specialize (H (VEmp _)).
        autorewrite with app_valu in *.
        assumption.
    - cbn.
      intuition.
      + cbn in *.
        dependent destruction valu0.
        rewrite IHc in H.
        specialize (H valu0).
        autorewrite with app_valu interp_fm in *.
        eauto.
      + rewrite IHc.
        intros v.
        autorewrite with interp_fm.
        intros.
        pose (VSnoc _ _ _ v val) as v''.
        specialize (H v'').
        eauto.
  Qed.

  Equations quantify_all {c: ctx} (f: fm c): fm CEmp := {
    @quantify_all (CSnoc c _) f := quantify_all (FForall _ _ f);
    @quantify_all CEmp f := f
  }.

  Lemma quantify_all_correct:
    forall m c phi,
     interp_fm m CEmp (VEmp _) (quantify_all phi) <->
     forall valu,
       interp_fm m c valu phi.
  Proof.
    dependent induction c; intros.
    - autorewrite with quantify_all.
      firstorder.
      now dependent destruction valu0.
    - autorewrite with quantify_all.
      rewrite IHc.
      split; intros.
      + dependent destruction valu0.
        specialize (H valu0).
        autorewrite with interp_fm in H.
        apply H.
      + autorewrite with interp_fm; intros.
        apply H.
  Qed.

  Fixpoint reindex_var {c c': ctx} {sort: sig.(sig_sorts)} (v: var c' sort) : var (app_ctx c c') sort :=
    match v in (var c' sort) return (var (app_ctx c c') sort) with
    | VHere ctx _ =>
      VHere (app_ctx c ctx) _
    | VThere ctx _ _ v' =>
      VThere (app_ctx c ctx) _ _ (reindex_var v')
    end.

  Equations reindex_tm {c c': ctx} {sort: sig.(sig_sorts)} (t: tm c' sort) : tm (app_ctx c c') sort := {
    reindex_tm (TVar _ _ v) := TVar _ _ (reindex_var v);
    reindex_tm (TFun _ _ _ f args') := TFun _ _ _ f (reindex_tms args')
  } where reindex_tms {c c':ctx} {sorts: list sig.(sig_sorts)} (ts: HList.t (tm c') sorts) : HList.t (tm (app_ctx c c')) sorts := {
    reindex_tms hnil := hnil;
    reindex_tms (t ::: ts) := reindex_tm t ::: reindex_tms ts
  }.

  Equations weaken_var {sort: sig.(sig_sorts)}
             {c1: ctx} (c2: ctx) (v: var c1 sort)
    : var (app_ctx c1 c2) sort :=
    { weaken_var CEmp v := v;
      weaken_var (CSnoc c2' sort') v := VThere _ _ _ (weaken_var c2' v) }.

  Equations weaken_tm (sort: sig.(sig_sorts))
             (c1: ctx) (c2: ctx) (t: tm c1 sort)
    : tm (app_ctx c1 c2) sort
    by struct t :=
    { weaken_tm _ _ c2 (TVar _ _ v) := TVar _ _ (weaken_var c2 v);
      weaken_tm _ _ c2 (TFun _ _ _ f args') :=
        TFun _ _ _ f (weaken_tms _ _ c2 args') }
  where weaken_tms (sorts: list sig.(sig_sorts))
       (c1: ctx) (c2: ctx) (ts: HList.t (tm c1) sorts)
        : HList.t (tm (app_ctx c1 c2)) sorts
    by struct ts :=
    { weaken_tms _ _ _ hnil := hnil;
      weaken_tms _ _ _ (t ::: ts) :=
        weaken_tm _ _ c2 t ::: weaken_tms _ _ c2 ts }.

  Lemma find_app_left:
    forall m c1 c2 (val1: valu m c1) (val2: valu m c2) t (v: var c1 t),
      find m (weaken_var c2 v) (app_valu val1 val2) =
      find m v val1.
  Proof.
    intros; dependent induction c2;
    autorewrite with weaken_var.
    - dependent destruction val2.
      now autorewrite with app_valu.
    - dependent destruction val2.
      autorewrite with app_valu; simpl.
      rewrite find_equation_2.
      apply IHc2.
  Qed.

  Lemma find_app_right:
    forall m c1 c2 (val1: valu m c1) (val2: valu m c2) t (v: var c2 t),
      find m (reindex_var v) (app_valu val1 val2) =
      find m v val2.
  Proof.
    intros; dependent induction c2.
    - dependent destruction v.
    - dependent destruction val2.
      autorewrite with app_valu.
      dependent destruction v; simpl;
      autorewrite with find; auto.
  Qed.

  Lemma interp_tm_reindex_tm:
    forall m c s (t: tm c s) (v: valu m c) c' (v': valu m c'),
      interp_tm m c s v t =
      interp_tm m (app_ctx c' c) s (app_valu v' v) (reindex_tm t).
  Proof.
    dependent induction t using tm_ind'; intros.
    - autorewrite with reindex_tm.
      autorewrite with interp_tm.
      now rewrite find_app_right.
    - autorewrite with reindex_tm.
      autorewrite with interp_tm.
      f_equal.
      clear srt.
      induction hl; auto.
      autorewrite with reindex_tm.
      autorewrite with interp_tm.
      f_equal.
      + apply H.
      + apply IHhl, H.
  Qed.

  Lemma interp_tm_weaken_tm:
    forall m c s (t: tm c s) (v: valu m c) c' (v': valu m c'),
      interp_tm m c s v t =
      interp_tm m (app_ctx c c') s (app_valu v v') (weaken_tm s c c' t).
  Proof.
    dependent induction t using tm_ind'; intros.
    - autorewrite with weaken_tm.
      autorewrite with interp_tm.
      now rewrite find_app_left.
    - autorewrite with weaken_tm.
      autorewrite with interp_tm.
      f_equal.
      clear srt.
      induction hl; auto.
      autorewrite with weaken_tm.
      autorewrite with interp_tm.
      f_equal.
      + apply H.
      + apply IHhl, H.
  Qed.

  Equations tm_cons {c s' s}
    (t: tm c s)
    : tm (CSnoc c s') s := {
    tm_cons (TVar _ _ v) := TVar _ _ (VThere _ _ _ v);
    tm_cons (TFun _ _ _ fn args') := TFun _ _ _ fn (tms_cons args')
  } where tms_cons {c s' s}
    (ts: HList.t (tm c) s)
    : HList.t (tm (CSnoc c s')) s := {
    tms_cons hnil := hnil;
    tms_cons (t ::: ts) := tm_cons t ::: tms_cons ts
  }.

  Lemma interp_tm_tm_cons:
    forall m c s (t: tm c s) (v: valu m c) s' val,
      interp_tm m c s v t =
      interp_tm m (CSnoc c s') s (VSnoc m s' c v val) (tm_cons t).
  Proof.
    dependent induction t using tm_ind'; intros.
    - autorewrite with tm_cons.
      autorewrite with interp_tm.
      reflexivity.
    - autorewrite with tm_cons.
      autorewrite with interp_tm.
      f_equal.
      clear srt.
      induction hl; auto.
      autorewrite with tm_cons.
      autorewrite with interp_tm.
      f_equal.
      + apply H.
      + apply IHhl, H.
  Qed.

  Inductive QFFm : forall c, (fm c) -> Prop :=
  | QFTrue : forall c, QFFm c (FTrue _)
  | QFFalse : forall c, QFFm c (FFalse _)
  | QFRel : forall c typs rel args, QFFm c (FRel c typs rel args)
  | QFEq : forall c s l r,  QFFm c (FEq _ s l r)
  | QFNeg : forall c i, QFFm c i -> QFFm _ (FNeg _ i)
  | QFOr : forall c l r, QFFm c l -> QFFm _ r -> QFFm _ (FOr _ l r)
  | QFFand : forall c l r, QFFm c l -> QFFm _ r -> QFFm _ (FAnd _ l r)
  | QFImpl : forall c l r, QFFm c l -> QFFm _ r -> QFFm _ (FImpl _ l r).

End FOL.

(* A helper for conditionals, to expose a metacoq term for if-then-else *)

Definition ite {A} (t: bool) (l: A) (r: A) := if t then l else r.

Arguments TVar {_ _ _}.
Arguments TFun _ {_ _ _} _ _.
Arguments FTrue {sig c}.
Arguments FFalse {sig c}.
Arguments FEq {_ _ _} _ _.
Arguments FRel {_ _} _ _.
Arguments FNeg {_} _.
Arguments FOr {_} _ _.
Arguments FAnd {_} _ _.
Arguments FForall {_ _} _.
Arguments FImpl {_ _} _ _.

Arguments interp_fm {_ _ _} _ _.
Arguments interp_tm {_ _ _ _} _ _.
Arguments interp_tms {_ _ _ _} _ _.

Arguments app_ctx {sig} c1 c2.
Arguments quantify {sig c0} c f.
Arguments quantify_all {sig} c f.
Arguments reindex_var {sig c c' sort} v.
Arguments reindex_tm {sig c c' sort} t.
Arguments reindex_tms {sig c c' sorts} ts.
Arguments weaken_var {sig sort c1} c2 v.
Arguments weaken_tm {sig sort c1} c2 t.

Register TVar as ms.core.var.
Register TFun as ms.core.fun.

Register VHere as ms.core.vhere.
Register VThere as ms.core.vthere.

Register interp_fm as ms.core.interp_fm.

Register FEq as ms.core.eq.
Register FTrue as ms.core.tt.
Register FFalse as ms.core.ff.
Register FRel as ms.core.rel.
Register FNeg as ms.core.neg.
Register FOr as ms.core.or.
Register FAnd as ms.core.and.
Register FForall as ms.core.forall.

Register FImpl as ms.core.impl.

Register SLNil as ms.core.cnil.
Register Snoc as ms.core.csnoc.

Register HList.HNil as ms.core.hnil.
Register HList.HCons as ms.core.hcons.

Require Import Coq.Lists.List.

(* a functor view of FOL, mapping between different sets of sorts and function/relation symbols *)

Section FMap.
  Variable (sigA sigB: signature).
  Variable (mA: model sigA).
  Variable (mB: model sigB).

  Fixpoint fmap_arity {sigA sigB: signature} (fmap_srt : sigA.(sig_sorts) -> sigB.(sig_sorts)) (arr: arity sigA.(sig_sorts)) : arity sigB.(sig_sorts) :=
    match arr with
    | nil => nil
    | s :: arrs => fmap_srt s :: fmap_arity fmap_srt arrs
    end.
  Record theory_functor {sigA sigB: signature} {mA: model sigA} {mB: model sigB} := {
   fmap_sorts : sigA.(sig_sorts) -> sigB.(sig_sorts);
   fmap_funs : forall arr srt, sigA.(sig_funs) arr srt  -> sigB.(sig_funs) (fmap_arity fmap_sorts arr) (fmap_sorts srt);
   fmap_rels : forall arr, sigA.(sig_rels) arr -> sigB.(sig_rels) (fmap_arity fmap_sorts arr);
   fmap_mv : forall srt, mod_sorts sigA mA srt -> mod_sorts sigB mB (fmap_sorts srt);
  }.

  Variable (a2b: @theory_functor sigA sigB mA mB).

  Fixpoint fmap_ctx (c: ctx sigA) : ctx sigB :=
    match c with
    | SLNil _ => SLNil _
    | Snoc _ i x => Snoc _ (fmap_ctx i) (a2b.(fmap_sorts) x)
    end.

  Equations fmap_var {c srt} (v: var sigA c srt) : var sigB (fmap_ctx c) (a2b.(fmap_sorts) srt) :=
  {
    fmap_var (VHere _ c s) := VHere _ _ _;
    fmap_var (VThere _ _ _ _ i) := VThere _ _ _ _ (fmap_var i)
  }.

  Equations fmap_valu {c} (v: valu sigA mA c) : valu sigB mB (fmap_ctx c) :=
    fmap_valu VEmp := VEmp _ _;
    fmap_valu (VSnoc _ _ i x) := VSnoc _ _ _ _ (fmap_valu i) (a2b.(fmap_mv) _ x).

  Variable (fmap_fun_arrs: forall c arr srt,
    sig_funs sigA arr srt ->
    HList.t (fun srt' : sig_sorts sigA => tm sigB (fmap_ctx c) (a2b.(fmap_sorts) srt')) arr ->
    HList.t (tm sigB (fmap_ctx c)) (fmap_arity (a2b.(fmap_sorts)) arr)
  ).

  Equations fmap_tm {c srt} (t: tm sigA c srt) : tm sigB (fmap_ctx c) (a2b.(fmap_sorts) srt) :=
  {
    fmap_tm (TVar v) := TVar (fmap_var v);
    fmap_tm (@TFun _ c arr srt f args) :=
      TFun _ (a2b.(fmap_funs) _ _ f) (fmap_fun_arrs _ _ _ f (fmap_tm_args args))
  }
  where fmap_tm_args {c arr} (args: HList.t (tm sigA c) arr)
    : HList.t (fun srt' : sig_sorts sigA => tm sigB (fmap_ctx c) (a2b.(fmap_sorts) srt')) arr :=
  {
    fmap_tm_args hnil := hnil;
    fmap_tm_args (h ::: t) := (fmap_tm h) ::: (fmap_tm_args t)
  }.

  Variable (fmap_rel_arrs: forall c arr,
    sig_rels sigA arr ->
    HList.t (fun srt' : sig_sorts sigA => tm sigB (fmap_ctx c) (a2b.(fmap_sorts) srt')) arr ->
    HList.t (tm sigB (fmap_ctx c)) (fmap_arity a2b.(fmap_sorts) arr)
  ).

  Variable (fmap_fm_fforall_op :
    forall c s,
      fm sigB (fmap_ctx (Snoc _ c s)) ->
      fm sigB (fmap_ctx (Snoc _ c s))
  ).

  Equations fmap_fm {c} (f: fm sigA c) : fm sigB (fmap_ctx c) :=
  {
    fmap_fm FTrue := FTrue;
    fmap_fm FFalse := FFalse;
    fmap_fm (FEq l r) := FEq (fmap_tm l) (fmap_tm r);
    fmap_fm (FRel r args') := FRel _ (a2b.(fmap_rels) _ r) (fmap_rel_arrs _ _ r (fmap_tm_args args'));
    fmap_fm (FNeg x) := FNeg _ (fmap_fm x);
    fmap_fm (FOr l r) := FOr _ (fmap_fm l) (fmap_fm r);
    fmap_fm (FAnd l r) := FAnd _ (fmap_fm l) (fmap_fm r);
    fmap_fm (FImpl l r) := FImpl (fmap_fm l) (fmap_fm r);
    fmap_fm (FForall s i) :=
      FForall _ (fmap_fm_fforall_op _ s (fmap_fm i))
  }.

  Record functor_wf := {
    interp_tm_inj:
    forall srt c (v: valu _ mA c) t t',
      interp_tm v t = interp_tm v t' <->
      interp_tm (fmap_valu v) (fmap_tm t) = interp_tm (fmap_valu v) (fmap_tm (c:=c) (srt:=srt) t');
    fmap_rel_equi:
      forall c v args r r_args,
        mod_rels sigA mA args r (interp_tms v r_args) <->
        mod_rels sigB mB (fmap_arity a2b.(fmap_sorts) args) (a2b.(fmap_rels) args r) (interp_tms (fmap_valu v) (fmap_rel_arrs c args r (fmap_tm_args r_args)));
    interp_fmap_forall_equi:
      forall srt c v (f : fm sigA (Snoc _ c srt)),
        (forall vA,
          interp_fm (VSnoc sigB mB (a2b.(fmap_sorts) srt) (fmap_ctx c) (fmap_valu v) (a2b.(fmap_mv) srt vA)) (fmap_fm f)) <->
        (forall vB,
          interp_fm (VSnoc sigB mB (a2b.(fmap_sorts) srt) (fmap_ctx c) (fmap_valu v) vB) (fmap_fm_fforall_op _ srt (fmap_fm f)))
  }.

  Theorem fmap_corr (wf: functor_wf):
    forall (c: ctx sigA) v f,
      interp_fm v f <-> interp_fm (fmap_valu v) (fmap_fm (c:= c) f).
  Proof.
    inversion wf.
    intros.
    dependent induction f;
    autorewrite with fmap_fm;
    autorewrite with interp_fm;
    try erewrite IHf;
    try erewrite IHf1;
    try erewrite IHf2;
    try eapply iff_refl.
    - eapply interp_tm_inj0.
    - eapply fmap_rel_equi0.
    - fold fmap_ctx.
      setoid_rewrite IHf.
      setoid_rewrite fmap_valu_equation_2.
      eapply interp_fmap_forall_equi0.
  Qed.
End FMap.


Load DFA_Def.

Section RegExp.

(** Der Typ eines regulaeren Ausdrucks induktiv definiert. *)

Inductive Reg_Exp {A: Type} :=
  | Void : @Reg_Exp A
  | Eps : @Reg_Exp A
  | Single : A -> @Reg_Exp A
  | Star : @Reg_Exp A -> @Reg_Exp A
  | Plus : @Reg_Exp A ->  @Reg_Exp A -> @Reg_Exp A
  | Conc : @Reg_Exp A -> @Reg_Exp A -> @Reg_Exp A
  | Not : @Reg_Exp A -> @Reg_Exp A.

(** Anhaengen eines Zeichens an das zweite Teilwort eines aus zwei Teilwoertern bestehenden Wortes. *)

Fixpoint appsec {A : Type} (ps : @Word (@Word A * @Word A)) (x : A) :
      @Word (@Word A * @Word A) :=
  match ps with
    | eps                       => eps
    | snoc ps' (w1, w2) => snoc (appsec ps' x) (w1, snoc w2 x)
  end.

(*Eval compute in (appsec (snoc eps (eps, eps)) 2).*)

(** Aufsplitten eines Wortes in zwei Teilwoerter. Das erste Teilwort wird dabei immer laenger und das
 zweite Teilwort dementsprechend kuerzer. *)

Fixpoint splits {A : Type} (w : @Word A) : @Word (@Word A * @Word A):=
  match w with
    | eps         => snoc eps (eps, eps)
    | snoc w x => snoc (appsec (splits w) x) (snoc w x, eps)
  end.

(*Eval compute in (splits (snoc (snoc (snoc eps 2) 3)4)).*)

(** Formalisierung des Existenzquantors auf Woertern analog zu [existsb], das auf Listen arbeitet. *)

Fixpoint existsbw {A : Type} (p : A -> bool) (w : @Word A) : bool :=
  match w with
    | eps          => false
    | snoc w' x => p x || existsbw p w'
  end.

(** Formalisierung des Allquantors auf Woertern analog zu [forallb], das auf Listen arbeitet. *)

Fixpoint forallbw {A : Type} (p : A -> bool) (w : @Word A) : bool :=
  match w with
    | eps          => true
    | snoc w' x => p x && forallbw p w'
  end.

(** "Kreuzprodukt" zweier Praedikate. *)

Fixpoint pair_andb {A B : Type} (p : A -> bool) (q : B -> bool) (c : A * B) : bool :=
  match c with
    | (a,b) => p a && q b
  end.

(** Ein einzelnes Zeichen an ein Wort anhaengen. *)

Definition concat_word_single {A : Type} (x : A) (w : Word2) : Word2 :=
           snoc w (snoc eps x).

(*Eval compute in (concat_word_single 2 (snoc eps (snoc eps 3))).*)

(** Ein Wort ueber Woertern in ein Wort umwandeln (Monadenmultiplikation von Word). *)

Fixpoint flatten_word {A : Type} (w : Word2) : @Word A :=
  match w with
    | eps              => eps
    | snoc w1 w2 => concat_word (flatten_word w1) w2
  end.

(** bind-Operation der Monade Word. *)

Definition concat_map_word {A B : Type} (f : A -> @Word B) (w : @Word A) : @Word B :=
           flatten_word(map_word f w).

(** Hilfsfunktion fuer [split2]. *)

Fixpoint last_snoc {A : Type} (x : A) (w : Word2) : Word3 :=
  match w with
    | eps               => eps
    | snoc w1 w2  => snoc eps (snoc w1 (snoc w2 x))
  end.

(** Generierung aller Zerlegungen eines Wortes in alle nichtleeren Teilwoerter. *)

Fixpoint split2 {A : Type} (w : @Word A) : Word3 :=
  match w with
    | eps          => snoc eps eps
    | snoc w' x => concat_word (map_word (concat_word_single x) (split2 w'))
                                                (concat_map_word (last_snoc x) (split2 w'))
  end.

(*
Eval compute in (split2 (snoc (snoc (snoc eps 1)2)3)).
Eval compute in (split2 (snoc (snoc (snoc (snoc (snoc eps 1)2)3)4)5)).
*)

(** Die Sprache, die von einem regulaeren Ausdruck beschrieben wird. *)

Fixpoint Lang_Reg {A : Type} (e : @Reg_Exp A) (eq: A -> A -> bool) (w : @Word A)  : bool :=
  match e, w with
    | Void  ,_                     => false
    | Eps ,eps                   => true
    | Eps ,_                       => false
    | Single x, snoc eps y => eq x y
    | Single _, _                => false
    | Conc e1 e2, w          => existsbw (pair_andb (Lang_Reg e1 eq) (Lang_Reg e2 eq))(splits w)
    | Star e1, w'                => existsbw (forallbw (Lang_Reg e1 eq)) (split2 w')
    | Plus e1 e2, w'          => (Lang_Reg e1 eq w') || (Lang_Reg e2 eq w')
    | Not e1, w'                 => negb (Lang_Reg e1 eq w')
  end.

End RegExp.

(** Ein Beispiel eines regulaeren Ausdrucks und die beschriebene Sprache. *)

Definition testreg : @Reg_Exp nat := Star( Conc (Single 1)(Single 2) ).
(*
Eval compute in (Lang_Reg testreg Nat.eqb eps).
Eval compute in (Lang_Reg testreg Nat.eqb (snoc eps 1)).
Eval compute in (Lang_Reg testreg Nat.eqb (snoc (snoc eps 1)2)).
Eval compute in (Lang_Reg testreg Nat.eqb (snoc (snoc (snoc eps 1)1)2)).
Eval compute in (Lang_Reg testreg Nat.eqb (snoc (snoc (snoc(snoc eps 1)2)1)2)).
Eval compute in (snoc (snoc (snoc(snoc eps 1)2)1)2).
*)


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_Seventeen.

Coq < Goal forall k n p r g b:Prop, (((~k /\ ~n) -> ((~p -> k) /\ (~r -> g))) /\ (k -> n) /\ (~n /\ b) /\ (~p \/ ~r)) -> (g).
1 subgoal

  ============================
   forall k n p r g b : Prop,
   (~ k /\ ~ n -> (~ p -> k) /\ (~ r -> g)) /\
   (k -> n) /\ (~ n /\ b) /\ (~ p \/ ~ r) -> g

Unnamed_thm < intros.
1 subgoal

  k : Prop
  n : Prop
  p : Prop
  r : Prop
  g : Prop
  b : Prop
  H : (~ k /\ ~ n -> (~ p -> k) /\ (~ r -> g)) /\
      (k -> n) /\ (~ n /\ b) /\ (~ p \/ ~ r)
  ============================
   g

Unnamed_thm < elim H.
1 subgoal

  k : Prop
  n : Prop
  p : Prop
  r : Prop
  g : Prop
  b : Prop
  H : (~ k /\ ~ n -> (~ p -> k) /\ (~ r -> g)) /\
      (k -> n) /\ (~ n /\ b) /\ (~ p \/ ~ r)
  ============================
   (~ k /\ ~ n -> (~ p -> k) /\ (~ r -> g)) ->
   (k -> n) /\ (~ n /\ b) /\ (~ p \/ ~ r) -> g

Unnamed_thm < intro.
1 subgoal

  k : Prop
  n : Prop
  p : Prop
  r : Prop
  g : Prop
  b : Prop
  H : (~ k /\ ~ n -> (~ p -> k) /\ (~ r -> g)) /\
      (k -> n) /\ (~ n /\ b) /\ (~ p \/ ~ r)
  H0 : ~ k /\ ~ n -> (~ p -> k) /\ (~ r -> g)
  ============================
   (k -> n) /\ (~ n /\ b) /\ (~ p \/ ~ r) -> g

Unnamed_thm < intro.
1 subgoal

  k : Prop
  n : Prop
  p : Prop
  r : Prop
  g : Prop
  b : Prop
  H : (~ k /\ ~ n -> (~ p -> k) /\ (~ r -> g)) /\
      (k -> n) /\ (~ n /\ b) /\ (~ p \/ ~ r)
  H0 : ~ k /\ ~ n -> (~ p -> k) /\ (~ r -> g)
  H1 : (k -> n) /\ (~ n /\ b) /\ (~ p \/ ~ r)
  ============================
   g

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <

*)

Section Exercise_Seventeen.
Goal forall k n p r g b:Prop, (((~k /\ ~n) -> ((~p -> k) /\ (~r -> g))) /\ (k -> n) /\ (~n /\ b) /\ (~p \/ ~r)) -> (g).
intros.
elim H.
intro.
intro.
firstorder.
Qed.


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq order.
From mathcomp Require Import choice fintype finfun ssrfun bigop ssralg.
(*Require Import orderedalg.*)

Require Import Zbool.
(*Require Import QArith.*)
Require Import Qcanon.
Require Import ZArith.

Close Scope Q_scope.

Set   Implicit Arguments.
Unset Strict Implicit.

Import Prenex Implicits.

Import GRing.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
(* Various eqtype, subtype, choice, count canonical structures          *)
(*               from the standard library                              *)
(* -------------------------------------------------------------------- *)

(* Structures on positive *)

Definition eqp (p q : positive) : bool :=
  match ((p ?= q))%positive with Eq => true | _ => false end.

Lemma eqpP : Equality.axiom eqp.
Proof.
  move=> p q; apply: (iffP  idP)=>[|<-]; last by rewrite /eqp Pos.compare_refl.
  rewrite /eqp; case e: ((p ?= q))%positive=> // _; exact: Pcompare_Eq_eq.
Qed.

Canonical Structure eqp_Mixin := EqMixin eqpP.
Canonical Structure eqp_eqType := Eval hnf in EqType positive eqp_Mixin.

Definition p_unpickle n := Some (Pos.pred (P_of_succ_nat n)).

Lemma p_pick_cancel : pcancel nat_of_P p_unpickle.
Proof.
  move=> x; rewrite /p_unpickle; congr Some.
  by rewrite pred_o_P_of_succ_nat_o_nat_of_P_eq_id.
Qed.

Definition p_countMixin  := CountMixin p_pick_cancel.
Definition p_choiceMixin := CountChoiceMixin p_countMixin.

Canonical Structure p_choiceType :=
  Eval hnf in ChoiceType positive p_choiceMixin.
Canonical Structure p_countType :=
  Eval hnf in CountType positive p_countMixin.

(* Structures on Z *)

Lemma eqzP : Equality.axiom Zeq_bool.
Proof. by move=> z1 z2;  apply: (iffP idP); move/Zeq_is_eq_bool. Qed.

Canonical Structure Z_Mixin := EqMixin eqzP.
Canonical Structure Z_eqType := Eval hnf in EqType Z Z_Mixin.

Definition z_code (z : Z) :=
  match z with
    |0%Z => (0%nat, true)
    |Zpos p => (pickle p, true)
    |Zneg p => (pickle p, false)
  end.

Definition z_pickle z := pickle (z_code z).

Definition z_decode c :=
  match c with
    |(0%nat, true) => Some 0%Z
    |(0%nat, false) => None
    |(n, true) =>
      if (unpickle n) is Some p then Some (Zpos p) else None
    |(n, false) =>
      if (unpickle n) is Some p then Some (Zneg p) else None
  end.

Definition z_unpickle n :=
  match (unpickle n) with
    |None => None
    |Some u => z_decode u
  end.

Lemma z_codeK : pcancel z_code z_decode.
Proof.
  rewrite /z_code /z_decode.
  case=> // n; case e : (pickle n)=>[|m]; rewrite -?e ?pickleK //;
    by move/ltP: (lt_O_nat_of_P n); rewrite -e -[pickle]/nat_of_P ltnn.
Qed.

Lemma z_pick_cancel : pcancel z_pickle z_unpickle.
Proof.
  by move=> x; rewrite /z_pickle /z_unpickle pickleK z_codeK.
Qed.

Definition z_countMixin  := CountMixin z_pick_cancel.
Definition z_choiceMixin := CountChoiceMixin z_countMixin.

Canonical Structure z_choiceType :=
  Eval hnf in ChoiceType Z z_choiceMixin.
Canonical Structure z_countType :=
  Eval hnf in CountType Z z_countMixin.

Lemma ZplusA : associative Zplus.
Proof. by exact Zplus_assoc. Qed.

Lemma ZplusC : commutative Zplus.
Proof. by exact Zplus_comm. Qed.

Lemma Zplus0 : left_id (0%Z) Zplus.
Proof. by exact Zplus_0_l. Qed.

Lemma ZplusNr : left_inverse  0%Z Z.opp Zplus.
Proof. exact Zplus_opp_l. Qed.

Lemma ZplusrN : right_inverse 0%Z Z.opp Zplus.
Proof. exact Zplus_opp_r. Qed.

Definition Z_zmodMixin :=
  ZmodMixin ZplusA ZplusC Zplus0 ZplusNr.

Canonical Structure Z_zmodType :=
  Eval hnf in ZmodType Z Z_zmodMixin.

(* Z Ring *)
Lemma ZmultA : associative Zmult.
Proof. exact: Zmult_assoc. Qed.

Lemma Zmult1q : left_id 1%Z Zmult.
Proof. exact: Zmult_1_l. Qed.

Lemma Zmultq1 : right_id 1%Z Zmult.
Proof. exact: Zmult_1_r. Qed.

Lemma Zmultq0 : forall (q : Z), Zmult q 0%Z = 0%Z.
Proof. exact: Zmult_0_r. Qed.

Lemma Zmult_addl : left_distributive Zmult Zplus.
Proof. exact: Zmult_plus_distr_l. Qed.

Lemma Zmult_addr : right_distributive Zmult Zplus.
Proof. exact: Zmult_plus_distr_r. Qed.

Lemma nonzeroZ1 : 1%Z != 0%Z.
Proof. by []. Qed.

Definition Z_ringMixin :=
  RingMixin ZmultA Zmult1q Zmultq1 Zmult_addl Zmult_addr nonzeroZ1.

Canonical Structure Z_ringType :=
  Eval hnf in RingType Z Z_ringMixin.

Lemma ZmultC : commutative Zmult.
Proof. exact: Zmult_comm. Qed.

Canonical Structure Z_comRingType := ComRingType Z ZmultC.

(* Warning : an antisymmetric an a transitive predicates are
present in loaded Relations.Relation_Definition *)
Lemma Zle_bool_antisymb : ssrbool.antisymmetric  Zle_bool.
Proof. by move=> x y; case/andP=> h1 h2; apply: Zle_bool_antisym. Qed.

Lemma Zle_bool_transb : ssrbool.transitive Zle_bool.
Proof. move=> x y z; exact: Zle_bool_trans. Qed.

Lemma Zle_bool_totalb : total Zle_bool.
Proof. by move=> x y; case: (Zle_bool_total x y)=> -> //; rewrite orbT. Qed.

Lemma Zle_bool_addr : forall z x y, Zle_bool x y -> Zle_bool (x + z) (y + z).
Proof. by move=> x y z h; rewrite Zle_bool_plus_mono // Zle_bool_refl. Qed.

Lemma Zle_bool_mulr : forall x y,
  Zle_bool 0 x -> Zle_bool 0 y -> Zle_bool 0 (x * y).
Proof.
move=> x y; move/Zle_is_le_bool=> px; move/Zle_is_le_bool=> py.
by apply/Zle_is_le_bool; apply: Zmult_le_0_compat.
Qed.

Definition Zunit := pred2 1%Z (-1)%Z.

Definition Zinv (z : Z) := z.

Lemma ZmulV : {in Zunit, left_inverse 1%R Zinv *%R}.
Proof. by move=> x; rewrite inE; case/pred2P => ->. Qed.

(* Zmult_1_inversion_r does not exist *)
Lemma unitZPl : forall x y, y * x = 1 -> Zunit x.
Proof.
move=> x y; rewrite mulrC.
rewrite -[x * y]/(Zmult x y); move/Zmult_1_inversion_l.
by case=> ->.
Qed.

Lemma  Zinv_out : {in predC Zunit, Zinv =1 id}.
Proof. exact. Qed.

Definition Z_comUnitRingMixin :=  ComUnitRingMixin ZmulV unitZPl Zinv_out.

Canonical Structure Z_unitRingType :=
  Eval hnf in UnitRingType Z Z_comUnitRingMixin.

Canonical Structure Z_comUnitRing := Eval hnf in [comUnitRingType of Z].

Lemma Z_idomain_axiom : forall x y : Z,
  x * y = 0 -> (x == 0) || (y == 0).
Proof.
move=> x y; rewrite -[x * y]/(Zmult x y); move/Zmult_integral; case=> -> //=.
by rewrite eqxx orbT.
Qed.

Canonical Structure Z_iDomain := Eval hnf in IdomainType Z Z_idomain_axiom.

Lemma Zlt_def (x y : Z) : (x <? y)%Z = (y != x) && (x <=? y)%Z.
Proof.
(* TODO *)
Admitted.

Lemma Zle_total : forall m n : Z, (m <=? n)%Z || (n <=? m)%Z.
Proof.
(* TODO *)
Admitted.

(*Definition Z_OrderedRingMixin :=
  OrderedRing.Mixin
  Zle_bool_antisymb Zle_bool_transb Zle_bool_totalb Zle_bool_addr Zle_bool_mulr.*)
Lemma Z_display : Datatypes.unit. Proof. exact: tt. Qed.
(*Definition Z_OrderedRingMixin :=
  @LePOrderMixin Z_eqType Z.leb Z.ltb Zlt_def Zle_bool_refl Zle_bool_antisymb Zle_bool_transb.
Canonical Z_porderType := POrderType Z_display Z Z_OrderedRingMixin.*)

Definition Z_OrderedRingMixin2 :=
  LeOrderMixin Zlt_def (fun _ _ => erefl) (fun _ _ => erefl) Zle_bool_antisymb Zle_bool_transb Zle_total.

Canonical z_porderType := POrderType Z_display Z Z_OrderedRingMixin2.
Canonical z_latticeType := LatticeType Z Z_OrderedRingMixin2.
Canonical z_distrLatticeType := DistrLatticeType Z Z_OrderedRingMixin2.
Canonical z_orderType := OrderType Z Z_OrderedRingMixin2.

(*Canonical Structure Z_OrderedRingType :=
  Eval hnf in OIdomainType Z Z_OrderedRingMixin.

Canonical Structure Z_oIdomainType :=
  Eval hnf in OIdomainType Z Z_OrderedRingMixin.*)

(* Basic tructures for rational numbers.*)

(* TODO

Definition eqq (x y : Q) : bool :=
  match x, y with
    | (xn # xd)%Q, (yn # yd)%Q => (xn == yn) && (xd == yd)
  end.

Lemma eqq_refl : forall q, eqq q q.
Proof. by move=> [d n]; rewrite /eqq; rewrite 2!eqxx. Qed.

Lemma eqqP : Equality.axiom eqq.
Proof.
  move=> q1 q2; apply: (iffP idP) => [|<-]; last exact: eqq_refl.
  by case: q1=> n1 d1; case: q2=> n2 d2; case/andP; move/eqP->; move/eqP->.
Qed.

Canonical Structure eqq_eqMixin := EqMixin eqqP.
Canonical Structure eqq_eqType := Eval hnf in EqType Q eqq_eqMixin.

Definition q_code (q : Q) :=
  match q with
    |(qnum # qden)%Q => (qnum, qden)
  end.

Definition q_pickle q := pickle (q_code q).

Definition q_decode c :=
  match c with
    |(q, d) => Some (q # d)%Q
  end.

Definition q_unpickle n :=
  match (unpickle n) with
    |None => None
    |Some u => q_decode u
  end.

Lemma q_codeK : pcancel q_code q_decode.
Proof. by move=> []. Qed.

Lemma q_pick_cancel : pcancel q_pickle q_unpickle.
Proof.
by move=> x; rewrite /q_pickle /q_unpickle pickleK q_codeK.
Qed.

Definition q_countMixin  := CountMixin q_pick_cancel.
Definition q_choiceMixin := CountChoiceMixin q_countMixin.

Canonical Structure q_choiceType :=
  Eval hnf in ChoiceType  Q q_choiceMixin.
Canonical Structure q_countType :=
  Eval hnf in CountType Q q_countMixin.

(*
Definition nnegqb (q : Q) :=
  match q with
    (qd # qn)%Q => match qd with Zneg _ => false | _ => true end
  end.
*)

(* Basic and algebraic structures for normalized rational numbers,
we do not intend to be specially clever wrt normalization at this point *)

Record Qcb : Type := QcbMake { qcb_val :> Q; _ : Qred qcb_val == qcb_val }.

Canonical Structure qcb_subType :=
  Eval hnf in [subType for qcb_val by Qcb_rect].

Definition qcb_eqMixin := Eval hnf in [eqMixin of qcb_subType by <:].
Canonical Structure qcb_eqType  := Eval hnf in EqType Qcb qcb_eqMixin.

Definition qcb_choiceMixin := [choiceMixin of Qcb by <:].
Canonical Structure qcb_choiceType :=
  Eval hnf in ChoiceType Qcb  qcb_choiceMixin.

Definition qcb_countMixin := [countMixin of Qcb by <:].
Canonical Structure qcb_countType :=
  Eval hnf in CountType Qcb qcb_countMixin.

Canonical Structure qcb_subCountType :=
  Eval hnf in [subCountType of Qcb].

(* Properties about Qred, Q and Qcb and equalities over all these types *)
Lemma Qredb_involutive : forall q, Qred (Qred q) == (Qred q).
Proof. by move=> q; apply/eqP; apply Qred_involutive. Qed.

(*
Lemma Qcb_is_canon : forall (q q' : Qcb), (q == q')%Q -> q = q'.
Proof.
move=> [x hx] [y hy]; move/Qred_complete=> /=; rewrite (eqP hx) (eqP hy)=> e.
by apply:val_inj.
Qed.
*)

Lemma Qredb_complete : forall q q', (q == q')%Q -> Qred q == Qred q'.
Proof. by move=> q q' H; apply/eqP; apply Qred_complete. Qed.

Lemma Qcb_QeqP : forall (q q': Qcb), reflect (q == q')%Q (q == q').
Proof.
move=> [q Hq] [q' Hq']; apply: (iffP eqP)=> [|]; first by move->.
by move/Qred_complete=> H; apply: val_inj=> /=; rewrite -(eqP Hq) -(eqP Hq').
Qed.

Lemma Qcb_is_canon : forall (q q' : Qcb), (q == q')%Q -> q == q'.
Proof.
  case=> q Hq; case=> q' Hq'; rewrite eqE /= => H.
  by rewrite -(eqP Hq) -(eqP Hq'); apply Qredb_complete.
Qed.

(* Arithmetic over Qcb from the one over Q *)
Definition Q2Qcb (q:Q) : Qcb := QcbMake (Qredb_involutive q).
Arguments Scope Q2Qc [Q_scope].

Definition Qcbplus  (x y : Qcb) := Q2Qcb (x + y).
Definition Qcbmult  (x y : Qcb) := Q2Qcb (x * y).
Definition Qcbopp   (x   : Qcb) := Q2Qcb (- x).
Definition Qcbminus (x y : Qcb) := Q2Qcb (x - y).
Definition Qcbinv   (x   : Qcb) := Q2Qcb (/x).
Definition Qcbdiv   (x y : Qcb) := Q2Qcb (x */ y).

(* just for the tactic *)
Lemma qcb_valE : forall x Hx, qcb_val (@QcbMake x Hx) = x .
Proof . by [] . Qed .

Tactic Notation "qcb" tactic(T) :=
    repeat case=> ? ?;
      apply/eqP; apply Qcb_is_canon;
      rewrite !qcb_valE; repeat setoid_rewrite Qred_correct;
      by T.

Lemma QcbplusA : associative Qcbplus.
Proof.
case=> [x hx] [y hy] [z hz]; apply: val_inj; apply: Qred_complete.
rewrite /= -/(Qred (Qplus y z)) -/(Qred (Qplus x y)).
repeat setoid_rewrite Qred_correct; ring.
Qed.

Lemma QcbplusC : commutative Qcbplus.
Proof.
case=> [x hx] [y hy]; apply: val_inj; apply: Qred_complete.
by rewrite Qplus_comm.
Qed.

Lemma Qcbplus0q : left_id (Q2Qcb 0) Qcbplus.
case=> [x hx];  apply: val_inj; rewrite /= -/(Qred (Qplus 0 x)).
rewrite -{2}(eqP hx). apply: Qred_complete.
by rewrite Qplus_0_l.
Qed.

Lemma QcbplusNq : left_inverse (Q2Qcb 0) Qcbopp Qcbplus.
Proof. by qcb ring. Qed.

Lemma QcbplusqN : right_inverse (Q2Qcb 0) Qcbopp Qcbplus.
Proof. by qcb ring. Qed.

Definition Qcb_zmodMixin :=
  ZmodMixin QcbplusA QcbplusC Qcbplus0q QcbplusNq.

Canonical Structure Qcb_zmodType :=
  Eval hnf in ZmodType Qcb Qcb_zmodMixin.

(* Q/== ==> Ring *)
Lemma QcbmultA : associative Qcbmult.
Proof. by qcb ring. Qed.

Lemma Qcbmult1q : left_id (Q2Qcb 1) Qcbmult.
Proof. by qcb ring. Qed.

Lemma Qcbmultq1 : right_id (Q2Qcb 1) Qcbmult.
Proof. by qcb ring. Qed.

Lemma Qcbmultq0 : forall (q : Qcb), Qcbmult q (Q2Qcb 0) = (Q2Qcb 0).
Proof. by qcb ring. Qed.

Lemma Qcbmult_addl : left_distributive Qcbmult Qcbplus.
Proof. by qcb ring. Qed.

Lemma Qcbmult_addr : right_distributive Qcbmult Qcbplus.
Proof. by qcb ring. Qed.

Lemma nonzeroq1 : Q2Qcb 1 != Q2Qcb 0.
Proof. by rewrite /Q2Qcb eqE /=. Qed.

Definition Qcb_ringMixin :=
  RingMixin QcbmultA Qcbmult1q Qcbmultq1 Qcbmult_addl Qcbmult_addr nonzeroq1.
Canonical Structure Qcb_ringType :=
  Eval hnf in RingType Qcb Qcb_ringMixin.

(* Q/== ==> commutative ring *)
Lemma QcbmultC : commutative Qcbmult.
Proof. by qcb ring. Qed.

Canonical Structure Qcb_comRingType := ComRingType Qcb QcbmultC.

(* Q/== ==> ring with units *)
Lemma Qcb_mulVx :
    forall x:Qcb, x != (Q2Qcb 0) -> Qcbmult (Qcbinv x) x = (Q2Qcb 1).
Proof.
  case=> x Hx; move=> H; apply/eqP; apply Qcb_is_canon.
  rewrite QcbmultC !qcb_valE; repeat setoid_rewrite Qred_correct.
  by apply Qmult_inv_r => Hx0; case/Qcb_QeqP: H.
Qed.

Lemma Qcb_mulxV :
    forall x:Qcb, x != (Q2Qcb 0) -> Qcbmult x (Qcbinv x) = (Q2Qcb 1).
Proof.
  by move=> x Hx; rewrite QcbmultC; apply Qcb_mulVx.
Qed.

Definition Qcb_unit : pred Qcb := fun q:Qcb => q != (Q2Qcb 0).

Lemma Qcb_intro_unit :
    forall (p q : Qcb), Qcbmult q p = (Q2Qcb 1) -> p != (Q2Qcb 0).
Proof.
  move=> p q H; apply/negP; move/eqP => p0.
  by rewrite p0 Qcbmultq0 in H.
Qed.

Lemma Qcb_intro_unit_nC :
    forall (p q : Qcb),
      Qcbmult q p = (Q2Qcb 1) /\ Qcbmult p q = (Q2Qcb 1)
      -> p != (Q2Qcb 0).
Proof.
  by move=> p q *; apply (@Qcb_intro_unit p q); tauto.
Qed.

Lemma Qcb_inv_out : forall (p : Qcb), negb (p != (Q2Qcb 0)) -> Qcbinv p = p.
Proof.
  by move=> p H; rewrite negbK in H; rewrite (eqP H) /Qcbinv /= /Qinv.
Qed.

(* FIXME strub: cannot do 1/x when defining Qcb_unitRingType as:

   Canonical Structure Qcb_unitRingType :=
      Eval hnf in UnitRingType Qcb_comUitRingMixin. *)

Definition Qcb_unitRingMixin :=
  UnitRingMixin Qcb_mulVx Qcb_mulxV Qcb_intro_unit_nC Qcb_inv_out.

Definition Qcb_comUnitRingMixin :=
  ComUnitRingMixin Qcb_mulVx Qcb_intro_unit Qcb_inv_out.

Canonical Structure Qcb_unitRingType :=
   Eval hnf in UnitRingType Qcb Qcb_unitRingMixin.

Canonical Structure Qcb_comUnitRingType := [comUnitRingType of Qcb].

(* Q/== ==> field *)
Definition Qcb_fieldMixin : GRing.Field.mixin_of Qcb_comUnitRingType.
Proof. by []. Qed.

Definition Qcb_idomainMixin := FieldIdomainMixin Qcb_fieldMixin.

Canonical Structure Qcb_iddomainType :=
  Eval hnf in IdomainType Qcb Qcb_idomainMixin.

Canonical Structure Qcb_fieldType :=
  Eval hnf in FieldType Qcb Qcb_fieldMixin.

(*
Definition Qcb_leb  (x y : Q) :=
  (Zle_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.
Definition Qcb_ltb  (x y : Q) :=
  (Zlt_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.
*)
(*
Local Notation "x <<= y" := (Qcb_leb x y).
Local Notation "x <<! y" := (Qcb_ltb x y).
*)

Definition Qcbleb (x y : Qcb) := (Qle_bool x y).

Lemma QcblebP : forall (x y : Qcb), reflect (x <= y)%Q (Qcbleb x y).
Proof. by move=> x y; apply: (iffP idP); move/Qle_bool_iff. Qed.

Lemma Qcbleb_antisymb : @ssrbool.antisymmetric Qcb Qcbleb.
Proof.
move=> x y; case/andP; move/QcblebP=> h1; move/QcblebP=> h2.
by apply/eqP; apply/Qcb_QeqP; apply: Qle_antisym.
Qed.

Lemma Qcbleb_transb : @ssrbool.transitive Qcb Qcbleb.
Proof.
move=> x y z; move/QcblebP=> h1; move/QcblebP=> h2; apply/QcblebP.
exact: Qle_trans h2.
Qed.

Lemma Qcbleb_totalb : @ssrbool.total Qcb Qcbleb.
Proof.
move=> x y; case e: (Qcbleb x y)=> //=.
by move/QcblebP: e; move/Qnot_le_lt; move/Qlt_le_weak; move/QcblebP->.
Qed.

Lemma Qcbleb_addr : forall z x y : Qcb,
  Qcbleb x y -> Qcbleb (x + z) (y + z).
Proof.
move=> [x Hx] [y Hy] [z Hz]; move/QcblebP => Hxy; apply/QcblebP.
rewrite !qcb_valE in Hxy *.
setoid_rewrite Qred_correct.
by apply Qplus_le_compat; last apply Qle_refl .
Qed.

Lemma Qle_bool_mulr : forall x y,
  Qle_bool 0 x -> Qle_bool 0 y -> Qle_bool 0 (x * y).
Proof.
move=> x y; move/Zle_is_le_bool; rewrite Zmult_1_r=> px.
move/Zle_is_le_bool; rewrite Zmult_1_r => py.
by apply/Zle_is_le_bool; rewrite Zmult_1_r; apply: Zmult_le_0_compat.
Qed.

Lemma Qcbleb_mulr : forall x y, Qcbleb 0 x -> Qcbleb 0 y -> Qcbleb 0 (x * y).
Proof.
  move=> x y; move/QcblebP; rewrite qcb_valE; setoid_rewrite Qred_correct=> hx.
  move/QcblebP; rewrite qcb_valE; setoid_rewrite Qred_correct=> hy.
  apply/QcblebP; rewrite !qcb_valE; setoid_rewrite Qred_correct.
  exact: Qmult_le_0_compat.
Qed.

Definition Q_OrderedRingMixin :=
  OrderedRing.Mixin
  Qcbleb_antisymb Qcbleb_transb Qcbleb_totalb Qcbleb_addr Qcbleb_mulr.

Canonical Structure Qcb_oIddomainType :=
  Eval hnf in OIdomainType Qcb Q_OrderedRingMixin.

Canonical Structure Qcb_oFieldType :=
  Eval hnf in OFieldType Qcb Q_OrderedRingMixin.

*)


(* Theorems to be added to the mathcomp library  *)
From mathcomp Require Import all_ssreflect all_fingroup all_field.
From mathcomp Require Import ssralg finalg poly polydiv zmodp vector.

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

Import GRing.Theory.
Import Pdiv.CommonRing.
Import Pdiv.RingMonic.

Local Open Scope ring_scope.

Lemma inZp0 p : inZp 0 = 0 :> 'Z_p.
Proof. by apply/val_eqP; rewrite /= mod0n. Qed.

(* More on comp_compy *)
Section Rcomp_poly.

Variable R : ringType.

Lemma comp_polyXn n (p : {poly R}) : 'X^n \Po p = p ^+ n.
Proof.
rewrite comp_polyE size_polyXn.
rewrite (bigD1 ord_max) //= coefXn eqxx scale1r big1 ?addr0 //.
by move=> i /eqP/val_eqP /= iDn; rewrite coefXn (negPf iDn) scale0r.
Qed.

Lemma comp_polyXsub1 n :
  ('X - 1) \Po 'X^n = 'X^n - 1 :> {poly R}.
Proof. by rewrite comp_polyB comp_polyC comp_polyX. Qed.

End Rcomp_poly.

Section Ccomp_poly.

Variable R : comRingType.

Lemma comp_poly_exp n (p q : {poly R}) : (p \Po q) ^+ n = (p ^+ n) \Po q.
Proof. by rewrite rmorphX. Qed.

End Ccomp_poly.

(* poly *)

Section Poly.

Variable R : ringType.

Lemma size_exp_monic (p: {poly R}) n :
  p \is monic -> size (p ^+ n) = ((size p).-1 * n).+1.
Proof.
move=> pM; elim: n => // [|n IH].
  by rewrite !expr0 muln0 size_polyC oner_eq0.
rewrite exprS size_proper_mul ?IH; last first.
  by rewrite (eqP pM) (eqP (monic_exp n pM)) mul1r oner_neq0.
have : (0 < size p)%nat.
  by have := monic_neq0 pM; rewrite -size_poly_eq0; case: size.
by case: size => // k _; rewrite addSn addnS -mulnS.
Qed.

Lemma monic_comp_poly (p q : {poly R}) :
  p \is monic -> q \is monic -> q != 1 -> p \Po q \is monic.
Proof.
move=> pM qM qD1.
have cp0q : (p \Po q)`_((size p).-1 * (size q).-1) == 1.
  rewrite comp_polyE coef_sum.
  have := (pM); rewrite monicE /lead_coef.
  have : (0 < size p)%nat.
    by have := monic_neq0 pM; rewrite -size_poly_eq0; case: size.
  case: size => //= k _ pkE.
  rewrite big_ord_recr /= (eqP pkE) scale1r big1 ?add0r.
    have := monic_exp k qM.
    by rewrite qualifE /lead_coef size_exp_monic //= mulnC.
  move=> i _; rewrite coefZ [_`_(k * _)]nth_default ?mulr0 //.
  rewrite size_exp_monic // mulnC.
  suff : (1 < size q)%nat.
    by case: size => // [] [|v] //_ ; rewrite ltn_mul2r ltn_ord.
  case E : size => [|[|v]] //.
    have /eqP := E; rewrite size_poly_eq0 => /eqP qE0.
    by move: qM; rewrite qualifE qE0 lead_coefC eq_sym oner_eq0.
  have /eqP/size_poly1P[c cD0 qE] := E.
  by case/eqP: qD1; move: qM; rewrite qE qualifE lead_coefC => /eqP->.
have := size_comp_poly_leq p q.
rewrite qualifE /lead_coef leq_eqVlt => /orP[/eqP-> //|].
rewrite ltnS => sLp; move: cp0q.
by rewrite nth_default // eq_sym oner_eq0.
Qed.

End Poly.

(* rdvdp *)

Section rdvdp.

Variable R : ringType.

Lemma rdvdp_trans (p q r : {poly R}) :
  p \is monic -> q \is monic -> rdvdp p q -> rdvdp q r -> rdvdp p r.
Proof.
move=> pM qM /rdvdpP => /(_ pM) [qq1 qq1E] /rdvdpP => /(_ qM) [qq2 qq2E].
by apply/rdvdpP => //; exists (qq2 * qq1); rewrite qq2E qq1E mulrA.
Qed.

End rdvdp.

Section Crdvdp.

Variable R : comRingType.

Lemma rdvdp_comp_poly (r p q : {poly R}) :
 p \is monic -> r \is monic -> r != 1 -> rdvdp p q -> rdvdp (p \Po r) (q \Po r).
Proof.
move=> pM rM rD1 /rdvdpP => /(_ pM) [qq qqE].
apply/rdvdpP; first by apply: monic_comp_poly.
by exists (qq \Po r); rewrite qqE comp_polyM.
Qed.

End Crdvdp.

(* irreducible *)

Section Firreducible.

Variable F : finFieldType.

Definition irreducibleb (p : {poly F}) :=
  (1 < size p) &&
  [forall q : (size p).-1.-tuple F, (Poly q %| p) ==> (size (Poly q) <= 1)].

Lemma irreducibleP (p : {poly F}) :
  reflect (irreducible_poly p) (irreducibleb p).
Proof.
rewrite /irreducibleb /irreducible_poly.
apply: (iffP idP) => [/andP[Sp /forallP Fp]|[Sp Fpoly]].
  split => // q SqD1 qDp.
  rewrite -dvdp_size_eqp //.
  have pD0 : p != 0 by rewrite -size_poly_eq0; case: size Sp.
  have: size q <= size p by apply: dvdp_leq.
  rewrite leq_eqVlt => /orP[//|SqLp].
  have xF : size (q ++ nseq ((size p).-1 - size q) 0) == (size p).-1.
    by rewrite size_cat size_nseq addnC subnK //;  case: size Sp SqLp.
  have /implyP/= := Fp (Tuple xF).
  rewrite (_ : Poly _ = q) // => [/(_ qDp)|].
    case E : size SqD1 qDp => [|[|k]] //.
    have /eqP  := E.
    rewrite size_poly_eq0 => /eqP-> _; rewrite dvd0p => /eqP->.
    by rewrite size_polyC eqxx.
  apply/polyP => i; rewrite coef_Poly nth_cat.
  by case: leqP => qLi //; first by rewrite nth_nseq if_same nth_default.
rewrite Sp /=; apply/forallP => q; apply/implyP=> qDp.
have [/eqP->//|/Fpoly/(_ qDp)/eqp_size ES] := boolP (size (Poly q) == 1%N).
have := size_Poly q; rewrite ES size_tuple.
by case: size Sp => // k; rewrite ltnn.
Qed.

Lemma irreducible_dvdp (p : {poly F}) :
  1 < size p -> exists2 q, irreducible_poly q & q %| p.
Proof.
elim: {p}_.+1 {-2}p  (ltnSn (size p)) => // k IH p SpLk Sp_gt1.
have [/irreducibleP pI|] := boolP (irreducibleb p); first by exists p.
rewrite /irreducibleb Sp_gt1 negb_forall => /existsP[q].
rewrite negb_imply -ltnNge => /andP[qDp Sq_gt1].
case: (IH _ _ Sq_gt1) => [|r rI rDq].
  apply: leq_ltn_trans (size_Poly _) _.
  by rewrite size_tuple; case: size SpLk Sp_gt1.
exists r => //.
by apply: dvdp_trans qDp.
Qed.

End Firreducible.

Section irreducible.

Variable R : idomainType.

Lemma irreducible_exp n (p q : {poly R}) :
  irreducible_poly p -> 0 < n -> p %| q ^+ n = (p %| q).
Proof.
move=> pI.
elim: n => // [] [|n] // /(_ isT) IH _.
apply/idP/idP; rewrite exprS; last first.
  by move=> /dvdp_trans; apply; apply: dvdp_mulr.
have [pCq|pNCq] := boolP (coprimep p q); first by rewrite Gauss_dvdpr // IH.
have /(irredp_XsubCP pI)[pCq|/andP[_ pDg] _] : gcdp p q %| p.
- by rewrite dvdp_gcdl.
- by case/negP: pNCq; rewrite /coprimep size_poly_eq1.
by apply: dvdp_trans pDg (dvdp_gcdr _ _).
Qed.

End irreducible.

(* Separable *)

Section separable.

Lemma separable_exp (F : finFieldType) n (p q : {poly F}) :
  separable_poly p -> 0 < n -> p %| q ^+ n = (p %| q).
Proof.
case: n => // n pS _.
apply/idP/idP; last first.
  by rewrite exprS => /dvdp_trans; apply; apply: dvdp_mulr.
elim: {p}_.+1 {-2}p (ltnSn (size p)) pS => // k IH p SpLk pS pDqn.
have [|Sp_gt1] := leqP (size p) 1.
  rewrite leq_eqVlt => /orP[].
    rewrite size_poly_eq1 => /andP[/dvdp_trans-> //].
    by apply: dvd1p.
  rewrite ltnS leqn0 size_poly_eq0 => /eqP pZ.
  by move: pDqn; rewrite pZ dvd0p expf_eq0 //= => /eqP->.
have [r rI rDq] := irreducible_dvdp Sp_gt1.
have /dvdpP[s pE] := rDq.
have sDp : s %| p by rewrite pE dvdp_mulr.
have rCs : coprimep s r by apply: separable_coprime  pS _; rewrite -pE.
rewrite pE Gauss_dvdp //; apply/andP; split; last first.
  by rewrite -(@irreducible_exp _ n.+1) // (dvdp_trans _ pDqn).
apply: IH; last 2 first.
- by apply: dvdp_separable pS; rewrite pE dvdp_mulr.
- by rewrite (dvdp_trans _ pDqn).
rewrite -(ltn_add2r (size r)) -[(_ + size _)%N]prednK; last first.
  by case: rI; case: size => // k1; rewrite addnS.
rewrite -size_mul; last by apply: irredp_neq0.
  rewrite -pE (leq_trans _ (_ : (k + 2 <= _))) //.
    by rewrite !addnS addn0 ltnS.
  by rewrite leq_add2l; case: rI.
apply: separable_poly_neq0.
by apply: dvdp_separable pS; rewrite pE dvdp_mulr.
Qed.

Lemma separable_polyXnsub1 (R : fieldType) n :
 n%:R != 0 :> R -> separable_poly ('X^n - 1 : {poly R}).
Proof.
move=> nC.
have n_gt0 : 0 < n by case: n nC => //; rewrite eqxx.
rewrite /separable_poly !derivE subr0.
suff ->: 'X^n - 1 = (n%:R^-1 *: 'X) * ('X^n.-1 *+ n) + (-1) :> {poly R}.
  rewrite coprimep_sym coprimep_addl_mul.
  by rewrite -scaleN1r coprimepZr ?coprimep1 // oppr_eq0 oner_eq0.
rewrite -scaler_nat scalerCA scalerA mulVf //.
by rewrite scale1r -exprS prednK.
Qed.

End separable.

(*  About rmodp and monic *)

Section Rmodp.

Variable R : ringType.

Lemma rmodp_mod (d p : {poly R}) :
  d \is monic -> rmodp (rmodp p d) d = rmodp p d.
Proof.
by move=> dM; rewrite rmodp_small // ltn_rmodpN0 // monic_neq0.
Qed.

Lemma rmodp_opp (d p : {poly R}) : d \is monic -> rmodp (- p) d = - rmodp p d.
Proof.
move=> dM.
rewrite {1}(rdivp_eq dM p) opprD // -mulNr rmodp_addl_mul_small //.
by rewrite size_opp ltn_rmodp //monic_neq0.
Qed.

Lemma rmodpB (d p q : {poly R}) :
  d \is monic -> rmodp (p - q) d = (rmodp p d - rmodp q d)%R.
Proof. by move=> dM; rewrite rmodpD // rmodp_opp. Qed.

Lemma rmodpZ (d : {poly R}) a p :
  d \is monic -> rmodp (a *: p) d = a *: (rmodp p d).
move=> dM.
case: (altP (a =P 0%R)) => [-> | cn0]; first by rewrite !scale0r rmod0p.
have -> : ((a *: p) = (a *: (rdivp p d)) * d + a *: (rmodp p d))%R.
  by rewrite -scalerAl -scalerDr -rdivp_eq.
rewrite  rmodp_addl_mul_small //.
rewrite -mul_polyC; apply: leq_ltn_trans (size_mul_leq _ _) _.
  rewrite size_polyC cn0 addSn add0n /= ltn_rmodp.
by apply: monic_neq0.
Qed.

Lemma rmodp_sum (I : Type) (r : seq I) (P : pred I) (F : I -> {poly R}) d :
   d \is monic ->
   rmodp (\sum_(i <- r | P i) F i) d = (\sum_(i <- r | P i) (rmodp (F i) d)).
Proof.
move=> dM.
by elim/big_rec2: _ => [|i p q _ <-]; rewrite ?(rmod0p, rmodpD).
Qed.

Lemma coef_comp_poly (p q : {poly R}) n :
  (p \Po q)`_n = \sum_(i < size p) p`_i * (q ^+ i)`_n.
Proof. by rewrite comp_polyE coef_sum; apply: eq_bigr => i; rewrite coefZ. Qed.

End Rmodp.

Section CRmodp.

Variable R : comRingType.

Lemma rmodp_mulml (p q r : {poly R}) :
  r \is monic -> rmodp (rmodp p r * q) r = rmodp (p * q) r.
Proof. by move=> dM; rewrite [in LHS]mulrC [in RHS]mulrC rmodp_mulmr.
Qed.

Lemma rmodpX (p q : {poly R}) n :
  q \is monic -> rmodp ((rmodp p q) ^+ n) q = rmodp (p ^+ n) q.
Proof.
move=> qM; elim: n => [|n IH]; first by rewrite !expr0.
rewrite !exprS -rmodp_mulmr // IH rmodp_mulmr //.
by rewrite mulrC rmodp_mulmr // mulrC.
Qed.

Lemma rmodp_compr (p q d : {poly R}) :
  d \is monic -> rmodp (p \Po (rmodp q d)) d = (rmodp (p \Po q) d).
Proof.
move=> dM.
elim/poly_ind: p => [|p c IH].
  by rewrite !comp_polyC !rmod0p.
rewrite !comp_polyD !comp_polyM addrC rmodpD //.
 rewrite mulrC -rmodp_mulmr // IH rmodp_mulmr //.
 rewrite !comp_polyX !comp_polyC.
by rewrite mulrC rmodp_mulmr // -rmodpD // addrC.
Qed.

End CRmodp.

(* natmul *)
Section natmul.

Variable R : ringType.

Lemma poly_natmul p : p%:R%:P = p%:R :> {poly R}.
Proof. by elim: p => //= p IH; rewrite !mulrS -IH polyCD. Qed.

Lemma scale_polyC a b : a *: b%:P = (a * b)%:P :> {poly R}.
Proof. by rewrite -mul_polyC polyCM. Qed.

End natmul.

(* charpoly *)
Section charpoly.

Variable R : ringType.

Lemma char_poly : [char {poly R}] =i [char R].
Proof.
move=> p; rewrite !inE; congr (_ && _).
apply/eqP/eqP=> [/(congr1 val) /=|]; last by rewrite -poly_natmul => ->.
by rewrite polyseq0 -poly_natmul polyseqC; case: eqP.
Qed.

End charpoly.

Section alreadyin.

Variable R : idomainType.
Implicit Type p : {poly R}.

Theorem max_poly_roots p rs :
  p != 0 -> all (root p) rs -> uniq rs -> size rs < size p.
Proof.
elim: rs p => [p pn0 _ _ | r rs ihrs p pn0] /=; first by rewrite size_poly_gt0.
case/andP => rpr arrs /andP [rnrs urs]; case/factor_theorem: rpr => q epq.
case: (altP (q =P 0)) => [q0 | ?]; first by move: pn0; rewrite epq q0 mul0r eqxx.
have -> : size p = (size q).+1.
   by rewrite epq size_Mmonic ?monicXsubC // size_XsubC addnC.
suff /eq_in_all h : {in rs, root q =1 root p} by apply: ihrs => //; rewrite h.
move=> x xrs; rewrite epq rootM root_XsubC orbC; case: (altP (x =P r)) => // exr.
by move: rnrs; rewrite -exr xrs.
Qed.

Lemma roots_geq_poly_eq0 p (rs : seq R) : all (root p) rs -> uniq rs ->
  size rs >= size p -> p = 0.
Proof. by move=> ??; apply: contraTeq => ?; rewrite leqNgt max_poly_roots. Qed.

End alreadyin.

Section FinField.

(* We extract a part of PrimePowerField *)
Lemma Fp_splittingField d p : prime p -> 0 < d ->
  {L: splittingFieldType 'F_p | #|FinFieldExtType L| = p ^ d}.
Proof.
move=> pP d_gt0.
have p_gt1 := prime_gt1 pP.
pose m := p ^ d.
have m_gt1: m > 1 by rewrite (ltn_exp2l 0) ?prime_gt1.
have m_gt0 := ltnW m_gt1; have m1_gt0: m.-1 > 0 by rewrite -ltnS prednK.
pose q := 'X^m - 'X; have Dq R: q R = ('X^m.-1 - 1) * ('X - 0).
  by rewrite subr0 mulrBl mul1r -exprSr prednK.
have /FinSplittingFieldFor[/= L splitLq]: q [ringType of 'F_p] != 0.
  by rewrite Dq monic_neq0 ?rpredM ?monicXsubC ?monic_Xn_sub_1.
rewrite [map_poly _ _]rmorphB rmorphX /= map_polyX -/(q L) in splitLq.
exists L.
have charL: p \in [char L] by  rewrite char_lalg /= char_Fp.
have /finField_galois_generator[/= a Ca Da]: (1 <= {:L})%VS by apply: sub1v.
pose Em := fixedSpace (a ^+ d)%g. rewrite //= dimv1 expn1 in Da.
have{splitLq} [zs DqL defL] := splitLq.
have Uzs: uniq zs.
  rewrite -separable_prod_XsubC -(eqp_separable DqL) Dq separable_root andbC.
  rewrite /root !hornerE subr_eq0 eq_sym expr0n gtn_eqF ?oner_eq0 //.
  rewrite cyclotomic.separable_Xn_sub_1 // -subn1 natrB // subr_eq0.
  by rewrite natrX charf0 // expr0n gtn_eqF // eq_sym oner_eq0.
have in_zs: zs =i Em.
  move=> z; rewrite -root_prod_XsubC -(eqp_root DqL) (sameP fixedSpaceP eqP).
  rewrite /root !hornerE subr_eq0 /= /m; congr (_ == z).
  elim: (d) => [|i IHi]; first by rewrite gal_id.
  by rewrite expgSr expnSr exprM IHi galM ?Da ?memvf // card_Fp.
have defEm: Em = {:L}%VS.
  apply/eqP; rewrite eqEsubv subvf -defL -[Em]subfield_closed agenvS //.
  by rewrite subv_add sub1v; apply/span_subvP=> z; rewrite in_zs.
have/eq_card-> : FinFieldExtType L =i zs.
  by move=> z; rewrite in_zs defEm memvf.
apply: succn_inj.
rewrite (card_uniqP _) //= -(size_prod_XsubC _ id).
by rewrite -(eqp_size DqL) size_addl size_polyXn // size_opp size_polyX.
Qed.

Lemma PrimePowerField p k (m := (p ^ k)) :
  prime p -> 0 < k -> {Fm : finFieldType | p \in [char Fm] & #|Fm| = m}.
Proof.
move=> pP k_gt0.
have [L LC] := Fp_splittingField pP k_gt0.
have charL: p \in [char L] by rewrite char_lalg char_Fp.
by exists (FinFieldExtType L).
Qed.

End FinField.

Lemma fin_little_fermat (F : finFieldType) (n c : nat) :
  n \in [char F] -> c%:R ^+ n = c%:R :> F.
Proof.
move=> nC.
have Pp : prime n by apply: charf_prime nC.
have Cn : [char F].-nat n by rewrite pnatE.
elim: c => [|c IH]; first by rewrite -natrX exp0n ?prime_gt0.
by rewrite -addn1 natrD exprDn_char // IH -natrX exp1n.
Qed.

Lemma poly_geom (R : comRingType) n (p : {poly R}) :
  p ^+ n.+1 - 1 = (p - 1) * \sum_(i < n.+1) p ^+ i.
Proof.
rewrite mulrBl mul1r {1}big_ord_recr big_ord_recl /=.
rewrite [_ + p^+_]addrC mulrDr -exprS expr0 addrAC opprD addrA mulr_sumr.
rewrite (eq_bigr (fun i : 'I_n => p * p ^+ i)) ?subrK // => i _.
by rewrite exprS.
Qed.

Lemma dvdp_geom (R : comRingType) n (p : {poly R}) :
  p - 1 \is monic -> rdvdp (p - 1) (p ^+ n.+1 - 1).
Proof. move=> pM; rewrite poly_geom mulrC rdvdp_mull //. Qed.

Lemma totient_leq n : totient n <= n.
Proof.
rewrite totient_count_coprime.
rewrite -{3}[n]muln1 -{3}[n]subn0 -sum_nat_const_nat.
by apply: leq_sum => i _; case: coprime.
Qed.

(* Definition of the order for Z_k *)
Fixpoint order_modn_rec m n r i k :=
  let r1 := ((r * n) %% m)%nat in
  if r1 == 1%N then i else
  if k is k1.+1 then order_modn_rec m n r1 i.+1 k1 else i%nat.

Lemma order_modn_recP m n r i k :
  coprime n m ->
  1 < m ->
  0 < i ->
  (forall j, 0 < j < i -> (n ^ j != 1 %[mod m])%N) ->
  r = (n ^ i.-1 %% m)%nat -> m.+1 = (k + i)%nat ->
  [/\ 0%N < order_modn_rec m n r i k,
  (n ^ order_modn_rec m n r i k = 1 %[mod m])%N &
  (forall j, 0 < j < order_modn_rec m n r i k -> (n ^ j != 1 %[mod m])%N)].
Proof.
move=> nCm m_gt1.
elim: k r i => /= [r i i_gt0 H rE mE| k IH r i i_gt0  H rE mE].
  have /H/eqP[] : 0 < totient m < i.
    by rewrite totient_gt0 ?(leq_trans _ m_gt1) // -[i]mE [_ < _]totient_leq.
  by apply: cyclic.Euler_exp_totient.
have niE : (n ^ i = r * n %[mod m])%N by rewrite rE modnMml -expnSr prednK.
case: eqP => [rnE|/eqP rnE].
  by rewrite niE {1}(modn_small m_gt1).
apply: IH => [|i1 /andP[i1_gt0]||] //.
  rewrite ltnS leq_eqVlt => /orP[/eqP->|i1Li].
    by rewrite niE {1}(modn_small m_gt1).
  by apply: H; rewrite i1_gt0.
by rewrite mE addnS.
Qed.

Definition order_modn m n :=
  if coprime n m && (1 < m) then order_modn_rec m n 1 1 m
  else 0%nat.

Lemma order_modnP m n :
  1 < m -> coprime m n ->
  [/\ 0 < order_modn m n,
  (n ^ order_modn m n = 1 %[mod m])%N &
  (forall j, 0 < j < order_modn m n -> n ^ j != 1 %[mod m])%N].
Proof.
move=> m_gt1 mCn.
rewrite /order_modn m_gt1 coprime_sym mCn /=.
apply: order_modn_recP => //; first by rewrite coprime_sym.
- by case.
- by rewrite modn_small.
by rewrite addn1.
Qed.

Lemma order_modn_gt1 k m : 1 < order_modn k m -> 1 < k.
Proof. by rewrite /order_modn andbC; case: (1 < k). Qed.

Lemma order_modn_coprime k m : 1 < order_modn k m -> coprime k m.
Proof. Proof. by rewrite /order_modn coprime_sym; case: coprime. Qed.

Lemma order_modn_dvd k m :
   1 < k -> coprime k m -> (k %| (m ^ order_modn k m).-1)%N.
Proof.
move=> k_gt1 kCm.
have /(order_modnP k_gt1)[o_gt0 /eqP] := kCm.
rewrite /dvdn [(1 %% _)%N]modn_small // => /eqP modE _.
by rewrite (divn_eq (_ ^ _) k) modE addn1 /= modnMl.
Qed.

Lemma order_modn_mod k m : 1 < k -> order_modn k (m %% k) = order_modn k m.
Proof.
move=> k_gt1.
have [kCm| kNCm]:= boolP (coprime k m); last first.
  have kNCmk : ~~ coprime k (m %% k) by rewrite coprime_modr.
  by rewrite /order_modn coprime_sym (negPf kNCmk) coprime_sym (negPf kNCm).
have kCmk : coprime k (m %% k) by rewrite coprime_modr.
have [m_gt0 Hm Hmn] := order_modnP k_gt1 kCm.
have [mk_gt0 Hmk Hmkn] := order_modnP k_gt1 kCmk.
case: (leqP (order_modn k (m %% k)%N) (order_modn k m)) => [|mLmk].
  rewrite leq_eqVlt => /orP[/eqP->//|mkLm].
  have /Hmn/eqP[] :  0 < order_modn k (m %% k) < order_modn k m.
    by rewrite mk_gt0.
  by rewrite -modnXm.
have /Hmkn/eqP[] :  0 < order_modn k m < order_modn k (m %% k).
  by rewrite m_gt0.
by rewrite modnXm.
Qed.

Lemma order_modnE n m :
  1 < m -> coprime m n ->
  order_modn m n =
  oapp (fingroup.order : {unit 'Z_m} -> nat) 0%N (insub n%:R).
Proof.
move=> m_gt1 mCn.
case: insubP; rewrite unitZpE ?mCn //= => u _ Hu.
have  [o_gt0 moE1 Hmon] := order_modnP m_gt1 mCn.
case: (leqP (order_modn m n) #[u]%g) => [|uLo].
  rewrite leq_eqVlt => /orP[/eqP //|].
  rewrite ltnNge => /negP[].
  apply: dvdn_leq => //.
  rewrite cyclic.order_dvdn.
  apply/eqP/val_eqP => /=.
  by rewrite FinRing.val_unitX /= Hu -natrX -Zp_nat_mod // moE1 modn_small.
have : n ^ #[u]%g != 1 %[mod m] by apply: Hmon; rewrite order_gt0.
have /val_eqP/= := expg_order u.
rewrite FinRing.val_unitX /= Hu -natrX -val_Zp_nat // => /eqP->.
by rewrite modn_small.
Qed.

(* k > 1 not necessary *)
Lemma order_modn_exp k m :
  1 < k -> coprime k m -> m ^ order_modn k m = 1 %[mod k].
Proof.
by move=> k_gt1 kCm; case: (order_modnP k_gt1 kCm).
Qed.

Lemma leq_order_totient k m : 0 < k -> order_modn k m <= totient k.
Proof.
move=> k_gt0.
case: (leqP k 1) => [|k_gt1].
  rewrite /order_modn.
  by case: k k_gt0 => [|[|]]; rewrite ?ltnn ?andbF.
have [kCm|kNCm] := boolP (coprime k m); last first.
  by rewrite /order_modn coprime_sym (negPf kNCm).
rewrite order_modnE //.
rewrite -card_units_Zp // /order_modn.
case: insubP => //= u uU uE.
by apply/subset_leq_card/subsetP=> i; rewrite inE.
Qed.

Lemma modn_prodm I r (P : pred I) F d :
  \prod_(i <- r | P i) (F i %% d) = \prod_(i <- r | P i) F i %[mod d].
Proof.
apply/eqP; elim/big_rec2: _ => // i m n _ /eqP nEm.
by rewrite modnMml -modnMmr nEm modnMmr.
Qed.

Lemma order_gt1_prime k n :
  1 < n -> 1 < order_modn k n ->
  exists p : nat, [/\ (p %| n), prime p & 1 < order_modn k p]%nat.
Proof.
move=> n_gt1 o_gt1.
have k_gt1 := order_modn_gt1 o_gt1.
have [/allP Ho|/allPn] :=
    boolP (all (fun i => order_modn k i <= 1) (primes n)); last first.
  case=> p; rewrite mem_primes -ltnNge => /and3P[pP _ pDn] pO.
  by exists p.
have B1 : 0 < 1 < order_modn k n by [].
have [_ _ /(_ _ B1)/eqP[]] :=
     order_modnP k_gt1 (order_modn_coprime o_gt1).
rewrite expn1 [n]prod_prime_decomp 1?ltnW // prime_decompE.
rewrite big_seq_cond -modn_prodm big1 // => [] [p r].
rewrite andbT => /mapP[q qP [-> ->]] /=.
have oL1 := Ho _ qP.
have kCq : coprime k q.
  apply: coprime_dvdr (order_modn_coprime o_gt1).
  by rewrite mem_primes in qP; case/and3P: qP.
have [H1 H2 _] := order_modnP k_gt1 kCq.
rewrite -modnXm -[q]expn1 -{1}(_ : order_modn k q = 1%nat).
  by rewrite H2 modnXm exp1n modn_small.
by apply/eqP; rewrite eqn_leq oL1.
Qed.

(* Definition of order for poly *)
Definition poly_order {R : ringType} (h p :  {poly R}) (n : nat) : nat :=
  if [pick i | rmodp (p^+ (i : 'I_n.+1).-1.+1) h == 1] is Some v then
      [arg min_(i < v | (rmodp (p^+ i.-1.+1) h == 1)) i].-1.+1 else 0.

Lemma poly_orderE (R : ringType) (h p : {poly R}) n m :
  0 < m <= n ->
  rmodp (p ^+ m) h = 1 ->
  (forall k, 0 < k -> rmodp (p^+ k) h = 1 -> m <= k) ->
  poly_order h p n = m.
Proof.
move=> /andP[m_gt0 mLn] /eqP mM HmM.
rewrite -ltnS in mLn.
rewrite /poly_order; case: pickP => [z zM|/(_ (Ordinal mLn))]; last first.
  by rewrite prednK //= (eqP mM) eqxx.
case: arg_minnP => //.
move=> i /eqP /HmM /= Hj /(_ (Ordinal mLn)).
rewrite prednK //= => /(_ mM) iLm.
apply/eqP; rewrite eqn_leq Hj // andbT.
by case: (i: nat) iLm.
Qed.

Lemma poly_order_leq (R : ringType) (h p : {poly R}) n :
  0 < n -> poly_order h p n <= n.
Proof.
by rewrite /poly_order; case: pickP => // x Hx; case: arg_minnP => // [] [[|m]].
Qed.

Lemma poly_order_gt0_rmodp (R : ringType) (h p : {poly R}) n :
  0 < poly_order h p n ->  rmodp (p^+ poly_order h p n) h == 1.
Proof.
by rewrite /poly_order; case: pickP => // x Hx _; case: arg_minnP.
Qed.

Lemma poly_order_eq0_rmodp (R : ringType) (h p : {poly R}) m n :
  poly_order h p n = 0%N -> 0 < m <= n -> rmodp (p^+ m) h != 1.
Proof.
rewrite -[_ <= n]ltnS /poly_order; case: pickP => // HM _ /andP[m_gt0 mLn].
by have /= := HM (Ordinal mLn); case: (m) m_gt0 => //= k _ /idP/negP.
Qed.

Lemma poly_order_lt (R : ringType) (h p : {poly R}) m n :
   0 < m < poly_order h p n -> rmodp (p^+ m) h != 1.
Proof.
rewrite /poly_order; case: pickP=> [x Hx|]; last by rewrite ltn0 andbF.
case: arg_minnP => // i Hi Hmin /andP[m_gt0 mLi].
have mLn : m < n.+1.
  by rewrite (leq_trans mLi) // (leq_trans _ (ltn_ord i)) //; case: (i : nat).
apply/negP; rewrite -[m]prednK // => /(Hmin (Ordinal mLn)) /=.
rewrite leqNgt; case: (i : nat) mLi  => [/=|j ->//].
by case: (m) m_gt0.
Qed.

(* To be a power of 2 *)
Definition is_2power n := n == 2 ^ (up_log 2 n).
Definition isnot_2power n := n != 2 ^ (up_log 2 n).

(* To be a power *)

Definition is_power p q := p == q ^ logn q p.

Lemma prime_is_power_exp p q n :
  prime p -> 1 < q -> 0 < n ->
  is_power (q ^ n) p -> is_power q p.
Proof.
move=> pP q_gt1 n_gt0.
have q_gt0 : 0 < q by apply: ltnW.
by rewrite  /is_power lognX mulnC expnM eqn_exp2r.
Qed.

Lemma is_power_exp p n : prime p -> is_power (p ^ n) p.
Proof.
by move=> pP; rewrite /is_power eqn_exp2l ?prime_gt1 // pfactorK.
Qed.

Lemma is_power_id p : prime p -> is_power p p.
Proof. by move=> pP; rewrite -{1}(expn1 p) is_power_exp. Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Datatypes.List.
Require Import coqutil.Byte.
Require Import bedrock2.Syntax.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Util.ZRange.BasicLemmas.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Local Open Scope Z_scope.
Import ListNotations.
Import Partition.

Section ByteBounds.
  Context {p : Types.parameters} {ok : Types.ok}.
  Context (n : nat).

  Definition byte_range : ZRange.zrange :=
    {|ZRange.lower:=0; ZRange.upper:=2^8-1|}.
  Definition byte_bounds : list (option ZRange.zrange) :=
    repeat (Some byte_range) n.

  (* TODO: consider refactoring this lemma into lemmas about Forall, Forall2,
     and fold_andb_map *)
  Lemma byte_bounds_range_iff x :
    list_Z_bounded_by byte_bounds x <->
    (length x = n /\
     Forall (fun z : Z => 0 <= z < 2 ^ 8) x).
  Proof.
    cbv [byte_bounds byte_range list_Z_bounded_by].
    generalize n as m.
    induction x; destruct m; split;
      cbn [FoldBool.fold_andb_map repeat]; try congruence; intros;
        repeat match goal with
               | _ => progress cleanup
               | _ => progress cbn [length ZRange.lower ZRange.upper] in *
               | |- Forall _ [] => solve [constructor]
               | |- Forall _ (_ :: _) => constructor
               | H: Forall _ (_ :: _) |- _ =>
                 inversion H; clear H; subst
               | |- (_ && _)%bool = true =>
                 apply Bool.andb_true_iff; split
               | H: (_ && _)%bool = true |- _ =>
                 apply Bool.andb_true_iff in H; destruct H
               | H : context [iff] |- _ => eapply H; solve [eauto]
               | H : context [iff] |- _ =>
                 rewrite H; auto; congruence
               | |- _ /\ _ => split
               | |- S _ = S _ => f_equal
               | _ => progress Z.ltb_to_lt
               | _ => congruence
               | _ => lia
               end.
  Qed.

  Lemma map_byte_wrap_bounded' r x m :
    ZRange.is_tighter_than_bool r byte_range = true ->
    list_Z_bounded_by (repeat (Some r) m) x ->
    map byte.wrap x = x.
  Proof.
    intros.
    pose proof length_list_Z_bounded_by _ x ltac:(eassumption).
    cbv [byte_bounds byte_range list_Z_bounded_by
                    ZRange.is_tighter_than_bool] in *.
    rewrite repeat_length in *.
    generalize dependent m.
    generalize dependent x; induction x; destruct m;
      repeat match goal with
             | _ => progress intros
             | _ => progress cleanup
             | _ => progress
                      cbn [length FoldBool.fold_andb_map
                                  ZRange.upper ZRange.lower
                                  repeat map] in *
             | H : (_ && _)%bool = true |- _ =>
               apply Bool.andb_true_iff in H
             | IH : context [map byte.wrap ?x = ?x] |- _ =>
               rewrite IH with (m:=m) by (try eassumption; lia)
             | _ => progress Z.ltb_to_lt
             | |- byte.wrap ?x :: ?y = ?x :: ?y =>
               cbv [byte.wrap]; Z.rewrite_mod_small;
                 reflexivity
             | _ => congruence
             end.
  Qed.

  Lemma map_byte_wrap_bounded x :
    list_Z_bounded_by byte_bounds x ->
    map byte.wrap x = x.
  Proof.
    intros. eapply map_byte_wrap_bounded'; [ | eassumption ].
    apply ZRange.is_tighter_than_bool_Reflexive.
  Qed.

  Lemma byte_map_unsigned_of_Z x :
    map byte.unsigned (map byte.of_Z x) = map byte.wrap x.
  Proof.
    rewrite map_map. apply map_ext. exact byte.unsigned_of_Z.
  Qed.

  (* TODO: this should be upstreamed (maybe move to Util for now) *)
  Lemma byte_of_Z_unsigned b : byte.of_Z (byte.unsigned b) = b.
  Proof.
    apply byte.unsigned_inj.
    rewrite byte.unsigned_of_Z.
    apply byte.wrap_unsigned.
  Qed.

  Lemma byte_map_of_Z_unsigned x :
    map byte.of_Z (map byte.unsigned x) = x.
  Proof.
    rewrite map_map.
    erewrite map_ext; [ apply map_id | ].
    auto using byte_of_Z_unsigned.
  Qed.

  Lemma partition_bytes_range :
    forall x,
      Forall (fun z => 0 <= z < 2^8)
             (partition (ModOps.weight 8 1) n x).
  Proof.
    induction n; intros; [ solve [constructor] | ].
    rewrite partition_step. apply Forall_snoc; auto; [ ].
    fold (UniformWeight.uweight 8).
    rewrite UniformWeight.uweight_S by lia.
    rewrite <-Z.mod_pull_div by auto with zarith.
    apply Z.mod_pos_bound; auto with zarith.
  Qed.

  Lemma partition_bounded_by x :
    list_Z_bounded_by byte_bounds (partition (ModOps.weight 8 1) n x).
  Proof.
    apply byte_bounds_range_iff; split;
      auto using partition_bytes_range, length_partition.
  Qed.
End ByteBounds.