diff options
82 files changed, 20081 insertions, 407 deletions
@@ -41,33 +41,36 @@ kernel/cooking.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \ kernel/names.cmi kernel/environ.cmi kernel/declarations.cmi kernel/csymtable.cmi: kernel/term.cmi kernel/pre_env.cmi kernel/names.cmi kernel/declarations.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \ - lib/rtree.cmi kernel/names.cmi kernel/mod_subst.cmi kernel/cemitcodes.cmi \ - kernel/cbytecodes.cmi + lib/rtree.cmi kernel/retroknowledge.cmi kernel/names.cmi \ + kernel/mod_subst.cmi kernel/cemitcodes.cmi kernel/cbytecodes.cmi kernel/entries.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \ kernel/names.cmi kernel/environ.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \ - kernel/pre_env.cmi kernel/names.cmi kernel/declarations.cmi \ - kernel/cemitcodes.cmi + kernel/retroknowledge.cmi kernel/pre_env.cmi kernel/names.cmi \ + kernel/declarations.cmi kernel/cemitcodes.cmi kernel/esubst.cmi: lib/util.cmi kernel/indtypes.cmi: kernel/univ.cmi kernel/typeops.cmi kernel/term.cmi \ kernel/names.cmi kernel/environ.cmi kernel/entries.cmi \ kernel/declarations.cmi kernel/inductive.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \ kernel/names.cmi kernel/environ.cmi kernel/declarations.cmi -kernel/modops.cmi: lib/util.cmi kernel/univ.cmi kernel/names.cmi \ - kernel/mod_subst.cmi kernel/environ.cmi kernel/entries.cmi \ - kernel/declarations.cmi kernel/mod_subst.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi kernel/mod_typing.cmi: kernel/environ.cmi kernel/entries.cmi \ kernel/declarations.cmi +kernel/modops.cmi: lib/util.cmi kernel/univ.cmi kernel/names.cmi \ + kernel/mod_subst.cmi kernel/environ.cmi kernel/entries.cmi \ + kernel/declarations.cmi kernel/names.cmi: lib/predicate.cmi lib/pp.cmi kernel/pre_env.cmi: lib/util.cmi kernel/univ.cmi kernel/term.cmi \ - kernel/sign.cmi kernel/names.cmi kernel/declarations.cmi + kernel/sign.cmi kernel/retroknowledge.cmi kernel/names.cmi \ + kernel/declarations.cmi kernel/reduction.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \ kernel/environ.cmi -kernel/safe_typing.cmi: kernel/univ.cmi kernel/term.cmi kernel/names.cmi \ - kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi \ - kernel/cooking.cmi +kernel/retroknowledge.cmi: kernel/term.cmi kernel/names.cmi \ + kernel/cbytecodes.cmi +kernel/safe_typing.cmi: kernel/univ.cmi kernel/term.cmi \ + kernel/retroknowledge.cmi kernel/names.cmi kernel/environ.cmi \ + kernel/entries.cmi kernel/declarations.cmi kernel/cooking.cmi kernel/sign.cmi: kernel/term.cmi kernel/names.cmi kernel/subtyping.cmi: kernel/univ.cmi kernel/environ.cmi \ kernel/declarations.cmi @@ -86,6 +89,9 @@ kernel/vm.cmi: kernel/term.cmi kernel/names.cmi kernel/cemitcodes.cmi \ kernel/cbytecodes.cmi lib/bigint.cmi: lib/pp.cmi lib/pp.cmi: lib/pp_control.cmi +lib/rtree.cmi: lib/pp.cmi +lib/system.cmi: lib/pp.cmi +lib/util.cmi: lib/pp.cmi lib/compat.cmo library/declare.cmi: kernel/term.cmi kernel/sign.cmi kernel/safe_typing.cmi \ library/nametab.cmi kernel/names.cmi library/libnames.cmi \ kernel/indtypes.cmi kernel/environ.cmi kernel/entries.cmi \ @@ -96,9 +102,9 @@ library/declaremods.cmi: lib/util.cmi kernel/safe_typing.cmi lib/pp.cmi \ library/dischargedhypsmap.cmi: kernel/term.cmi library/nametab.cmi \ library/libnames.cmi kernel/environ.cmi library/global.cmi: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \ - kernel/safe_typing.cmi kernel/names.cmi library/libnames.cmi \ - kernel/indtypes.cmi kernel/environ.cmi kernel/entries.cmi \ - kernel/declarations.cmi + kernel/safe_typing.cmi kernel/retroknowledge.cmi kernel/names.cmi \ + library/libnames.cmi kernel/indtypes.cmi kernel/environ.cmi \ + kernel/entries.cmi kernel/declarations.cmi library/goptions.cmi: lib/util.cmi kernel/term.cmi lib/pp.cmi \ library/nametab.cmi kernel/names.cmi kernel/mod_subst.cmi \ library/libnames.cmi @@ -116,9 +122,6 @@ library/library.cmi: lib/util.cmi lib/system.cmi lib/pp.cmi kernel/names.cmi \ library/nameops.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi library/nametab.cmi: lib/util.cmi lib/pp.cmi kernel/names.cmi \ library/libnames.cmi -lib/rtree.cmi: lib/pp.cmi -lib/system.cmi: lib/pp.cmi -lib/util.cmi: lib/pp.cmi lib/compat.cmo parsing/egrammar.cmi: toplevel/vernacexpr.cmo lib/util.cmi \ interp/topconstr.cmi proofs/tacexpr.cmo pretyping/rawterm.cmi \ interp/ppextend.cmi parsing/pcoq.cmi kernel/names.cmi \ @@ -234,8 +237,8 @@ proofs/decl_expr.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \ proofs/tacexpr.cmo pretyping/rawterm.cmi kernel/names.cmi \ interp/genarg.cmi proofs/decl_mode.cmi: kernel/term.cmi proofs/tacmach.cmi \ - proofs/proof_type.cmi kernel/names.cmi pretyping/evd.cmi lib/dyn.cmi \ - proofs/decl_expr.cmi + proofs/proof_type.cmi kernel/names.cmi pretyping/evd.cmi \ + kernel/environ.cmi lib/dyn.cmi proofs/decl_expr.cmi proofs/evar_refiner.cmi: interp/topconstr.cmi kernel/term.cmi \ proofs/refiner.cmi pretyping/rawterm.cmi kernel/names.cmi \ pretyping/evd.cmi kernel/environ.cmi @@ -279,10 +282,10 @@ tactics/contradiction.cmi: kernel/term.cmi pretyping/rawterm.cmi \ tactics/decl_interp.cmi: tactics/tacinterp.cmi kernel/mod_subst.cmi \ pretyping/evd.cmi kernel/environ.cmi proofs/decl_mode.cmi \ proofs/decl_expr.cmi -tactics/decl_proof_instr.cmi: kernel/term.cmi proofs/tacmach.cmi \ - proofs/refiner.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \ - kernel/names.cmi kernel/environ.cmi proofs/decl_mode.cmi \ - proofs/decl_expr.cmi +tactics/decl_proof_instr.cmi: pretyping/termops.cmi kernel/term.cmi \ + proofs/tacmach.cmi proofs/refiner.cmi pretyping/rawterm.cmi \ + proofs/proof_type.cmi kernel/names.cmi kernel/environ.cmi \ + proofs/decl_mode.cmi proofs/decl_expr.cmi tactics/dhyp.cmi: toplevel/vernacexpr.cmo interp/topconstr.cmi \ proofs/tacmach.cmi proofs/tacexpr.cmo kernel/names.cmi tactics/eauto.cmi: interp/topconstr.cmi kernel/term.cmi proofs/tacexpr.cmo \ @@ -299,8 +302,8 @@ tactics/evar_tactics.cmi: kernel/term.cmi proofs/tacmach.cmi \ proofs/tacexpr.cmo pretyping/rawterm.cmi kernel/names.cmi tactics/extraargs.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \ tactics/tacticals.cmi proofs/tacexpr.cmo tactics/setoid_replace.cmi \ - pretyping/rawterm.cmi proofs/proof_type.cmi parsing/pcoq.cmi \ - kernel/names.cmi + kernel/retroknowledge.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \ + parsing/pcoq.cmi kernel/names.cmi tactics/extratactics.cmi: lib/util.cmi interp/topconstr.cmi kernel/term.cmi \ proofs/tacexpr.cmo pretyping/rawterm.cmi proofs/proof_type.cmi \ kernel/names.cmi interp/genarg.cmi @@ -368,12 +371,12 @@ toplevel/record.cmi: toplevel/vernacexpr.cmo interp/topconstr.cmi \ toplevel/searchisos.cmi: kernel/term.cmi kernel/names.cmi \ library/libobject.cmi toplevel/toplevel.cmi: lib/pp.cmi parsing/pcoq.cmi +toplevel/vernac.cmi: toplevel/vernacexpr.cmo lib/util.cmi parsing/pcoq.cmi toplevel/vernacentries.cmi: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \ lib/util.cmi interp/topconstr.cmi kernel/term.cmi \ pretyping/reductionops.cmi kernel/names.cmi library/libnames.cmi \ pretyping/evd.cmi kernel/environ.cmi toplevel/vernacinterp.cmi: proofs/tacexpr.cmo -toplevel/vernac.cmi: toplevel/vernacexpr.cmo lib/util.cmi parsing/pcoq.cmi toplevel/whelp.cmi: interp/topconstr.cmi kernel/term.cmi kernel/names.cmi \ kernel/environ.cmi contrib/cc/ccalgo.cmi: lib/util.cmi kernel/term.cmi lib/pp.cmi \ @@ -383,9 +386,9 @@ contrib/cc/ccproof.cmi: kernel/term.cmi kernel/names.cmi \ contrib/cc/cctac.cmi: kernel/term.cmi proofs/proof_type.cmi contrib/correctness/past.cmi: lib/util.cmi interp/topconstr.cmi \ kernel/term.cmi kernel/names.cmi +contrib/correctness/pcic.cmi: pretyping/rawterm.cmi contrib/correctness/pcicenv.cmi: kernel/term.cmi kernel/sign.cmi \ kernel/names.cmi -contrib/correctness/pcic.cmi: pretyping/rawterm.cmi contrib/correctness/pdb.cmi: kernel/names.cmi contrib/correctness/peffect.cmi: lib/pp.cmi kernel/names.cmi contrib/correctness/penv.cmi: kernel/term.cmi kernel/names.cmi \ @@ -453,10 +456,10 @@ contrib/funind/functional_principles_types.cmi: kernel/term.cmi \ contrib/funind/indfun_common.cmi: kernel/term.cmi proofs/tacexpr.cmo \ pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi library/libnames.cmi \ kernel/entries.cmi library/decl_kinds.cmo -contrib/funind/rawtermops.cmi: lib/util.cmi pretyping/rawterm.cmi \ - kernel/names.cmi library/libnames.cmi contrib/funind/rawterm_to_relation.cmi: interp/topconstr.cmi \ pretyping/rawterm.cmi kernel/names.cmi +contrib/funind/rawtermops.cmi: lib/util.cmi pretyping/rawterm.cmi \ + kernel/names.cmi library/libnames.cmi contrib/funind/tacinvutils.cmi: lib/util.cmi pretyping/termops.cmi \ kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ proofs/tacmach.cmi tactics/tacinterp.cmi tactics/refine.cmi \ @@ -493,6 +496,7 @@ contrib/rtauto/refl_tauto.cmi: kernel/term.cmi proofs/tacmach.cmi \ contrib/subtac/context.cmi: kernel/term.cmi kernel/names.cmi contrib/subtac/eterm.cmi: lib/util.cmi kernel/term.cmi proofs/tacmach.cmi \ kernel/names.cmi pretyping/evd.cmi +contrib/subtac/subtac.cmi: toplevel/vernacexpr.cmo lib/util.cmi contrib/subtac/subtac_cases.cmi: lib/util.cmi kernel/term.cmi \ pretyping/rawterm.cmi kernel/names.cmi pretyping/inductiveops.cmi \ pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \ @@ -505,7 +509,6 @@ contrib/subtac/subtac_command.cmi: toplevel/vernacexpr.cmo \ contrib/subtac/subtac_errors.cmi: lib/util.cmi lib/pp.cmi contrib/subtac/subtac_interp_fixpoint.cmi: lib/util.cmi interp/topconstr.cmi \ lib/pp.cmi kernel/names.cmi library/libnames.cmi -contrib/subtac/subtac.cmi: toplevel/vernacexpr.cmo lib/util.cmi contrib/subtac/subtac_obligations.cmi: lib/util.cmi interp/topconstr.cmi \ kernel/term.cmi proofs/tacexpr.cmo proofs/proof_type.cmi kernel/names.cmi contrib/subtac/subtac_pretyping.cmi: interp/topconstr.cmi kernel/term.cmi \ @@ -565,16 +568,6 @@ ide/config_lexer.cmo: lib/util.cmi ide/config_parser.cmi ide/config_lexer.cmx: lib/util.cmx ide/config_parser.cmx ide/config_parser.cmo: lib/util.cmi ide/config_parser.cmi ide/config_parser.cmx: lib/util.cmx ide/config_parser.cmi -ide/coqide.cmo: toplevel/vernacexpr.cmo lib/util.cmi ide/undo.cmi \ - lib/system.cmi ide/preferences.cmi lib/pp.cmi proofs/pfedit.cmi \ - ide/ideutils.cmi ide/highlight.cmo ide/find_phrase.cmo \ - proofs/decl_mode.cmi config/coq_config.cmi ide/coq_commands.cmo \ - ide/coq.cmi ide/command_windows.cmi ide/blaster_window.cmo ide/coqide.cmi -ide/coqide.cmx: toplevel/vernacexpr.cmx lib/util.cmx ide/undo.cmx \ - lib/system.cmx ide/preferences.cmx lib/pp.cmx proofs/pfedit.cmx \ - ide/ideutils.cmx ide/highlight.cmx ide/find_phrase.cmx \ - proofs/decl_mode.cmx config/coq_config.cmx ide/coq_commands.cmx \ - ide/coq.cmx ide/command_windows.cmx ide/blaster_window.cmx ide/coqide.cmi ide/coq.cmo: toplevel/vernacexpr.cmo toplevel/vernacentries.cmi \ toplevel/vernac.cmi lib/util.cmi pretyping/termops.cmi kernel/term.cmi \ proofs/tacmach.cmi tactics/tacinterp.cmi lib/system.cmi \ @@ -599,6 +592,16 @@ ide/coq.cmx: toplevel/vernacexpr.cmx toplevel/vernacentries.cmx \ config/coq_config.cmx toplevel/cerrors.cmx ide/coq.cmi ide/coq_tactics.cmo: ide/coq_tactics.cmi ide/coq_tactics.cmx: ide/coq_tactics.cmi +ide/coqide.cmo: toplevel/vernacexpr.cmo lib/util.cmi ide/undo.cmi \ + lib/system.cmi ide/preferences.cmi lib/pp.cmi proofs/pfedit.cmi \ + ide/ideutils.cmi ide/highlight.cmo ide/find_phrase.cmo \ + proofs/decl_mode.cmi config/coq_config.cmi ide/coq_commands.cmo \ + ide/coq.cmi ide/command_windows.cmi ide/blaster_window.cmo ide/coqide.cmi +ide/coqide.cmx: toplevel/vernacexpr.cmx lib/util.cmx ide/undo.cmx \ + lib/system.cmx ide/preferences.cmx lib/pp.cmx proofs/pfedit.cmx \ + ide/ideutils.cmx ide/highlight.cmx ide/find_phrase.cmx \ + proofs/decl_mode.cmx config/coq_config.cmx ide/coq_commands.cmx \ + ide/coq.cmx ide/command_windows.cmx ide/blaster_window.cmx ide/coqide.cmi ide/find_phrase.cmo: ide/preferences.cmi ide/ideutils.cmi ide/find_phrase.cmx: ide/preferences.cmx ide/ideutils.cmx ide/highlight.cmo: ide/ideutils.cmi @@ -715,12 +718,12 @@ interp/topconstr.cmx: lib/util.cmx kernel/term.cmx pretyping/rawterm.cmx \ pretyping/detyping.cmx lib/bigint.cmx interp/topconstr.cmi kernel/cbytecodes.cmo: kernel/term.cmi kernel/names.cmi kernel/cbytecodes.cmi kernel/cbytecodes.cmx: kernel/term.cmx kernel/names.cmx kernel/cbytecodes.cmi -kernel/cbytegen.cmo: lib/util.cmi kernel/term.cmi kernel/pre_env.cmi \ - kernel/names.cmi kernel/declarations.cmi kernel/cemitcodes.cmi \ - kernel/cbytecodes.cmi kernel/cbytegen.cmi -kernel/cbytegen.cmx: lib/util.cmx kernel/term.cmx kernel/pre_env.cmx \ - kernel/names.cmx kernel/declarations.cmx kernel/cemitcodes.cmx \ - kernel/cbytecodes.cmx kernel/cbytegen.cmi +kernel/cbytegen.cmo: lib/util.cmi kernel/term.cmi kernel/retroknowledge.cmi \ + kernel/pre_env.cmi kernel/names.cmi kernel/declarations.cmi \ + kernel/cemitcodes.cmi kernel/cbytecodes.cmi kernel/cbytegen.cmi +kernel/cbytegen.cmx: lib/util.cmx kernel/term.cmx kernel/retroknowledge.cmx \ + kernel/pre_env.cmx kernel/names.cmx kernel/declarations.cmx \ + kernel/cemitcodes.cmx kernel/cbytecodes.cmx kernel/cbytegen.cmi kernel/cemitcodes.cmo: kernel/term.cmi kernel/names.cmi kernel/mod_subst.cmi \ kernel/copcodes.cmo kernel/cbytecodes.cmi kernel/cemitcodes.cmi kernel/cemitcodes.cmx: kernel/term.cmx kernel/names.cmx kernel/mod_subst.cmx \ @@ -750,21 +753,25 @@ kernel/csymtable.cmx: kernel/vm.cmx kernel/term.cmx kernel/sign.cmx \ kernel/declarations.cmx kernel/cemitcodes.cmx kernel/cbytegen.cmx \ kernel/cbytecodes.cmx kernel/csymtable.cmi kernel/declarations.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \ - kernel/sign.cmi lib/rtree.cmi kernel/names.cmi kernel/mod_subst.cmi \ - kernel/cemitcodes.cmi kernel/cbytecodes.cmi kernel/declarations.cmi + kernel/sign.cmi lib/rtree.cmi kernel/retroknowledge.cmi kernel/names.cmi \ + kernel/mod_subst.cmi kernel/cemitcodes.cmi kernel/cbytecodes.cmi \ + kernel/declarations.cmi kernel/declarations.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \ - kernel/sign.cmx lib/rtree.cmx kernel/names.cmx kernel/mod_subst.cmx \ - kernel/cemitcodes.cmx kernel/cbytecodes.cmx kernel/declarations.cmi + kernel/sign.cmx lib/rtree.cmx kernel/retroknowledge.cmx kernel/names.cmx \ + kernel/mod_subst.cmx kernel/cemitcodes.cmx kernel/cbytecodes.cmx \ + kernel/declarations.cmi kernel/entries.cmo: kernel/univ.cmi kernel/term.cmi kernel/sign.cmi \ kernel/names.cmi kernel/entries.cmi kernel/entries.cmx: kernel/univ.cmx kernel/term.cmx kernel/sign.cmx \ kernel/names.cmx kernel/entries.cmi kernel/environ.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \ - kernel/sign.cmi kernel/pre_env.cmi kernel/names.cmi \ - kernel/declarations.cmi kernel/cbytegen.cmi kernel/environ.cmi + kernel/sign.cmi kernel/retroknowledge.cmi kernel/pre_env.cmi \ + kernel/names.cmi kernel/declarations.cmi kernel/cbytegen.cmi \ + kernel/cbytecodes.cmi kernel/environ.cmi kernel/environ.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \ - kernel/sign.cmx kernel/pre_env.cmx kernel/names.cmx \ - kernel/declarations.cmx kernel/cbytegen.cmx kernel/environ.cmi + kernel/sign.cmx kernel/retroknowledge.cmx kernel/pre_env.cmx \ + kernel/names.cmx kernel/declarations.cmx kernel/cbytegen.cmx \ + kernel/cbytecodes.cmx kernel/environ.cmi kernel/esubst.cmo: lib/util.cmi kernel/esubst.cmi kernel/esubst.cmx: lib/util.cmx kernel/esubst.cmi kernel/indtypes.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \ @@ -783,14 +790,6 @@ kernel/inductive.cmx: lib/util.cmx kernel/univ.cmx kernel/type_errors.cmx \ kernel/term.cmx kernel/sign.cmx kernel/reduction.cmx kernel/names.cmx \ kernel/environ.cmx kernel/declarations.cmx kernel/closure.cmx \ kernel/inductive.cmi -kernel/modops.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi lib/pp.cmi \ - kernel/names.cmi kernel/mod_subst.cmi kernel/environ.cmi \ - kernel/entries.cmi kernel/declarations.cmi kernel/cemitcodes.cmi \ - kernel/modops.cmi -kernel/modops.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx lib/pp.cmx \ - kernel/names.cmx kernel/mod_subst.cmx kernel/environ.cmx \ - kernel/entries.cmx kernel/declarations.cmx kernel/cemitcodes.cmx \ - kernel/modops.cmi kernel/mod_subst.cmo: lib/util.cmi kernel/term.cmi lib/pp.cmi \ kernel/names.cmi kernel/mod_subst.cmi kernel/mod_subst.cmx: lib/util.cmx kernel/term.cmx lib/pp.cmx \ @@ -805,16 +804,24 @@ kernel/mod_typing.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \ kernel/names.cmx kernel/modops.cmx kernel/mod_subst.cmx \ kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \ kernel/cemitcodes.cmx kernel/mod_typing.cmi +kernel/modops.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \ + kernel/retroknowledge.cmi lib/pp.cmi kernel/names.cmi \ + kernel/mod_subst.cmi kernel/environ.cmi kernel/entries.cmi \ + kernel/declarations.cmi kernel/cemitcodes.cmi kernel/modops.cmi +kernel/modops.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \ + kernel/retroknowledge.cmx lib/pp.cmx kernel/names.cmx \ + kernel/mod_subst.cmx kernel/environ.cmx kernel/entries.cmx \ + kernel/declarations.cmx kernel/cemitcodes.cmx kernel/modops.cmi kernel/names.cmo: lib/util.cmi lib/predicate.cmi lib/pp.cmi lib/hashcons.cmi \ kernel/names.cmi kernel/names.cmx: lib/util.cmx lib/predicate.cmx lib/pp.cmx lib/hashcons.cmx \ kernel/names.cmi kernel/pre_env.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \ - kernel/sign.cmi kernel/names.cmi kernel/declarations.cmi \ - kernel/pre_env.cmi + kernel/sign.cmi kernel/retroknowledge.cmi kernel/names.cmi \ + kernel/declarations.cmi kernel/pre_env.cmi kernel/pre_env.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \ - kernel/sign.cmx kernel/names.cmx kernel/declarations.cmx \ - kernel/pre_env.cmi + kernel/sign.cmx kernel/retroknowledge.cmx kernel/names.cmx \ + kernel/declarations.cmx kernel/pre_env.cmi kernel/reduction.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi \ kernel/sign.cmi kernel/names.cmi kernel/esubst.cmi kernel/environ.cmi \ kernel/declarations.cmi kernel/conv_oracle.cmi kernel/closure.cmi \ @@ -823,20 +830,24 @@ kernel/reduction.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx \ kernel/sign.cmx kernel/names.cmx kernel/esubst.cmx kernel/environ.cmx \ kernel/declarations.cmx kernel/conv_oracle.cmx kernel/closure.cmx \ kernel/reduction.cmi +kernel/retroknowledge.cmo: kernel/term.cmi kernel/names.cmi \ + kernel/cbytecodes.cmi kernel/retroknowledge.cmi +kernel/retroknowledge.cmx: kernel/term.cmx kernel/names.cmx \ + kernel/cbytecodes.cmx kernel/retroknowledge.cmi kernel/safe_typing.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \ kernel/type_errors.cmi kernel/term_typing.cmi kernel/term.cmi \ - kernel/subtyping.cmi kernel/sign.cmi kernel/reduction.cmi \ - kernel/names.cmi kernel/modops.cmi kernel/mod_typing.cmi \ - kernel/inductive.cmi kernel/indtypes.cmi kernel/environ.cmi \ - kernel/entries.cmi kernel/declarations.cmi kernel/cooking.cmi \ - kernel/safe_typing.cmi + kernel/subtyping.cmi kernel/sign.cmi kernel/retroknowledge.cmi \ + kernel/reduction.cmi kernel/names.cmi kernel/modops.cmi \ + kernel/mod_typing.cmi kernel/inductive.cmi kernel/indtypes.cmi \ + kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi \ + kernel/cooking.cmi kernel/safe_typing.cmi kernel/safe_typing.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \ kernel/type_errors.cmx kernel/term_typing.cmx kernel/term.cmx \ - kernel/subtyping.cmx kernel/sign.cmx kernel/reduction.cmx \ - kernel/names.cmx kernel/modops.cmx kernel/mod_typing.cmx \ - kernel/inductive.cmx kernel/indtypes.cmx kernel/environ.cmx \ - kernel/entries.cmx kernel/declarations.cmx kernel/cooking.cmx \ - kernel/safe_typing.cmi + kernel/subtyping.cmx kernel/sign.cmx kernel/retroknowledge.cmx \ + kernel/reduction.cmx kernel/names.cmx kernel/modops.cmx \ + kernel/mod_typing.cmx kernel/inductive.cmx kernel/indtypes.cmx \ + kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \ + kernel/cooking.cmx kernel/safe_typing.cmi kernel/sign.cmo: lib/util.cmi kernel/term.cmi kernel/names.cmi \ kernel/sign.cmi kernel/sign.cmx: lib/util.cmx kernel/term.cmx kernel/names.cmx \ @@ -905,10 +916,10 @@ lib/edit.cmo: lib/util.cmi lib/pp.cmi lib/bstack.cmi lib/edit.cmi lib/edit.cmx: lib/util.cmx lib/pp.cmx lib/bstack.cmx lib/edit.cmi lib/explore.cmo: lib/explore.cmi lib/explore.cmx: lib/explore.cmi -lib/gmapl.cmo: lib/util.cmi lib/gmap.cmi lib/gmapl.cmi -lib/gmapl.cmx: lib/util.cmx lib/gmap.cmx lib/gmapl.cmi lib/gmap.cmo: lib/gmap.cmi lib/gmap.cmx: lib/gmap.cmi +lib/gmapl.cmo: lib/util.cmi lib/gmap.cmi lib/gmapl.cmi +lib/gmapl.cmx: lib/util.cmx lib/gmap.cmx lib/gmapl.cmi lib/gset.cmo: lib/gset.cmi lib/gset.cmx: lib/gset.cmi lib/hashcons.cmo: lib/hashcons.cmi @@ -917,14 +928,24 @@ lib/heap.cmo: lib/heap.cmi lib/heap.cmx: lib/heap.cmi lib/options.cmo: lib/util.cmi lib/options.cmi lib/options.cmx: lib/util.cmx lib/options.cmi -lib/pp_control.cmo: lib/pp_control.cmi -lib/pp_control.cmx: lib/pp_control.cmi lib/pp.cmo: lib/pp_control.cmi lib/pp.cmi lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi +lib/pp_control.cmo: lib/pp_control.cmi +lib/pp_control.cmx: lib/pp_control.cmi lib/predicate.cmo: lib/predicate.cmi lib/predicate.cmx: lib/predicate.cmi lib/profile.cmo: lib/profile.cmi lib/profile.cmx: lib/profile.cmi +lib/rtree.cmo: lib/util.cmi lib/pp.cmi lib/rtree.cmi +lib/rtree.cmx: lib/util.cmx lib/pp.cmx lib/rtree.cmi +lib/system.cmo: lib/util.cmi lib/pp.cmi config/coq_config.cmi lib/system.cmi +lib/system.cmx: lib/util.cmx lib/pp.cmx config/coq_config.cmx lib/system.cmi +lib/tlm.cmo: lib/gset.cmi lib/gmap.cmi lib/tlm.cmi +lib/tlm.cmx: lib/gset.cmx lib/gmap.cmx lib/tlm.cmi +lib/util.cmo: lib/pp.cmi lib/compat.cmo lib/util.cmi +lib/util.cmx: lib/pp.cmx lib/compat.cmx lib/util.cmi +library/decl_kinds.cmo: lib/util.cmi +library/decl_kinds.cmx: lib/util.cmx library/declare.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \ kernel/type_errors.cmi kernel/term.cmi library/summary.cmi \ kernel/sign.cmi kernel/safe_typing.cmi kernel/reduction.cmi lib/pp.cmi \ @@ -957,8 +978,6 @@ library/declaremods.cmx: lib/util.cmx library/summary.cmx \ library/libobject.cmx library/libnames.cmx library/lib.cmx \ library/global.cmx kernel/environ.cmx kernel/entries.cmx \ kernel/declarations.cmx library/declaremods.cmi -library/decl_kinds.cmo: lib/util.cmi -library/decl_kinds.cmx: lib/util.cmx library/dischargedhypsmap.cmo: lib/util.cmi kernel/term.cmi \ library/summary.cmi kernel/reduction.cmi library/nametab.cmi \ kernel/names.cmi library/libobject.cmi library/libnames.cmi \ @@ -1030,10 +1049,10 @@ library/nameops.cmo: lib/util.cmi lib/pp.cmi kernel/names.cmi \ library/nameops.cmx: lib/util.cmx lib/pp.cmx kernel/names.cmx \ library/nameops.cmi library/nametab.cmo: lib/util.cmi library/summary.cmi lib/pp.cmi \ - kernel/names.cmi library/nameops.cmi library/libnames.cmi \ + lib/options.cmi kernel/names.cmi library/nameops.cmi library/libnames.cmi \ kernel/declarations.cmi library/nametab.cmi library/nametab.cmx: lib/util.cmx library/summary.cmx lib/pp.cmx \ - kernel/names.cmx library/nameops.cmx library/libnames.cmx \ + lib/options.cmx kernel/names.cmx library/nameops.cmx library/libnames.cmx \ kernel/declarations.cmx library/nametab.cmi library/states.cmo: lib/system.cmi library/summary.cmi library/library.cmi \ library/lib.cmi library/states.cmi @@ -1041,14 +1060,6 @@ library/states.cmx: lib/system.cmx library/summary.cmx library/library.cmx \ library/lib.cmx library/states.cmi library/summary.cmo: lib/util.cmi lib/pp.cmi lib/dyn.cmi library/summary.cmi library/summary.cmx: lib/util.cmx lib/pp.cmx lib/dyn.cmx library/summary.cmi -lib/rtree.cmo: lib/util.cmi lib/pp.cmi lib/rtree.cmi -lib/rtree.cmx: lib/util.cmx lib/pp.cmx lib/rtree.cmi -lib/system.cmo: lib/util.cmi lib/pp.cmi config/coq_config.cmi lib/system.cmi -lib/system.cmx: lib/util.cmx lib/pp.cmx config/coq_config.cmx lib/system.cmi -lib/tlm.cmo: lib/gset.cmi lib/gmap.cmi lib/tlm.cmi -lib/tlm.cmx: lib/gset.cmx lib/gmap.cmx lib/tlm.cmi -lib/util.cmo: lib/pp.cmi lib/compat.cmo lib/util.cmi -lib/util.cmx: lib/pp.cmx lib/compat.cmx lib/util.cmi parsing/argextend.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ parsing/q_util.cmi parsing/q_coqast.cmo parsing/pcoq.cmi \ interp/genarg.cmi @@ -1087,6 +1098,12 @@ parsing/g_decl_mode.cmo: interp/topconstr.cmi kernel/term.cmi \ parsing/g_decl_mode.cmx: interp/topconstr.cmx kernel/term.cmx \ parsing/pcoq.cmx kernel/names.cmx library/libnames.cmx interp/genarg.cmx \ proofs/decl_expr.cmi +parsing/g_intsyntax.cmo: lib/util.cmi pretyping/rawterm.cmi lib/pp.cmi \ + interp/notation.cmi kernel/names.cmi library/libnames.cmi lib/bigint.cmi \ + parsing/g_intsyntax.cmi +parsing/g_intsyntax.cmx: lib/util.cmx pretyping/rawterm.cmx lib/pp.cmx \ + interp/notation.cmx kernel/names.cmx library/libnames.cmx lib/bigint.cmx \ + parsing/g_intsyntax.cmi parsing/g_ltac.cmo: toplevel/vernacexpr.cmo lib/util.cmi interp/topconstr.cmi \ proofs/tacexpr.cmo pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi \ kernel/names.cmi @@ -1606,13 +1623,13 @@ pretyping/unification.cmx: lib/util.cmx pretyping/typing.cmx \ library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ kernel/environ.cmx pretyping/unification.cmi pretyping/vnorm.cmo: kernel/vm.cmi kernel/vconv.cmi lib/util.cmi \ - kernel/typeops.cmi kernel/term.cmi kernel/reduction.cmi kernel/names.cmi \ - kernel/inductive.cmi kernel/environ.cmi kernel/declarations.cmi \ - pretyping/vnorm.cmi + kernel/typeops.cmi kernel/term.cmi kernel/retroknowledge.cmi \ + kernel/reduction.cmi kernel/names.cmi kernel/inductive.cmi \ + kernel/environ.cmi kernel/declarations.cmi pretyping/vnorm.cmi pretyping/vnorm.cmx: kernel/vm.cmx kernel/vconv.cmx lib/util.cmx \ - kernel/typeops.cmx kernel/term.cmx kernel/reduction.cmx kernel/names.cmx \ - kernel/inductive.cmx kernel/environ.cmx kernel/declarations.cmx \ - pretyping/vnorm.cmi + kernel/typeops.cmx kernel/term.cmx kernel/retroknowledge.cmx \ + kernel/reduction.cmx kernel/names.cmx kernel/inductive.cmx \ + kernel/environ.cmx kernel/declarations.cmx pretyping/vnorm.cmi proofs/clenvtac.cmo: lib/util.cmi pretyping/unification.cmi \ pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \ proofs/tacmach.cmi proofs/tacexpr.cmo kernel/sign.cmi proofs/refiner.cmi \ @@ -1633,10 +1650,12 @@ proofs/clenvtac.cmx: lib/util.cmx pretyping/unification.cmx \ proofs/clenvtac.cmi proofs/decl_mode.cmo: lib/util.cmi kernel/term.cmi proofs/refiner.cmi \ proofs/proof_trees.cmi proofs/pfedit.cmi kernel/names.cmi \ - pretyping/evd.cmi lib/dyn.cmi proofs/decl_expr.cmi proofs/decl_mode.cmi + pretyping/evd.cmi kernel/environ.cmi lib/dyn.cmi proofs/decl_expr.cmi \ + proofs/decl_mode.cmi proofs/decl_mode.cmx: lib/util.cmx kernel/term.cmx proofs/refiner.cmx \ proofs/proof_trees.cmx proofs/pfedit.cmx kernel/names.cmx \ - pretyping/evd.cmx lib/dyn.cmx proofs/decl_expr.cmi proofs/decl_mode.cmi + pretyping/evd.cmx kernel/environ.cmx lib/dyn.cmx proofs/decl_expr.cmi \ + proofs/decl_mode.cmi proofs/evar_refiner.cmo: lib/util.cmi kernel/term.cmi kernel/sign.cmi \ proofs/refiner.cmi proofs/proof_trees.cmi pretyping/pretyping.cmi \ kernel/names.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ @@ -1832,29 +1851,31 @@ tactics/decl_interp.cmx: lib/util.cmx interp/topconstr.cmx \ proofs/decl_expr.cmi interp/coqlib.cmx interp/constrintern.cmx \ kernel/closure.cmx tactics/decl_interp.cmi tactics/decl_proof_instr.cmo: lib/util.cmi pretyping/unification.cmi \ - kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \ - tactics/tactics.cmi tactics/tacticals.cmi proofs/tacmach.cmi \ - tactics/tacinterp.cmi proofs/tacexpr.cmo proofs/refiner.cmi \ - pretyping/reductionops.cmi kernel/reduction.cmi pretyping/rawterm.cmi \ - proofs/proof_type.cmi proofs/proof_trees.cmi parsing/printer.cmi \ - lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi library/nameops.cmi \ - library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \ - library/goptions.cmi library/global.cmi interp/genarg.cmi \ - pretyping/evd.cmi kernel/environ.cmi kernel/declarations.cmi \ - proofs/decl_mode.cmi tactics/decl_interp.cmi proofs/decl_expr.cmi \ - interp/coqlib.cmi kernel/closure.cmi tactics/decl_proof_instr.cmi + pretyping/typing.cmi kernel/type_errors.cmi pretyping/termops.cmi \ + kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ + proofs/tacmach.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ + proofs/refiner.cmi pretyping/reductionops.cmi kernel/reduction.cmi \ + pretyping/rawterm.cmi proofs/proof_type.cmi proofs/proof_trees.cmi \ + parsing/printer.cmi lib/pp.cmi proofs/pfedit.cmi kernel/names.cmi \ + library/nameops.cmi library/libnames.cmi pretyping/inductiveops.cmi \ + kernel/inductive.cmi library/goptions.cmi library/global.cmi \ + interp/genarg.cmi pretyping/evd.cmi kernel/environ.cmi \ + kernel/declarations.cmi proofs/decl_mode.cmi tactics/decl_interp.cmi \ + proofs/decl_expr.cmi interp/coqlib.cmi kernel/closure.cmi \ + tactics/decl_proof_instr.cmi tactics/decl_proof_instr.cmx: lib/util.cmx pretyping/unification.cmx \ - kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \ - tactics/tactics.cmx tactics/tacticals.cmx proofs/tacmach.cmx \ - tactics/tacinterp.cmx proofs/tacexpr.cmx proofs/refiner.cmx \ - pretyping/reductionops.cmx kernel/reduction.cmx pretyping/rawterm.cmx \ - proofs/proof_type.cmx proofs/proof_trees.cmx parsing/printer.cmx \ - lib/pp.cmx proofs/pfedit.cmx kernel/names.cmx library/nameops.cmx \ - library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \ - library/goptions.cmx library/global.cmx interp/genarg.cmx \ - pretyping/evd.cmx kernel/environ.cmx kernel/declarations.cmx \ - proofs/decl_mode.cmx tactics/decl_interp.cmx proofs/decl_expr.cmi \ - interp/coqlib.cmx kernel/closure.cmx tactics/decl_proof_instr.cmi + pretyping/typing.cmx kernel/type_errors.cmx pretyping/termops.cmx \ + kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \ + proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ + proofs/refiner.cmx pretyping/reductionops.cmx kernel/reduction.cmx \ + pretyping/rawterm.cmx proofs/proof_type.cmx proofs/proof_trees.cmx \ + parsing/printer.cmx lib/pp.cmx proofs/pfedit.cmx kernel/names.cmx \ + library/nameops.cmx library/libnames.cmx pretyping/inductiveops.cmx \ + kernel/inductive.cmx library/goptions.cmx library/global.cmx \ + interp/genarg.cmx pretyping/evd.cmx kernel/environ.cmx \ + kernel/declarations.cmx proofs/decl_mode.cmx tactics/decl_interp.cmx \ + proofs/decl_expr.cmi interp/coqlib.cmx kernel/closure.cmx \ + tactics/decl_proof_instr.cmi tactics/dhyp.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \ tactics/tacticals.cmi proofs/tacmach.cmi proofs/tacexpr.cmo \ library/summary.cmi proofs/refiner.cmi kernel/reduction.cmi \ @@ -1969,16 +1990,16 @@ tactics/evar_tactics.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \ tactics/evar_tactics.cmi tactics/extraargs.cmo: lib/util.cmi tactics/tacticals.cmi \ tactics/tacinterp.cmi proofs/tacexpr.cmo tactics/setoid_replace.cmi \ - parsing/printer.cmi parsing/pptactic.cmi interp/ppextend.cmi \ - parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi kernel/names.cmi \ - library/nameops.cmi toplevel/metasyntax.cmi parsing/lexer.cmi \ - interp/genarg.cmi tactics/extraargs.cmi + kernel/retroknowledge.cmi parsing/printer.cmi parsing/pptactic.cmi \ + interp/ppextend.cmi parsing/ppconstr.cmi lib/pp.cmi parsing/pcoq.cmi \ + kernel/names.cmi library/nameops.cmi toplevel/metasyntax.cmi \ + parsing/lexer.cmi interp/genarg.cmi tactics/extraargs.cmi tactics/extraargs.cmx: lib/util.cmx tactics/tacticals.cmx \ tactics/tacinterp.cmx proofs/tacexpr.cmx tactics/setoid_replace.cmx \ - parsing/printer.cmx parsing/pptactic.cmx interp/ppextend.cmx \ - parsing/ppconstr.cmx lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx \ - library/nameops.cmx toplevel/metasyntax.cmx parsing/lexer.cmx \ - interp/genarg.cmx tactics/extraargs.cmi + kernel/retroknowledge.cmx parsing/printer.cmx parsing/pptactic.cmx \ + interp/ppextend.cmx parsing/ppconstr.cmx lib/pp.cmx parsing/pcoq.cmx \ + kernel/names.cmx library/nameops.cmx toplevel/metasyntax.cmx \ + parsing/lexer.cmx interp/genarg.cmx tactics/extraargs.cmi tactics/extratactics.cmo: toplevel/vernacinterp.cmi lib/util.cmi \ kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ tactics/tacinterp.cmi proofs/tacexpr.cmo library/summary.cmi \ @@ -1988,8 +2009,9 @@ tactics/extratactics.cmo: toplevel/vernacinterp.cmi lib/util.cmi \ library/libnames.cmi library/lib.cmi tactics/leminv.cmi tactics/inv.cmi \ library/global.cmi interp/genarg.cmi tactics/extraargs.cmi \ pretyping/evd.cmi tactics/evar_tactics.cmi tactics/equality.cmi \ - parsing/egrammar.cmi tactics/contradiction.cmi interp/constrintern.cmi \ - toplevel/cerrors.cmi tactics/autorewrite.cmi tactics/extratactics.cmi + kernel/environ.cmi parsing/egrammar.cmi tactics/contradiction.cmi \ + interp/constrintern.cmi toplevel/cerrors.cmi kernel/cbytegen.cmi \ + kernel/cbytecodes.cmi tactics/autorewrite.cmi tactics/extratactics.cmi tactics/extratactics.cmx: toplevel/vernacinterp.cmx lib/util.cmx \ kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \ tactics/tacinterp.cmx proofs/tacexpr.cmx library/summary.cmx \ @@ -1999,8 +2021,9 @@ tactics/extratactics.cmx: toplevel/vernacinterp.cmx lib/util.cmx \ library/libnames.cmx library/lib.cmx tactics/leminv.cmx tactics/inv.cmx \ library/global.cmx interp/genarg.cmx tactics/extraargs.cmx \ pretyping/evd.cmx tactics/evar_tactics.cmx tactics/equality.cmx \ - parsing/egrammar.cmx tactics/contradiction.cmx interp/constrintern.cmx \ - toplevel/cerrors.cmx tactics/autorewrite.cmx tactics/extratactics.cmi + kernel/environ.cmx parsing/egrammar.cmx tactics/contradiction.cmx \ + interp/constrintern.cmx toplevel/cerrors.cmx kernel/cbytegen.cmx \ + kernel/cbytecodes.cmx tactics/autorewrite.cmx tactics/extratactics.cmi tactics/hiddentac.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \ proofs/tacmach.cmi proofs/tacexpr.cmo proofs/refiner.cmi \ proofs/redexpr.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \ @@ -2266,12 +2289,12 @@ toplevel/command.cmo: toplevel/vernacexpr.cmo lib/util.cmi kernel/typeops.cmi \ toplevel/metasyntax.cmi proofs/logic.cmi library/library.cmi \ library/libobject.cmi library/libnames.cmi library/lib.cmi \ pretyping/inductiveops.cmi kernel/inductive.cmi kernel/indtypes.cmi \ - pretyping/indrec.cmi library/impargs.cmi library/global.cmi \ - pretyping/evd.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \ - kernel/environ.cmi kernel/entries.cmi library/declare.cmi \ - kernel/declarations.cmi library/decl_kinds.cmo interp/coqlib.cmi \ - interp/constrintern.cmi interp/constrextern.cmi toplevel/class.cmi \ - toplevel/command.cmi + pretyping/indrec.cmi library/impargs.cmi library/goptions.cmi \ + library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ + pretyping/evarconv.cmi kernel/environ.cmi kernel/entries.cmi \ + library/declare.cmi kernel/declarations.cmi library/decl_kinds.cmo \ + interp/coqlib.cmi interp/constrintern.cmi interp/constrextern.cmi \ + toplevel/class.cmi toplevel/command.cmi toplevel/command.cmx: toplevel/vernacexpr.cmx lib/util.cmx kernel/typeops.cmx \ interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \ proofs/tacmach.cmx interp/syntax_def.cmx library/states.cmx \ @@ -2283,12 +2306,12 @@ toplevel/command.cmx: toplevel/vernacexpr.cmx lib/util.cmx kernel/typeops.cmx \ toplevel/metasyntax.cmx proofs/logic.cmx library/library.cmx \ library/libobject.cmx library/libnames.cmx library/lib.cmx \ pretyping/inductiveops.cmx kernel/inductive.cmx kernel/indtypes.cmx \ - pretyping/indrec.cmx library/impargs.cmx library/global.cmx \ - pretyping/evd.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \ - kernel/environ.cmx kernel/entries.cmx library/declare.cmx \ - kernel/declarations.cmx library/decl_kinds.cmx interp/coqlib.cmx \ - interp/constrintern.cmx interp/constrextern.cmx toplevel/class.cmx \ - toplevel/command.cmi + pretyping/indrec.cmx library/impargs.cmx library/goptions.cmx \ + library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ + pretyping/evarconv.cmx kernel/environ.cmx kernel/entries.cmx \ + library/declare.cmx kernel/declarations.cmx library/decl_kinds.cmx \ + interp/coqlib.cmx interp/constrintern.cmx interp/constrextern.cmx \ + toplevel/class.cmx toplevel/command.cmi toplevel/coqinit.cmo: toplevel/vernac.cmi toplevel/toplevel.cmi \ lib/system.cmi lib/pp.cmi lib/options.cmi kernel/names.cmi \ library/nameops.cmi toplevel/mltop.cmi config/coq_config.cmi \ @@ -2415,6 +2438,16 @@ toplevel/toplevel.cmx: toplevel/vernacexpr.cmx toplevel/vernac.cmx \ toplevel/toplevel.cmi toplevel/usage.cmo: config/coq_config.cmi toplevel/usage.cmi toplevel/usage.cmx: config/coq_config.cmx toplevel/usage.cmi +toplevel/vernac.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \ + toplevel/vernacentries.cmi lib/util.cmi lib/system.cmi library/states.cmi \ + parsing/ppvernac.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \ + lib/options.cmi kernel/names.cmi library/library.cmi library/lib.cmi \ + parsing/lexer.cmi interp/constrintern.cmi toplevel/vernac.cmi +toplevel/vernac.cmx: toplevel/vernacinterp.cmx toplevel/vernacexpr.cmx \ + toplevel/vernacentries.cmx lib/util.cmx lib/system.cmx library/states.cmx \ + parsing/ppvernac.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \ + lib/options.cmx kernel/names.cmx library/library.cmx library/lib.cmx \ + parsing/lexer.cmx interp/constrintern.cmx toplevel/vernac.cmi toplevel/vernacentries.cmo: kernel/vm.cmi toplevel/vernacinterp.cmi \ toplevel/vernacexpr.cmo kernel/vconv.cmi lib/util.cmi kernel/univ.cmi \ kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \ @@ -2479,16 +2512,6 @@ toplevel/vernacinterp.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ tactics/tacinterp.cmx proofs/tacexpr.cmx proofs/proof_type.cmx lib/pp.cmx \ lib/options.cmx kernel/names.cmx library/libnames.cmx toplevel/himsg.cmx \ toplevel/vernacinterp.cmi -toplevel/vernac.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \ - toplevel/vernacentries.cmi lib/util.cmi lib/system.cmi library/states.cmi \ - parsing/ppvernac.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \ - lib/options.cmi kernel/names.cmi library/library.cmi library/lib.cmi \ - parsing/lexer.cmi interp/constrintern.cmi toplevel/vernac.cmi -toplevel/vernac.cmx: toplevel/vernacinterp.cmx toplevel/vernacexpr.cmx \ - toplevel/vernacentries.cmx lib/util.cmx lib/system.cmx library/states.cmx \ - parsing/ppvernac.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \ - lib/options.cmx kernel/names.cmx library/library.cmx library/lib.cmx \ - parsing/lexer.cmx interp/constrintern.cmx toplevel/vernac.cmi toplevel/whelp.cmo: toplevel/vernacinterp.cmi lib/util.cmi \ pretyping/termops.cmi kernel/term.cmi proofs/tacmach.cmi lib/system.cmi \ interp/syntax_def.cmi proofs/refiner.cmi pretyping/rawterm.cmi lib/pp.cmi \ @@ -2537,12 +2560,6 @@ contrib/cc/g_congruence.cmx: lib/util.cmx tactics/tactics.cmx \ tactics/tacticals.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx interp/genarg.cmx \ parsing/egrammar.cmx toplevel/cerrors.cmx contrib/cc/cctac.cmx -contrib/correctness/pcicenv.cmo: kernel/univ.cmi kernel/term.cmi \ - kernel/sign.cmi kernel/names.cmi library/global.cmi \ - contrib/correctness/pcicenv.cmi -contrib/correctness/pcicenv.cmx: kernel/univ.cmx kernel/term.cmx \ - kernel/sign.cmx kernel/names.cmx library/global.cmx \ - contrib/correctness/pcicenv.cmi contrib/correctness/pcic.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \ kernel/term.cmi kernel/sign.cmi toplevel/record.cmi pretyping/rawterm.cmi \ @@ -2557,6 +2574,12 @@ contrib/correctness/pcic.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ library/libnames.cmx kernel/indtypes.cmx library/global.cmx \ kernel/entries.cmx pretyping/detyping.cmx library/declare.cmx \ kernel/declarations.cmx contrib/correctness/pcic.cmi +contrib/correctness/pcicenv.cmo: kernel/univ.cmi kernel/term.cmi \ + kernel/sign.cmi kernel/names.cmi library/global.cmi \ + contrib/correctness/pcicenv.cmi +contrib/correctness/pcicenv.cmx: kernel/univ.cmx kernel/term.cmx \ + kernel/sign.cmx kernel/names.cmx library/global.cmx \ + contrib/correctness/pcicenv.cmi contrib/correctness/pdb.cmo: pretyping/termops.cmi kernel/term.cmi \ library/nametab.cmi kernel/names.cmi library/global.cmi \ interp/constrintern.cmi contrib/correctness/pdb.cmi @@ -3031,6 +3054,38 @@ contrib/funind/functional_principles_types.cmx: lib/util.cmx \ kernel/environ.cmx kernel/entries.cmx library/declare.cmx \ kernel/declarations.cmx library/decl_kinds.cmx toplevel/command.cmx \ kernel/closure.cmx contrib/funind/functional_principles_types.cmi +contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ + kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \ + kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ + proofs/tacmach.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ + library/states.cmi kernel/sign.cmi contrib/recdef/recdef.cmo \ + contrib/funind/rawterm_to_relation.cmi pretyping/rawterm.cmi \ + parsing/printer.cmi parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi \ + interp/notation.cmi kernel/names.cmi library/nameops.cmi \ + library/libnames.cmi contrib/funind/invfun.cmo pretyping/indrec.cmi \ + contrib/funind/indfun_common.cmi library/impargs.cmi \ + tactics/hiddentac.cmi library/global.cmi \ + contrib/funind/functional_principles_types.cmi \ + contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \ + tactics/equality.cmi kernel/environ.cmi kernel/declarations.cmi \ + library/decl_kinds.cmo interp/constrintern.cmi interp/constrextern.cmi \ + toplevel/command.cmi toplevel/cerrors.cmi +contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ + kernel/typeops.cmx interp/topconstr.cmx pretyping/termops.cmx \ + kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \ + proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ + library/states.cmx kernel/sign.cmx contrib/recdef/recdef.cmx \ + contrib/funind/rawterm_to_relation.cmx pretyping/rawterm.cmx \ + parsing/printer.cmx parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx \ + interp/notation.cmx kernel/names.cmx library/nameops.cmx \ + library/libnames.cmx contrib/funind/invfun.cmx pretyping/indrec.cmx \ + contrib/funind/indfun_common.cmx library/impargs.cmx \ + tactics/hiddentac.cmx library/global.cmx \ + contrib/funind/functional_principles_types.cmx \ + contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \ + tactics/equality.cmx kernel/environ.cmx kernel/declarations.cmx \ + library/decl_kinds.cmx interp/constrintern.cmx interp/constrextern.cmx \ + toplevel/command.cmx toplevel/cerrors.cmx contrib/funind/indfun_common.cmo: lib/util.cmi pretyping/termops.cmi \ kernel/term.cmi library/summary.cmi proofs/refiner.cmi \ pretyping/reductionops.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \ @@ -3079,38 +3134,6 @@ contrib/funind/indfun_main.cmx: toplevel/vernacinterp.cmx lib/util.cmx \ contrib/funind/functional_principles_types.cmx pretyping/evd.cmx \ parsing/egrammar.cmx interp/coqlib.cmx interp/constrintern.cmx \ toplevel/cerrors.cmx -contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ - kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \ - kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ - proofs/tacmach.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ - library/states.cmi kernel/sign.cmi contrib/recdef/recdef.cmo \ - contrib/funind/rawterm_to_relation.cmi pretyping/rawterm.cmi \ - parsing/printer.cmi parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi \ - interp/notation.cmi kernel/names.cmi library/nameops.cmi \ - library/libnames.cmi contrib/funind/invfun.cmo pretyping/indrec.cmi \ - contrib/funind/indfun_common.cmi library/impargs.cmi \ - tactics/hiddentac.cmi library/global.cmi \ - contrib/funind/functional_principles_types.cmi \ - contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \ - tactics/equality.cmi kernel/environ.cmi kernel/declarations.cmi \ - library/decl_kinds.cmo interp/constrintern.cmi interp/constrextern.cmi \ - toplevel/command.cmi toplevel/cerrors.cmi -contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ - kernel/typeops.cmx interp/topconstr.cmx pretyping/termops.cmx \ - kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \ - proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ - library/states.cmx kernel/sign.cmx contrib/recdef/recdef.cmx \ - contrib/funind/rawterm_to_relation.cmx pretyping/rawterm.cmx \ - parsing/printer.cmx parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx \ - interp/notation.cmx kernel/names.cmx library/nameops.cmx \ - library/libnames.cmx contrib/funind/invfun.cmx pretyping/indrec.cmx \ - contrib/funind/indfun_common.cmx library/impargs.cmx \ - tactics/hiddentac.cmx library/global.cmx \ - contrib/funind/functional_principles_types.cmx \ - contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \ - tactics/equality.cmx kernel/environ.cmx kernel/declarations.cmx \ - library/decl_kinds.cmx interp/constrintern.cmx interp/constrextern.cmx \ - toplevel/command.cmx toplevel/cerrors.cmx contrib/funind/invfun.cmo: toplevel/vernacentries.cmi lib/util.cmi \ pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \ tactics/tauto.cmo tactics/tactics.cmi tactics/tacticals.cmi \ @@ -3157,16 +3180,6 @@ contrib/funind/merge.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ pretyping/evd.cmx kernel/environ.cmx pretyping/detyping.cmx \ kernel/declarations.cmx interp/constrintern.cmx interp/constrextern.cmx \ toplevel/command.cmx -contrib/funind/rawtermops.cmo: lib/util.cmi kernel/term.cmi \ - pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \ - library/libnames.cmi pretyping/inductiveops.cmi \ - contrib/funind/indfun_common.cmi library/global.cmi pretyping/evd.cmi \ - interp/coqlib.cmi contrib/funind/rawtermops.cmi -contrib/funind/rawtermops.cmx: lib/util.cmx kernel/term.cmx \ - pretyping/rawterm.cmx lib/pp.cmx kernel/names.cmx library/nameops.cmx \ - library/libnames.cmx pretyping/inductiveops.cmx \ - contrib/funind/indfun_common.cmx library/global.cmx pretyping/evd.cmx \ - interp/coqlib.cmx contrib/funind/rawtermops.cmi contrib/funind/rawterm_to_relation.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ pretyping/typing.cmi interp/topconstr.cmi pretyping/termops.cmi \ kernel/term.cmi tactics/tacinterp.cmi lib/system.cmi kernel/sign.cmi \ @@ -3191,6 +3204,16 @@ contrib/funind/rawterm_to_relation.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ pretyping/detyping.cmx kernel/declarations.cmx interp/coqlib.cmx \ interp/constrextern.cmx toplevel/command.cmx toplevel/cerrors.cmx \ contrib/funind/rawterm_to_relation.cmi +contrib/funind/rawtermops.cmo: lib/util.cmi kernel/term.cmi \ + pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \ + library/libnames.cmi pretyping/inductiveops.cmi \ + contrib/funind/indfun_common.cmi library/global.cmi pretyping/evd.cmi \ + interp/coqlib.cmi contrib/funind/rawtermops.cmi +contrib/funind/rawtermops.cmx: lib/util.cmx kernel/term.cmx \ + pretyping/rawterm.cmx lib/pp.cmx kernel/names.cmx library/nameops.cmx \ + library/libnames.cmx pretyping/inductiveops.cmx \ + contrib/funind/indfun_common.cmx library/global.cmx pretyping/evd.cmx \ + interp/coqlib.cmx contrib/funind/rawtermops.cmi contrib/funind/tacinvutils.cmo: lib/util.cmi pretyping/termops.cmi \ kernel/term.cmi kernel/sign.cmi pretyping/reductionops.cmi \ parsing/printer.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \ @@ -3365,14 +3388,6 @@ contrib/interface/pbp.cmx: lib/util.cmx pretyping/typing.cmx \ proofs/logic.cmx library/libnames.cmx tactics/hipattern.cmx \ library/global.cmx interp/genarg.cmx pretyping/evd.cmx kernel/environ.cmx \ interp/coqlib.cmx contrib/interface/pbp.cmi -contrib/interface/showproof_ct.cmo: contrib/interface/xlate.cmi \ - contrib/interface/vtp.cmi contrib/interface/translate.cmi \ - parsing/printer.cmi lib/pp.cmi toplevel/metasyntax.cmi library/global.cmi \ - contrib/interface/ascent.cmi -contrib/interface/showproof_ct.cmx: contrib/interface/xlate.cmx \ - contrib/interface/vtp.cmx contrib/interface/translate.cmx \ - parsing/printer.cmx lib/pp.cmx toplevel/metasyntax.cmx library/global.cmx \ - contrib/interface/ascent.cmi contrib/interface/showproof.cmo: toplevel/vernacinterp.cmi lib/util.cmi \ pretyping/typing.cmi kernel/typeops.cmi contrib/interface/translate.cmi \ pretyping/termops.cmi kernel/term.cmi proofs/tacmach.cmi \ @@ -3395,6 +3410,14 @@ contrib/interface/showproof.cmx: toplevel/vernacinterp.cmx lib/util.cmx \ interp/genarg.cmx pretyping/evd.cmx kernel/environ.cmx \ kernel/declarations.cmx interp/constrintern.cmx pretyping/clenv.cmx \ contrib/interface/showproof.cmi +contrib/interface/showproof_ct.cmo: contrib/interface/xlate.cmi \ + contrib/interface/vtp.cmi contrib/interface/translate.cmi \ + parsing/printer.cmi lib/pp.cmi toplevel/metasyntax.cmi library/global.cmi \ + contrib/interface/ascent.cmi +contrib/interface/showproof_ct.cmx: contrib/interface/xlate.cmx \ + contrib/interface/vtp.cmx contrib/interface/translate.cmx \ + parsing/printer.cmx lib/pp.cmx toplevel/metasyntax.cmx library/global.cmx \ + contrib/interface/ascent.cmi contrib/interface/translate.cmo: contrib/interface/xlate.cmi \ contrib/interface/vtp.cmi toplevel/vernacinterp.cmi lib/util.cmi \ kernel/term.cmi proofs/tacmach.cmi kernel/sign.cmi proofs/proof_type.cmi \ @@ -3693,6 +3716,38 @@ contrib/subtac/g_subtac.cmx: toplevel/vernacinterp.cmx \ kernel/reduction.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \ kernel/names.cmx library/nameops.cmx library/libnames.cmx \ interp/genarg.cmx parsing/egrammar.cmx toplevel/cerrors.cmx +contrib/subtac/subtac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ + kernel/typeops.cmi kernel/type_errors.cmi pretyping/termops.cmi \ + kernel/term.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ + contrib/subtac/subtac_utils.cmi contrib/subtac/subtac_pretyping.cmi \ + contrib/subtac/subtac_errors.cmi contrib/subtac/subtac_command.cmi \ + contrib/subtac/subtac_coercion.cmi kernel/sign.cmi \ + pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \ + parsing/printer.cmi pretyping/pretype_errors.cmi parsing/ppconstr.cmi \ + lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi lib/options.cmi \ + library/nametab.cmi kernel/names.cmi library/library.cmi \ + library/libnames.cmi library/lib.cmi toplevel/himsg.cmi \ + library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ + pretyping/evarconv.cmi contrib/subtac/eterm.cmi kernel/environ.cmi \ + lib/dyn.cmi pretyping/detyping.cmi library/decl_kinds.cmo \ + interp/coqlib.cmi contrib/subtac/context.cmi toplevel/command.cmi \ + pretyping/classops.cmi toplevel/cerrors.cmi contrib/subtac/subtac.cmi +contrib/subtac/subtac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ + kernel/typeops.cmx kernel/type_errors.cmx pretyping/termops.cmx \ + kernel/term.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ + contrib/subtac/subtac_utils.cmx contrib/subtac/subtac_pretyping.cmx \ + contrib/subtac/subtac_errors.cmx contrib/subtac/subtac_command.cmx \ + contrib/subtac/subtac_coercion.cmx kernel/sign.cmx \ + pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \ + parsing/printer.cmx pretyping/pretype_errors.cmx parsing/ppconstr.cmx \ + lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx lib/options.cmx \ + library/nametab.cmx kernel/names.cmx library/library.cmx \ + library/libnames.cmx library/lib.cmx toplevel/himsg.cmx \ + library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ + pretyping/evarconv.cmx contrib/subtac/eterm.cmx kernel/environ.cmx \ + lib/dyn.cmx pretyping/detyping.cmx library/decl_kinds.cmx \ + interp/coqlib.cmx contrib/subtac/context.cmx toplevel/command.cmx \ + pretyping/classops.cmx toplevel/cerrors.cmx contrib/subtac/subtac.cmi contrib/subtac/subtac_cases.cmo: lib/util.cmi kernel/typeops.cmi \ kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \ contrib/subtac/subtac_utils.cmi kernel/sign.cmi pretyping/retyping.cmi \ @@ -3797,76 +3852,26 @@ contrib/subtac/subtac_interp_fixpoint.cmx: lib/util.cmx kernel/typeops.cmx \ contrib/subtac/eterm.cmx kernel/environ.cmx lib/dyn.cmx interp/coqlib.cmx \ contrib/subtac/context.cmx pretyping/classops.cmx \ contrib/subtac/subtac_interp_fixpoint.cmi -contrib/subtac/subtac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ - kernel/typeops.cmi kernel/type_errors.cmi pretyping/termops.cmi \ - kernel/term.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ - contrib/subtac/subtac_utils.cmi contrib/subtac/subtac_pretyping.cmi \ - contrib/subtac/subtac_errors.cmi contrib/subtac/subtac_command.cmi \ - contrib/subtac/subtac_coercion.cmi kernel/sign.cmi \ - pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \ - parsing/printer.cmi pretyping/pretype_errors.cmi parsing/ppconstr.cmi \ - lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi lib/options.cmi \ - library/nametab.cmi kernel/names.cmi library/library.cmi \ - library/libnames.cmi library/lib.cmi toplevel/himsg.cmi \ - library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ - pretyping/evarconv.cmi contrib/subtac/eterm.cmi kernel/environ.cmi \ - lib/dyn.cmi pretyping/detyping.cmi library/decl_kinds.cmo \ - interp/coqlib.cmi contrib/subtac/context.cmi toplevel/command.cmi \ - pretyping/classops.cmi toplevel/cerrors.cmi contrib/subtac/subtac.cmi -contrib/subtac/subtac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ - kernel/typeops.cmx kernel/type_errors.cmx pretyping/termops.cmx \ - kernel/term.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ - contrib/subtac/subtac_utils.cmx contrib/subtac/subtac_pretyping.cmx \ - contrib/subtac/subtac_errors.cmx contrib/subtac/subtac_command.cmx \ - contrib/subtac/subtac_coercion.cmx kernel/sign.cmx \ - pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \ - parsing/printer.cmx pretyping/pretype_errors.cmx parsing/ppconstr.cmx \ - lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx lib/options.cmx \ - library/nametab.cmx kernel/names.cmx library/library.cmx \ - library/libnames.cmx library/lib.cmx toplevel/himsg.cmx \ - library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ - pretyping/evarconv.cmx contrib/subtac/eterm.cmx kernel/environ.cmx \ - lib/dyn.cmx pretyping/detyping.cmx library/decl_kinds.cmx \ - interp/coqlib.cmx contrib/subtac/context.cmx toplevel/command.cmx \ - pretyping/classops.cmx toplevel/cerrors.cmx contrib/subtac/subtac.cmi contrib/subtac/subtac_obligations.cmo: lib/util.cmi pretyping/termops.cmi \ kernel/term.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ library/summary.cmi contrib/subtac/subtac_utils.cmi proofs/refiner.cmi \ pretyping/reductionops.cmi proofs/proof_type.cmi parsing/ppconstr.cmi \ lib/pp.cmi proofs/pfedit.cmi lib/options.cmi kernel/names.cmi \ - library/libobject.cmi library/libnames.cmi library/global.cmi \ - pretyping/evd.cmi kernel/environ.cmi kernel/entries.cmi \ - library/declare.cmi library/decl_kinds.cmo toplevel/command.cmi \ - tactics/auto.cmi contrib/subtac/subtac_obligations.cmi + library/libobject.cmi library/libnames.cmi library/lib.cmi \ + library/global.cmi pretyping/evd.cmi kernel/environ.cmi \ + kernel/entries.cmi library/declare.cmi library/decl_kinds.cmo \ + toplevel/command.cmi tactics/auto.cmi \ + contrib/subtac/subtac_obligations.cmi contrib/subtac/subtac_obligations.cmx: lib/util.cmx pretyping/termops.cmx \ kernel/term.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ library/summary.cmx contrib/subtac/subtac_utils.cmx proofs/refiner.cmx \ pretyping/reductionops.cmx proofs/proof_type.cmx parsing/ppconstr.cmx \ lib/pp.cmx proofs/pfedit.cmx lib/options.cmx kernel/names.cmx \ - library/libobject.cmx library/libnames.cmx library/global.cmx \ - pretyping/evd.cmx kernel/environ.cmx kernel/entries.cmx \ - library/declare.cmx library/decl_kinds.cmx toplevel/command.cmx \ - tactics/auto.cmx contrib/subtac/subtac_obligations.cmi -contrib/subtac/subtac_pretyping_F.cmo: lib/util.cmi kernel/typeops.cmi \ - kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \ - contrib/subtac/subtac_cases.cmi kernel/sign.cmi pretyping/retyping.cmi \ - pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \ - pretyping/pretyping.cmi pretyping/pretype_errors.cmi lib/pp.cmi \ - pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \ - library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \ - pretyping/evd.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \ - kernel/environ.cmi lib/dyn.cmi kernel/declarations.cmi \ - pretyping/coercion.cmi pretyping/classops.cmi -contrib/subtac/subtac_pretyping_F.cmx: lib/util.cmx kernel/typeops.cmx \ - kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \ - contrib/subtac/subtac_cases.cmx kernel/sign.cmx pretyping/retyping.cmx \ - pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \ - pretyping/pretyping.cmx pretyping/pretype_errors.cmx lib/pp.cmx \ - pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \ - library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \ - pretyping/evd.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \ - kernel/environ.cmx lib/dyn.cmx kernel/declarations.cmx \ - pretyping/coercion.cmx pretyping/classops.cmx + library/libobject.cmx library/libnames.cmx library/lib.cmx \ + library/global.cmx pretyping/evd.cmx kernel/environ.cmx \ + kernel/entries.cmx library/declare.cmx library/decl_kinds.cmx \ + toplevel/command.cmx tactics/auto.cmx \ + contrib/subtac/subtac_obligations.cmi contrib/subtac/subtac_pretyping.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ kernel/typeops.cmi kernel/type_errors.cmi interp/topconstr.cmi \ pretyping/termops.cmi kernel/term.cmi contrib/subtac/subtac_utils.cmi \ @@ -3895,6 +3900,26 @@ contrib/subtac/subtac_pretyping.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ kernel/environ.cmx lib/dyn.cmx interp/coqlib.cmx \ contrib/subtac/context.cmx interp/constrintern.cmx toplevel/command.cmx \ pretyping/classops.cmx contrib/subtac/subtac_pretyping.cmi +contrib/subtac/subtac_pretyping_F.cmo: lib/util.cmi kernel/typeops.cmi \ + kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \ + contrib/subtac/subtac_cases.cmi kernel/sign.cmi pretyping/retyping.cmi \ + pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \ + pretyping/pretyping.cmi pretyping/pretype_errors.cmi lib/pp.cmi \ + pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \ + library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \ + pretyping/evd.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \ + kernel/environ.cmi lib/dyn.cmi kernel/declarations.cmi \ + pretyping/coercion.cmi pretyping/classops.cmi +contrib/subtac/subtac_pretyping_F.cmx: lib/util.cmx kernel/typeops.cmx \ + kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \ + contrib/subtac/subtac_cases.cmx kernel/sign.cmx pretyping/retyping.cmx \ + pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \ + pretyping/pretyping.cmx pretyping/pretype_errors.cmx lib/pp.cmx \ + pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \ + library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \ + pretyping/evd.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \ + kernel/environ.cmx lib/dyn.cmx kernel/declarations.cmx \ + pretyping/coercion.cmx pretyping/classops.cmx contrib/subtac/subtac_utils.cmo: lib/util.cmi interp/topconstr.cmi \ pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \ tactics/tacticals.cmi proofs/tacexpr.cmo kernel/reduction.cmi \ @@ -3915,12 +3940,18 @@ contrib/subtac/subtac_utils.cmx: lib/util.cmx interp/topconstr.cmx \ pretyping/evarutil.cmx kernel/entries.cmx library/decl_kinds.cmx \ interp/coqlib.cmx interp/constrextern.cmx toplevel/command.cmx \ contrib/subtac/subtac_utils.cmi +contrib/xml/acic.cmo: kernel/term.cmi kernel/names.cmi +contrib/xml/acic.cmx: kernel/term.cmx kernel/names.cmx contrib/xml/acic2Xml.cmo: contrib/xml/xml.cmi lib/util.cmi kernel/term.cmi \ kernel/names.cmi contrib/xml/cic2acic.cmo contrib/xml/acic.cmo contrib/xml/acic2Xml.cmx: contrib/xml/xml.cmx lib/util.cmx kernel/term.cmx \ kernel/names.cmx contrib/xml/cic2acic.cmx contrib/xml/acic.cmx -contrib/xml/acic.cmo: kernel/term.cmi kernel/names.cmi -contrib/xml/acic.cmx: kernel/term.cmx kernel/names.cmx +contrib/xml/cic2Xml.cmo: contrib/xml/xml.cmi contrib/xml/unshare.cmi \ + tactics/tacinterp.cmi contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \ + contrib/xml/acic.cmo +contrib/xml/cic2Xml.cmx: contrib/xml/xml.cmx contrib/xml/unshare.cmx \ + tactics/tacinterp.cmx contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx \ + contrib/xml/acic.cmx contrib/xml/cic2acic.cmo: lib/util.cmi contrib/xml/unshare.cmi \ kernel/univ.cmi kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi \ pretyping/reductionops.cmi parsing/printer.cmi lib/pp.cmi \ @@ -3939,12 +3970,6 @@ contrib/xml/cic2acic.cmx: lib/util.cmx contrib/xml/unshare.cmx \ kernel/environ.cmx contrib/xml/doubleTypeInference.cmx \ library/dischargedhypsmap.cmx library/declare.cmx kernel/declarations.cmx \ contrib/xml/acic.cmx -contrib/xml/cic2Xml.cmo: contrib/xml/xml.cmi contrib/xml/unshare.cmi \ - tactics/tacinterp.cmi contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \ - contrib/xml/acic.cmo -contrib/xml/cic2Xml.cmx: contrib/xml/xml.cmx contrib/xml/unshare.cmx \ - tactics/tacinterp.cmx contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx \ - contrib/xml/acic.cmx contrib/xml/doubleTypeInference.cmo: lib/util.cmi contrib/xml/unshare.cmi \ kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi \ pretyping/retyping.cmi pretyping/reductionops.cmi kernel/reduction.cmi \ @@ -3985,6 +4010,8 @@ contrib/xml/proofTree2Xml.cmx: contrib/xml/xml.cmx lib/util.cmx \ contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx contrib/xml/acic.cmx contrib/xml/unshare.cmo: contrib/xml/unshare.cmi contrib/xml/unshare.cmx: contrib/xml/unshare.cmi +contrib/xml/xml.cmo: contrib/xml/xml.cmi +contrib/xml/xml.cmx: contrib/xml/xml.cmi contrib/xml/xmlcommand.cmo: contrib/xml/xml.cmi toplevel/vernac.cmi \ lib/util.cmi contrib/xml/unshare.cmi kernel/typeops.cmi kernel/term.cmi \ proofs/tacmach.cmi pretyping/recordops.cmi proofs/proof_trees.cmi \ @@ -4015,14 +4042,12 @@ contrib/xml/xmlentries.cmx: contrib/xml/xmlcommand.cmx \ toplevel/vernacinterp.cmx lib/util.cmx lib/pp.cmx parsing/pcoq.cmx \ parsing/lexer.cmx interp/genarg.cmx parsing/extend.cmx \ parsing/egrammar.cmx toplevel/cerrors.cmx -contrib/xml/xml.cmo: contrib/xml/xml.cmi -contrib/xml/xml.cmx: contrib/xml/xml.cmi -doc/refman/euclid.cmo: doc/refman/euclid.cmi -doc/refman/euclid.cmx: doc/refman/euclid.cmi -doc/refman/heapsort.cmo: doc/refman/heapsort.cmi -doc/refman/heapsort.cmx: doc/refman/heapsort.cmi ide/utils/config_file.cmo: ide/utils/config_file.cmi ide/utils/config_file.cmx: ide/utils/config_file.cmi +ide/utils/configwin.cmo: ide/utils/configwin_types.cmo \ + ide/utils/configwin_ihm.cmo ide/utils/configwin.cmi +ide/utils/configwin.cmx: ide/utils/configwin_types.cmx \ + ide/utils/configwin_ihm.cmx ide/utils/configwin.cmi ide/utils/configwin_html_config.cmo: ide/utils/configwin_types.cmo \ ide/utils/configwin_messages.cmo ide/utils/configwin_ihm.cmo \ ide/utils/config_file.cmi @@ -4033,10 +4058,6 @@ ide/utils/configwin_ihm.cmo: ide/utils/okey.cmi ide/utils/configwin_types.cmo \ ide/utils/configwin_messages.cmo ide/utils/config_file.cmi ide/utils/configwin_ihm.cmx: ide/utils/okey.cmx ide/utils/configwin_types.cmx \ ide/utils/configwin_messages.cmx ide/utils/config_file.cmx -ide/utils/configwin.cmo: ide/utils/configwin_types.cmo \ - ide/utils/configwin_ihm.cmo ide/utils/configwin.cmi -ide/utils/configwin.cmx: ide/utils/configwin_types.cmx \ - ide/utils/configwin_ihm.cmx ide/utils/configwin.cmi ide/utils/configwin_types.cmo: ide/utils/configwin_keys.cmo \ ide/utils/config_file.cmi ide/utils/configwin_types.cmx: ide/utils/configwin_keys.cmx \ @@ -4175,7 +4196,8 @@ coq_fix_code.o: kernel/byterun/coq_fix_code.c \ kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h coq_interp.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \ kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ - kernel/byterun/coq_memory.h kernel/byterun/coq_values.h + kernel/byterun/coq_memory.h kernel/byterun/coq_values.h \ + kernel/byterun/int64_emul.h coq_memory.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \ kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ kernel/byterun/coq_memory.h kernel/byterun/coq_interp.h @@ -130,10 +130,12 @@ BYTERUN=\ KERNEL=\ kernel/names.cmo kernel/univ.cmo \ - kernel/esubst.cmo kernel/term.cmo kernel/mod_subst.cmo kernel/sign.cmo \ + kernel/esubst.cmo kernel/term.cmo \ + kernel/mod_subst.cmo kernel/sign.cmo \ kernel/cbytecodes.cmo kernel/copcodes.cmo \ kernel/cemitcodes.cmo kernel/vm.cmo \ - kernel/declarations.cmo kernel/pre_env.cmo \ + kernel/declarations.cmo \ + kernel/retroknowledge.cmo kernel/pre_env.cmo \ kernel/cbytegen.cmo kernel/environ.cmo \ kernel/csymtable.cmo kernel/conv_oracle.cmo \ kernel/closure.cmo kernel/reduction.cmo kernel/type_errors.cmo \ @@ -187,7 +189,7 @@ HIGHPARSING=\ parsing/g_proofs.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo \ parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo \ parsing/g_ascii_syntax.cmo parsing/g_string_syntax.cmo \ - parsing/g_decl_mode.cmo + parsing/g_decl_mode.cmo parsing/g_intsyntax.cmo TACTICS=\ tactics/dn.cmo tactics/termdn.cmo tactics/btermdn.cmo \ @@ -904,6 +906,26 @@ ZARITHVO=\ theories/ZArith/Znumtheory.vo theories/ZArith/Int.vo \ theories/ZArith/Zpow_def.vo +INTSVO=\ + theories/Ints/Z/IntsZmisc.vo theories/Ints/Z/Pmod.vo \ + theories/Ints/Tactic.vo theories/Ints/Z/ZAux.vo \ + theories/Ints/Z/ZPowerAux.vo theories/Ints/Z/ZDivModAux.vo \ + theories/Ints/Z/Zmod.vo \ + theories/Ints/Basic_type.vo theories/Ints/Int31.vo \ + theories/Ints/num/GenBase.vo theories/Ints/num/ZnZ.vo \ + theories/Ints/num/GenAdd.vo theories/Ints/num/GenSub.vo \ + theories/Ints/num/GenMul.vo theories/Ints/num/GenDivn1.vo \ + theories/Ints/num/GenDiv.vo theories/Ints/num/GenSqrt.vo \ + theories/Ints/num/GenLift.vo theories/Ints/num/Zn2Z.vo\ + theories/Ints/num/Nbasic.vo theories/Ints/num/NMake.vo \ + theories/Ints/BigN.vo +# theories/Ints/List/ListAux.vo +# theories/Ints/List/LPermutation.vo theories/Ints/List/Iterator.vo \ +# theories/Ints/List/ZProgression.vo +# theories/Ints/Z/ZSum.vo theories/Ints/Z/Ppow.vo \ +# spiwack : should use the genN.ml to create NMake eventually +# arnaud : see above + QARITHVO=\ theories/QArith/QArith_base.vo theories/QArith/Qreduction.vo \ theories/QArith/Qring.vo theories/QArith/Qreals.vo \ @@ -1028,7 +1050,8 @@ SETOIDSVO=theories/Setoids/Setoid.vo THEORIESVO =\ $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) $(NARITHVO) $(ZARITHVO) \ $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) $(INTMAPVO) \ - $(RELATIONSVO) $(WELLFOUNDEDVO) $(REALSVO) $(SORTINGVO) $(QARITHVO) + $(RELATIONSVO) $(WELLFOUNDEDVO) $(REALSVO) $(SORTINGVO) $(QARITHVO) \ + $(INTSVO) THEORIESLIGHTVO = $(INITVO) $(LOGICVO) $(ARITHVO) @@ -1049,6 +1072,7 @@ allfsets: $(ALLFSETS) intmap: $(INTMAPVO) relations: $(RELATIONSVO) wellfounded: $(WELLFOUNDEDVO) +ints: $(INTSVO) # reals reals: $(REALSVO) allreals: $(ALLREALS) @@ -1153,6 +1177,7 @@ contrib/%.vo: contrib/%.v states/initial.coq $(VO_TOOLS_DEP) cleantheories: rm -f states/*.coq rm -f theories/*/*.vo + rm -f theories/*/*/*.vo clean :: cleantheories @@ -1167,6 +1192,7 @@ archclean:: glob.dump:: rm -f glob.dump rm -f theories/*/*.vo + rm -f theories/*/*/*.vo $(MAKE) GLOB="-dump-glob glob.dump" world ########################################################################### @@ -1424,7 +1450,8 @@ GRAMMARNEEDEDCMO=\ kernel/names.cmo kernel/univ.cmo \ kernel/esubst.cmo kernel/term.cmo kernel/mod_subst.cmo kernel/sign.cmo \ kernel/cbytecodes.cmo kernel/copcodes.cmo kernel/cemitcodes.cmo \ - kernel/declarations.cmo kernel/pre_env.cmo \ + kernel/declarations.cmo \ + kernel/retroknowledge.cmo kernel/pre_env.cmo \ kernel/cbytegen.cmo kernel/conv_oracle.cmo kernel/environ.cmo \ kernel/closure.cmo kernel/reduction.cmo kernel/type_errors.cmo\ kernel/entries.cmo \ @@ -1457,7 +1484,9 @@ PRINTERSCMO=\ config/coq_config.cmo lib/lib.cma \ kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo kernel/term.cmo \ kernel/mod_subst.cmo kernel/copcodes.cmo kernel/cemitcodes.cmo \ - kernel/sign.cmo kernel/declarations.cmo kernel/pre_env.cmo \ + kernel/sign.cmo kernel/declarations.cmo kernel/retroknowledge.cmo \ + kernel/pre_env.cmo \ + kernel/retroknowledge.cmo kernel/pre_env.cmo \ kernel/cbytecodes.cmo kernel/cbytegen.cmo kernel/environ.cmo \ kernel/conv_oracle.cmo kernel/closure.cmo kernel/reduction.cmo \ kernel/modops.cmo kernel/type_errors.cmo kernel/inductive.cmo \ diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml index eb5c27450..519565888 100644 --- a/contrib/extraction/modutil.ml +++ b/contrib/extraction/modutil.ml @@ -49,7 +49,10 @@ let rec subst_module sub mb = mod_type=mtb'; mod_user_type=mtb''; mod_equiv=mpo'; - mod_constraints=mb.mod_constraints } + mod_constraints=mb.mod_constraints; + mod_retroknowledge=[] } (* spiwack: since I'm lazy and it's unused at + this point. I forget about retroknowledge, + this may need a change later *) and subst_meb sub = function | MEBident mp -> MEBident (subst_mp sub mp) diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index affcccb3a..961c49785 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -8,6 +8,9 @@ /* */ /***********************************************************************/ +/* Arnaud Spiwack: expanded the virtual machine with operators used + for fast computation of bounded (31bits) integers */ + #include <stdio.h> #include <stdlib.h> #include <config.h> @@ -37,7 +40,12 @@ void init_arity () { arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= - arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= 0; + arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= + arity[ADDINT31]=arity[ADDCINT31]=arity[ADDCARRYCINT31]= + arity[SUBINT31]=arity[SUBCINT31]=arity[SUBCARRYCINT31]= + arity[MULCINT31]=arity[MULINT31]=arity[COMPAREINT31]= + arity[DIV21INT31]=arity[DIVINT31]=arity[ADDMULDIVINT31]= + arity[COMPINT31]=arity[DECOMPINT31]=0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= @@ -45,9 +53,11 @@ void init_arity () { arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]= arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= - arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=arity[ACCUMULATECOND]= 1; + arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=arity[ACCUMULATECOND]= + arity[BRANCH]=arity[ISCONST]= 1; /* instruction with two operands */ - arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]=2; + arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= + arity[ARECONST]=2; /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; /* instruction with arbitrary operands */ diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h index d1dac80fb..003453183 100644 --- a/kernel/byterun/coq_fix_code.h +++ b/kernel/byterun/coq_fix_code.h @@ -31,4 +31,5 @@ value coq_makeaccu (value i); value coq_pushpop (value i); value coq_accucond (value i); value coq_is_accumulate_code(value code); + #endif /* _COQ_FIX_CODE_ */ diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h index 89616c5f3..00156ebe8 100644 --- a/kernel/byterun/coq_instruct.h +++ b/kernel/byterun/coq_instruct.h @@ -35,7 +35,17 @@ enum instructions { CONST0, CONST1, CONST2, CONST3, CONSTINT, PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, ACCUMULATE, ACCUMULATECOND, - MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, STOP + MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, +/* spiwack: */ + BRANCH, + ADDINT31, ADDCINT31, ADDCARRYCINT31, + SUBINT31, SUBCINT31, SUBCARRYCINT31, + MULCINT31, MULINT31, DIV21INT31, DIVINT31, + ADDMULDIVINT31, COMPAREINT31, + ISCONST, ARECONST, + COMPINT31, DECOMPINT31, +/* /spiwack */ + STOP }; #endif /* _COQ_INSTRUCT_ */ diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 8f9c10e68..c3072dc72 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -10,12 +10,31 @@ /* The bytecode interpreter */ +/* Spiwack: expanded the virtual machine with operators used + for fast computation of bounded (31bits) integers */ + #include <stdio.h> #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" -#include "coq_memory.h" -#include "coq_values.h" +#include "coq_memory.h" +#include "coq_values.h" + +/*spiwack : imports support functions for 64-bit integers */ +#include "config.h" +#ifdef ARCH_INT64_TYPE +#include "int64_native.h" +#else +#include "int64_emul.h" +#endif + +/* spiwack: I append here a few macros for value/number manipulation */ +#define uint32_of_value(val) (((uint32)val >> 1)) +#define value_of_uint32(i) ((value)(((uint32)i << 1) | 1)) +#define UI64_of_uint32(i) ((uint64)I64_literal(0,i)) +#define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) +/* /spiwack */ + /* Registers for the abstract machine: @@ -61,13 +80,6 @@ sp is a local copy of the global variable extern_sp. */ # define print_int(i) #endif -/* Wrapper pour caml_modify */ -#ifdef OCAML_307 -#define CAML_MODIFY(a,b) modify(a,b) -#else -#define CAML_MODIFY(a,b) caml_modify(a,b) -#endif - /* GC interface */ #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } @@ -640,7 +652,7 @@ value coq_interprete Field(accu, 0) = sp[0]; *sp = accu; /* mise a jour du block accumulate */ - CAML_MODIFY(&Field(p[i], 1),*sp); + caml_modify(&Field(p[i], 1),*sp); sp++; } pc += nfunc; @@ -811,7 +823,7 @@ value coq_interprete Instruct(SETFIELD0){ print_instr("SETFIELD0"); - CAML_MODIFY(&Field(accu, 0),*sp); + caml_modify(&Field(accu, 0),*sp); sp++; Next; } @@ -819,7 +831,7 @@ value coq_interprete Instruct(SETFIELD1){ int i, j, size, size_aux; print_instr("SETFIELD1"); - CAML_MODIFY(&Field(accu, 1),*sp); + caml_modify(&Field(accu, 1),*sp); sp++; Next; } @@ -848,7 +860,7 @@ value coq_interprete Instruct(SETFIELD){ print_instr("SETFIELD"); - CAML_MODIFY(&Field(accu, *pc),*sp); + caml_modify(&Field(accu, *pc),*sp); sp++; pc++; Next; } @@ -1035,7 +1047,285 @@ value coq_interprete sp += 2; Next; } - + + /* spiwack: code for interpreting compiled integers */ + Instruct(BRANCH) { + /* unconditional branching */ + print_instr("BRANCH"); + pc += *pc; + /* pc = (code_t)(pc+*pc); */ + Next; + } + + Instruct(ADDINT31) { + /* Adds the integer in the accumulator with + the one ontop of the stack (which is poped)*/ + print_instr("ADDINT31"); + accu = + (value)((uint32) accu + (uint32) *sp++ - 1); + /* nota,unlike CaML we don't want + to have a different behavior depending on the + architecture. Thus we cast the operand to uint32 */ + Next; + } + + Instruct (ADDCINT31) { + print_instr("ADDCINT31"); + /* returns the sum with a carry */ + uint32 s; + s = (uint32)accu + (uint32)*sp++ - 1; + if( (uint32)s < (uint32)accu ) { + /* carry */ + Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ + } + else { + /*no carry */ + Alloc_small(accu, 1, 1); + } + Field(accu, 0)=(value)s; + Next; + } + + Instruct (ADDCARRYCINT31) { + print_instr("ADDCARRYCINT31"); + /* returns the sum plus one with a carry */ + uint32 s; + s = (uint32)accu + (uint32)*sp++ + 1; + value block; + if( (uint32)s <= (uint32)accu ) { + /* carry */ + Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ + } + else { + /*no carry */ + Alloc_small(accu, 1, 1); + } + Field(accu, 0)=(value)s; + Next; + } + + Instruct (SUBINT31) { + print_instr("SUBINT31"); + /* returns the subtraction */ + accu = + (value)((uint32) accu - (uint32) *sp++ + 1); + Next; + } + + Instruct (SUBCINT31) { + print_instr("SUBCINT31"); + /* returns the subtraction with a carry */ + uint32 b; + uint32 s; + b = (uint32)*sp++; + s = (uint32)accu - b + 1; + if( (uint32)accu < b ) { + /* carry */ + Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ + } + else { + /*no carry */ + Alloc_small(accu, 1, 1); + } + Field(accu, 0)=(value)s; + Next; + } + + Instruct (SUBCARRYCINT31) { + print_instr("SUBCARRYCINT31"); + /* returns the subtraction minus one with a carry */ + uint32 b; + uint32 s; + b = (uint32)*sp++; + s = (value)((uint32)accu - b - 1); + if( (uint32)accu <= b ) { + /* carry */ + Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ + } + else { + /*no carry */ + Alloc_small(accu, 1, 1); + } + Field(accu, 0)=(value)s; + Next; + } + + Instruct (MULINT31) { + /* returns the multiplication */ + print_instr("MULINT31"); + accu = + value_of_uint32((uint32_of_value(accu)) * (uint32_of_value(*sp++))); + Next; + } + + Instruct (MULCINT31) { + /*returns the multiplication on a double size word + (special case for 0) */ + print_instr("MULCINT31"); + uint64 p; + /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */ + p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); + if ( I64_is_zero(p) ) { + accu = (value)1; + } + else { + /* the output type is supposed to have a constant constructor + and a non-constant constructor (in that order), the tag + of the non-constant constructor is then 1 */ + Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ + /*unsigned shift*/ + Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; /*higher part*/ + Field(accu, 1) = (value)(I64_to_int32(p)|1); /*lower part*/ + } + Next; + } + + Instruct (DIV21INT31) { + print_instr("DIV21INT31"); + /* spiwack: takes three int31 (the two first ones represent an + int62) and perfoms the euclidian division of the + int62 by the int31 */ + uint64 bigint; + bigint = UI64_of_value(accu); + bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); + uint64 divisor; + divisor = UI64_of_value(*sp++); + Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ + if (I64_is_zero (divisor)) { + Field(accu, 0) = 1; /* 2*0+1 */ + Field(accu, 1) = 1; /* 2*0+1 */ + } + else { + uint64 quo, mod; + I64_udivmod(bigint, divisor, &quo, &mod); + Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); + Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); + } + Next; + } + + Instruct (DIVINT31) { + print_instr("DIVINT31"); + /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag + since it probably only concerns negative number. + needs to be checked at this point */ + uint32 divisor; + divisor = uint32_of_value(*sp++); + if (divisor == 0) { + Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ + Field(accu, 0) = 1; /* 2*0+1 */ + Field(accu, 1) = 1; /* 2*0+1 */ + } + else { + uint32 modulus; + modulus = uint32_of_value(accu); + Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ + Field(accu, 0) = value_of_uint32(modulus/divisor); + Field(accu, 1) = value_of_uint32(modulus%divisor); + } + Next; + } + + Instruct (ADDMULDIVINT31) { + print_instr("ADDMULDIVINT31"); + /* higher level shift (does shifts and cycles and such) */ + uint32 shiftby; + shiftby = uint32_of_value(accu); + /* *sp = 2*x+1 --> accu = 2^(shiftby+1)*x */ + accu = (value)(((*sp++)^1) << shiftby); + /* accu = 2^(shiftby+1)*x --> 2^(shifby+1)*x+2*y/2^(31-shiftby)+1 */ + accu = (value)((accu | ((*sp++) >> (31-shiftby)))|1); + Next; + } + + Instruct (COMPAREINT31) { + /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ + /* assumes Inudctive _ : _ := Eq | Lt | Gt */ + print_instr("COMPAREINT31"); + if ((uint32)accu == (uint32)*sp) { + accu = 1; /* 2*0+1 */ + sp++; + } + else{if ((uint32)accu < (uint32)(*sp++)) { + accu = 3; /* 2*1+1 */ + } + else{ + accu = 5; /* 2*2+1 */ + }} + Next; + } + + Instruct (ISCONST) { + /* Branches if the accu does not contain a constant + (i.e., a non-block value) */ + print_instr("ISCONST"); + if ((accu & 1) == 0) /* last bit is 0 -> it is a block */ + pc += *pc; + else + pc++; + Next; + + } + + Instruct (ARECONST) { + /* Branches if the n first values on the stack are not + all constansts */ + print_instr("ARECONST"); + int i, n, ok; + ok = 1; + n = *pc++; + for(i=0; i < n; i++) { + if ((sp[i] & 1) == 0) { + ok = 0; + break; + } + } + if(ok) pc++; else pc += *pc; + Next; + } + + Instruct (COMPINT31) { + /* makes an 31-bit integer out of the accumulator and + the 30 first values of the stack + and put it in the accumulator (the accumulator then the + topmost get to be the heavier bits) */ + print_instr("COMPINT31"); + int i; + /*accu=accu or accu = (value)((unsigned long)1-accu) if bool + is used for the bits */ + for(i=0; i < 30; i++) { + accu = (value) ((((uint32)accu-1) << 1) | *sp++); + /* -1 removes the tag bit, << 1 multiplies the value by 2, + | *sp++ pops the last value and add it (no carry involved) + not that it reintroduces a tag bit */ + /* alternative, if bool is used for the bits : + accu = (value) ((((unsigned long)accu) << 1) & !*sp++); */ + } + Next; + } + + Instruct (DECOMPINT31) { + /* builds a block out of a 31-bit integer (from the accumulator), + used before cases */ + int i; + value block; + print_instr("DECOMPINT31"); + Alloc_small(block, 31, 1); // Alloc_small(*, size, tag) + for(i = 30; i >= 0; i--) { + Field(block, i) = (value)(accu & 3); /* two last bits of the accumulator */ + //Field(block, i) = 3; + accu = (value) ((uint32)accu >> 1) | 1; /* last bit must be a one */ + }; + accu = block; + Next; + } + + + + /* /spiwack */ + + + /* Debugging and machine control */ Instruct(STOP){ diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h new file mode 100644 index 000000000..ba8a60149 --- /dev/null +++ b/kernel/byterun/int64_emul.h @@ -0,0 +1,272 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: int64_emul.h,v 1.5 2005/09/22 14:21:50 xleroy Exp $ */ + +/* Software emulation of 64-bit integer arithmetic, for C compilers + that do not support it. */ + +#ifndef CAML_INT64_EMUL_H +#define CAML_INT64_EMUL_H + +#include <math.h> + +#ifdef ARCH_BIG_ENDIAN +#define I64_literal(hi,lo) { hi, lo } +#else +#define I64_literal(hi,lo) { lo, hi } +#endif + +/* Unsigned comparison */ +static int I64_ucompare(uint64 x, uint64 y) +{ + if (x.h > y.h) return 1; + if (x.h < y.h) return -1; + if (x.l > y.l) return 1; + if (x.l < y.l) return -1; + return 0; +} + +#define I64_ult(x, y) (I64_ucompare(x, y) < 0) + +/* Signed comparison */ +static int I64_compare(int64 x, int64 y) +{ + if ((int32)x.h > (int32)y.h) return 1; + if ((int32)x.h < (int32)y.h) return -1; + if (x.l > y.l) return 1; + if (x.l < y.l) return -1; + return 0; +} + +/* Negation */ +static int64 I64_neg(int64 x) +{ + int64 res; + res.l = -x.l; + res.h = ~x.h; + if (res.l == 0) res.h++; + return res; +} + +/* Addition */ +static int64 I64_add(int64 x, int64 y) +{ + int64 res; + res.l = x.l + y.l; + res.h = x.h + y.h; + if (res.l < x.l) res.h++; + return res; +} + +/* Subtraction */ +static int64 I64_sub(int64 x, int64 y) +{ + int64 res; + res.l = x.l - y.l; + res.h = x.h - y.h; + if (x.l < y.l) res.h--; + return res; +} + +/* Multiplication */ +static int64 I64_mul(int64 x, int64 y) +{ + int64 res; + uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); + uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); + uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); + uint32 prod11 = (x.l >> 16) * (y.l >> 16); + res.l = prod00; + res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); + prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; + prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; + res.h += x.l * y.h + x.h * y.l; + return res; +} + +#define I64_is_zero(x) (((x).l | (x).h) == 0) + +#define I64_is_negative(x) ((int32) (x).h < 0) + +/* Bitwise operations */ +static int64 I64_and(int64 x, int64 y) +{ + int64 res; + res.l = x.l & y.l; + res.h = x.h & y.h; + return res; +} + +static int64 I64_or(int64 x, int64 y) +{ + int64 res; + res.l = x.l | y.l; + res.h = x.h | y.h; + return res; +} + +static int64 I64_xor(int64 x, int64 y) +{ + int64 res; + res.l = x.l ^ y.l; + res.h = x.h ^ y.h; + return res; +} + +/* Shifts */ +static int64 I64_lsl(int64 x, int s) +{ + int64 res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = x.l << s; + res.h = (x.h << s) | (x.l >> (32 - s)); + } else { + res.l = 0; + res.h = x.l << (s - 32); + } + return res; +} + +static int64 I64_lsr(int64 x, int s) +{ + int64 res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = (x.l >> s) | (x.h << (32 - s)); + res.h = x.h >> s; + } else { + res.l = x.h >> (s - 32); + res.h = 0; + } + return res; +} + +static int64 I64_asr(int64 x, int s) +{ + int64 res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = (x.l >> s) | (x.h << (32 - s)); + res.h = (int32) x.h >> s; + } else { + res.l = (int32) x.h >> (s - 32); + res.h = (int32) x.h >> 31; + } + return res; +} + +/* Division and modulus */ + +#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 +#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 + +static void I64_udivmod(uint64 modulus, uint64 divisor, + uint64 * quo, uint64 * mod) +{ + int64 quotient, mask; + int cmp; + + quotient.h = 0; quotient.l = 0; + mask.h = 0; mask.l = 1; + while ((int32) divisor.h >= 0) { + cmp = I64_ucompare(divisor, modulus); + I64_SHL1(divisor); + I64_SHL1(mask); + if (cmp >= 0) break; + } + while (mask.l | mask.h) { + if (I64_ucompare(modulus, divisor) >= 0) { + quotient.h |= mask.h; quotient.l |= mask.l; + modulus = I64_sub(modulus, divisor); + } + I64_SHR1(mask); + I64_SHR1(divisor); + } + *quo = quotient; + *mod = modulus; +} + +static int64 I64_div(int64 x, int64 y) +{ + int64 q, r; + int32 sign; + + sign = x.h ^ y.h; + if ((int32) x.h < 0) x = I64_neg(x); + if ((int32) y.h < 0) y = I64_neg(y); + I64_udivmod(x, y, &q, &r); + if (sign < 0) q = I64_neg(q); + return q; +} + +static int64 I64_mod(int64 x, int64 y) +{ + int64 q, r; + int32 sign; + + sign = x.h; + if ((int32) x.h < 0) x = I64_neg(x); + if ((int32) y.h < 0) y = I64_neg(y); + I64_udivmod(x, y, &q, &r); + if (sign < 0) r = I64_neg(r); + return r; +} + +/* Coercions */ + +static int64 I64_of_int32(int32 x) +{ + int64 res; + res.l = x; + res.h = x >> 31; + return res; +} + +#define I64_to_int32(x) ((int32) (x).l) + +/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise + autoconfiguration would have selected native 64-bit integers */ +#define I64_of_intnat I64_of_int32 +#define I64_to_intnat I64_to_int32 + +static double I64_to_double(int64 x) +{ + double res; + int32 sign = x.h; + if (sign < 0) x = I64_neg(x); + res = ldexp((double) x.h, 32) + x.l; + if (sign < 0) res = -res; + return res; +} + +static int64 I64_of_double(double f) +{ + int64 res; + double frac, integ; + int neg; + + neg = (f < 0); + f = fabs(f); + frac = modf(ldexp(f, -32), &integ); + res.h = (uint32) integ; + res.l = (uint32) ldexp(frac, 32); + if (neg) res = I64_neg(res); + return res; +} + +#endif /* CAML_INT64_EMUL_H */ diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h new file mode 100644 index 000000000..2341e9989 --- /dev/null +++ b/kernel/byterun/int64_native.h @@ -0,0 +1,50 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: int64_native.h,v 1.5 2005/09/22 14:21:50 xleroy Exp $ */ + +/* Wrapper macros around native 64-bit integer arithmetic, + so that it has the same interface as the software emulation + provided in int64_emul.h */ + +#ifndef CAML_INT64_NATIVE_H +#define CAML_INT64_NATIVE_H + +#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) +#define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) +#define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) +#define I64_neg(x) (-(x)) +#define I64_add(x,y) ((x) + (y)) +#define I64_sub(x,y) ((x) - (y)) +#define I64_mul(x,y) ((x) * (y)) +#define I64_is_zero(x) ((x) == 0) +#define I64_is_negative(x) ((x) < 0) +#define I64_div(x,y) ((x) / (y)) +#define I64_mod(x,y) ((x) % (y)) +#define I64_udivmod(x,y,quo,rem) \ + (*(rem) = (uint64)(x) % (uint64)(y), \ + *(quo) = (uint64)(x) / (uint64)(y)) +#define I64_and(x,y) ((x) & (y)) +#define I64_or(x,y) ((x) | (y)) +#define I64_xor(x,y) ((x) ^ (y)) +#define I64_lsl(x,y) ((x) << (y)) +#define I64_asr(x,y) ((x) >> (y)) +#define I64_lsr(x,y) ((uint64)(x) >> (y)) +#define I64_to_intnat(x) ((intnat) (x)) +#define I64_of_intnat(x) ((intnat) (x)) +#define I64_to_int32(x) ((int32) (x)) +#define I64_of_int32(x) ((int64) (x)) +#define I64_to_double(x) ((double)(x)) +#define I64_of_double(x) ((int64)(x)) + +#endif /* CAML_INT64_NATIVE_H */ diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index a9b16f29c..ee8cb1eea 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -17,6 +17,7 @@ type structured_constant = | Const_b0 of tag | Const_bn of tag * structured_constant array + type reloc_table = (tag * int) array type annot_switch = @@ -63,6 +64,40 @@ type instruction = | Ksetfield of int | Kstop | Ksequence of bytecodes * bytecodes +(* spiwack: instructions concerning integers *) + | Kbranch of Label.t (* jump to label *) + | Kaddint31 (* adds the int31 in the accu + and the one ontop of the stack *) + | Kaddcint31 (* makes the sum and keeps the carry *) + | Kaddcarrycint31 (* sum +1, keeps the carry *) + | Ksubint31 (* subtraction modulo *) + | Ksubcint31 (* subtraction, keeps the carry *) + | Ksubcarrycint31 (* subtraction -1, keeps the carry *) + | Kmulint31 (* multiplication modulo *) + | Kmulcint31 (* multiplication, result in two + int31, for exact computation *) + | Kdiv21int31 (* divides a double size integer + (represented by an int31 in the + accumulator and one on the top of + the stack) by an int31. The result + is a pair of the quotient and the + rest. + If the divisor is 0, it returns + 0. *) + | Kdivint31 (* euclidian division (returns a pair + quotient,rest) *) + | Kaddmuldivint31 (* generic operation for shifting and + cycling. Takes 3 int31 i j and s, + and returns x*2^s+y/(2^(31-s) *) + | Kcompareint31 (* unsigned comparison of int31 + cf COMPAREINT31 in + kernel/byterun/coq_interp.c + for more info *) + | Kisconst of Label.t (* conditional jump *) + | Kareconst of int*Label.t (* conditional jump *) + | Kcompint31 (* dynamic compilation of int31 *) + | Kdecompint31 (* dynamic decompilation of int31 *) +(* /spiwack *) and bytecodes = instruction list @@ -70,6 +105,31 @@ type fv_elem = FVnamed of identifier | FVrel of int type fv = fv_elem array +(* spiwack: this exception is expected to be raised by function expecting + closed terms. *) +exception NotClosed + + +(*spiwack: both type have been moved from Cbytegen because I needed then + for the retroknowledge *) +type vm_env = { + size : int; (* longueur de la liste [n] *) + fv_rev : fv_elem list (* [fvn; ... ;fv1] *) + } + + +type comp_env = { + nb_stack : int; (* nbre de variables sur la pile *) + in_stack : int list; (* position dans la pile *) + nb_rec : int; (* nbre de fonctions mutuellement *) + (* recursives = nbr *) + pos_rec : instruction list; (* instruction d'acces pour les variables *) + (* de point fix ou de cofix *) + offset : int; + in_env : vm_env ref + } + + (* --- Pretty print *) open Format @@ -123,6 +183,27 @@ let rec instruction ppf = function | Kstop -> fprintf ppf "\tstop" | Ksequence (c1,c2) -> fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 +(* spiwack *) + | Kbranch lbl -> fprintf ppf "\tbranch %i" lbl + | Kaddint31 -> fprintf ppf "\taddint31" + | Kaddcint31 -> fprintf ppf "\taddcint31" + | Kaddcarrycint31 -> fprintf ppf "\taddcarrycint31" + | Ksubint31 -> fprintf ppf "\tsubint31" + | Ksubcint31 -> fprintf ppf "\tsubcint31" + | Ksubcarrycint31 -> fprintf ppf "\tsubcarrycint31" + | Kmulint31 -> fprintf ppf "\tmulint31" + | Kmulcint31 -> fprintf ppf "\tmulcint31" + | Kdiv21int31 -> fprintf ppf "\tdiv21int31" + | Kdivint31 -> fprintf ppf "\tdivint31" + | Kcompareint31 -> fprintf ppf "\tcompareint31" + | Kaddmuldivint31 -> fprintf ppf "\taddmuldivint31" + | Kisconst lbl -> fprintf ppf "\tisconst %i" lbl + | Kareconst(n,lbl) -> fprintf ppf "\tareconst %i %i" n lbl + | Kcompint31 -> fprintf ppf "\tcompint31" + | Kdecompint31 -> fprintf ppf "\tdecompint" + +(* /spiwack *) + and instruction_list ppf = function [] -> () @@ -130,6 +211,26 @@ and instruction_list ppf = function fprintf ppf "L%i:%a" lbl instruction_list il | instr :: il -> fprintf ppf "%a@ %a" instruction instr instruction_list il + + +(*spiwack: moved this type in this file because I needed it for + retroknowledge which can't depend from cbytegen *) +type block = + | Bconstr of constr + | Bstrconst of structured_constant + | Bmakeblock of int * block array + | Bconstruct_app of int * int * int * block array + (* tag , nparams, arity *) + | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array + (* spiwack: compilation given by a function *) + (* compilation function (see get_vm_constant_dynamic_info in + retroknowledge.mli for more info) , argument array *) + + let draw_instr c = fprintf std_formatter "@[<v 0>%a@]" instruction_list c + +let string_of_instr c = + fprintf str_formatter "@[<v 0>%a@]" instruction_list c; + flush_str_formatter () diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 215b6ad4a..a2d4f7e01 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -61,6 +61,40 @@ type instruction = | Ksetfield of int | Kstop | Ksequence of bytecodes * bytecodes +(* spiwack: instructions concerning integers *) + | Kbranch of Label.t (* jump to label, is it needed ? *) + | Kaddint31 (* adds the int31 in the accu + and the one ontop of the stack *) + | Kaddcint31 (* makes the sum and keeps the carry *) + | Kaddcarrycint31 (* sum +1, keeps the carry *) + | Ksubint31 (* subtraction modulo *) + | Ksubcint31 (* subtraction, keeps the carry *) + | Ksubcarrycint31 (* subtraction -1, keeps the carry *) + | Kmulint31 (* multiplication modulo *) + | Kmulcint31 (* multiplication, result in two + int31, for exact computation *) + | Kdiv21int31 (* divides a double size integer + (represented by an int31 in the + accumulator and one on the top of + the stack) by an int31. The result + is a pair of the quotient and the + rest. + If the divisor is 0, it returns + 0. *) + | Kdivint31 (* euclidian division (returns a pair + quotient,rest) *) + | Kaddmuldivint31 (* generic operation for shifting and + cycling. Takes 3 int31 i j and s, + and returns x*2^s+y/(2^(31-s) *) + | Kcompareint31 (* unsigned comparison of int31 + cf COMPAREINT31 in + kernel/byterun/coq_interp.c + for more info *) + | Kisconst of Label.t (* conditional jump *) + | Kareconst of int*Label.t (* conditional jump *) + | Kcompint31 (* dynamic compilation of int31 *) + | Kdecompint31 (* dynamix decompilation of int31 *) +(* /spiwack *) and bytecodes = instruction list @@ -69,5 +103,43 @@ type fv_elem = FVnamed of identifier | FVrel of int type fv = fv_elem array + +(* spiwack: this exception is expected to be raised by function expecting + closed terms. *) +exception NotClosed + +(*spiwack: both type have been moved from Cbytegen because I needed then + for the retroknowledge *) +type vm_env = { + size : int; (* longueur de la liste [n] *) + fv_rev : fv_elem list (* [fvn; ... ;fv1] *) + } + + +type comp_env = { + nb_stack : int; (* nbre de variables sur la pile *) + in_stack : int list; (* position dans la pile *) + nb_rec : int; (* nbre de fonctions mutuellement *) + (* recursives = nbr *) + pos_rec : instruction list; (* instruction d'acces pour les variables *) + (* de point fix ou de cofix *) + offset : int; + in_env : vm_env ref + } + val draw_instr : bytecodes -> unit +val string_of_instr : bytecodes -> string + + + +(*spiwack: moved this here because I needed it for retroknowledge *) +type block = + | Bconstr of constr + | Bstrconst of structured_constant + | Bmakeblock of int * block array + | Bconstruct_app of int * int * int * block array + (* tag , nparams, arity *) + | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array + (* compilation function (see get_vm_constant_dynamic_info in + retroknowledge.mli for more info) , argument array *) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index e1f89fadb..2664abe1f 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -83,24 +83,9 @@ open Pre_env (* On conserve la fct de cofix pour la conversion *) -type vm_env = { - size : int; (* longueur de la liste [n] *) - fv_rev : fv_elem list (* [fvn; ... ;fv1] *) - } - + let empty_fv = { size= 0; fv_rev = [] } - -type comp_env = { - nb_stack : int; (* nbre de variables sur la pile *) - in_stack : int list; (* position dans la pile *) - nb_rec : int; (* nbre de fonctions mutuellement *) - (* recursives = nbr *) - pos_rec : instruction list; (* instruction d'acces pour les variables *) - (* de point fix ou de cofix *) - offset : int; - in_env : vm_env ref - } - + let fv r = !(r.in_env) let empty_comp_env ()= @@ -231,17 +216,40 @@ let rec discard_dead_code cont = cont let label_code = function | Klabel lbl :: _ as cont -> (lbl, cont) + | Kbranch lbl :: _ as cont -> (lbl, cont) | cont -> let lbl = Label.create() in (lbl, Klabel lbl :: cont) (* Return a branch to the continuation. That is, an instruction that, when executed, branches to the continuation or performs what the continuation performs. We avoid generating branches to returns. *) - +(* spiwack: make_branch was only used once. Changed it back to the ZAM + one to match the appropriate semantics (old one avoided the + introduction of an unconditional branch operation, which seemed + appropriate for the 31-bit integers' code). As a memory, I leave + the former version in this comment. let make_branch cont = match cont with | (Kreturn _ as return) :: cont' -> return, cont' | Klabel lbl as b :: _ -> b, cont | _ -> let b = Klabel(Label.create()) in b,b::cont +*) + +let rec make_branch_2 lbl n cont = + function + Kreturn m :: _ -> (Kreturn (n + m), cont) + | Klabel _ :: c -> make_branch_2 lbl n cont c + | Kpop m :: c -> make_branch_2 lbl (n + m) cont c + | _ -> + match lbl with + Some lbl -> (Kbranch lbl, cont) + | None -> let lbl = Label.create() in (Kbranch lbl, Klabel lbl :: cont) + +let make_branch cont = + match cont with + (Kbranch _ as branch) :: _ -> (branch, cont) + | (Kreturn _ as return) :: _ -> (return, cont) + | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont + | _ -> make_branch_2 (None) 0 cont cont (* Check if we're in tailcall position *) @@ -315,52 +323,105 @@ let code_construct tag nparams arity cont = fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont -type block = - | Bconstr of constr - | Bstrconst of structured_constant - | Bmakeblock of int * block array - | Bconstruct_app of int * int * int * block array - (* tag , nparams, arity *) - let get_strcst = function | Bstrconst sc -> sc | _ -> raise Not_found -let rec str_const c = + +let rec str_const c = match kind_of_term c with | Sort s -> Bstrconst (Const_sorts s) | Cast(c,_,_) -> str_const c | App(f,args) -> begin match kind_of_term f with - | Construct((kn,j),i) -> + | Construct(((kn,j),i) as cstr) -> + begin let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in let num,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in if nparams + arity = Array.length args then - if arity = 0 then Bstrconst(Const_b0 num) - else - let rargs = Array.sub args nparams arity in - let b_args = Array.map str_const rargs in - try - let sc_args = Array.map get_strcst b_args in - Bstrconst(Const_bn(num, sc_args)) - with Not_found -> - Bmakeblock(num,b_args) + (* spiwack: *) + (* 1/ tries to compile the constructor in an optimal way, + it is supposed to work only if the arguments are + all fully constructed, fails with Cbytecodes.NotClosed. + it can also raise Not_found when there is no special + treatment for this constructor + for instance: tries to to compile an integer of the + form I31 D1 D2 ... D31 to [D1D2...D31] as + a processor number (a caml number actually) *) + try + try + Bstrconst (Retroknowledge.get_vm_constant_static_info + (!global_env).retroknowledge + (kind_of_term f) args) + with NotClosed -> + (* 2/ if the arguments are not all closed (this is + expectingly (and it is currently the case) the only + reason why this exception is raised) tries to + give a clever, run-time behavior to the constructor. + Raises Not_found if there is no special treatment + for this integer. + this is done in a lazy fashion, using the constructor + Bspecial because it needs to know the continuation + and such, which can't be done at this time. + for instance, for int31: if one of the digit is + not closed, it's not impossible that the number + gets fully instanciated at run-time, thus to ensure + uniqueness of the representation in the vm + it is necessary to try and build a caml integer + during the execution *) + let rargs = Array.sub args nparams arity in + let b_args = Array.map str_const rargs in + Bspecial ((Retroknowledge.get_vm_constant_dynamic_info + (!global_env).retroknowledge + (kind_of_term f)), + b_args) + with Not_found -> + (* 3/ if no special behavior is available, then the compiler + falls back to the normal behavior *) + if arity = 0 then Bstrconst(Const_b0 num) + else + let rargs = Array.sub args nparams arity in + let b_args = Array.map str_const rargs in + try + let sc_args = Array.map get_strcst b_args in + Bstrconst(Const_bn(num, sc_args)) + with Not_found -> + Bmakeblock(num,b_args) else - let b_args = Array.map str_const args in - Bconstruct_app(num, nparams, arity, b_args) + let b_args = Array.map str_const args in + (* spiwack: tries first to apply the run-time compilation + behavior of the constructor, as in 2/ above *) + try + Bspecial ((Retroknowledge.get_vm_constant_dynamic_info + (!global_env).retroknowledge + (kind_of_term f)), + b_args) + with Not_found -> + Bconstruct_app(num, nparams, arity, b_args) + end | _ -> Bconstr c end | Ind ind -> Bstrconst (Const_ind ind) - | Construct ((kn,j),i) -> - let oib = lookup_mind kn !global_env in - let oip = oib.mind_packets.(j) in - let num,arity = oip.mind_reloc_tbl.(i-1) in - let nparams = oib.mind_nparams in - if nparams + arity = 0 then Bstrconst(Const_b0 num) - else Bconstruct_app(num,nparams,arity,[||]) + | Construct ((kn,j),i as cstr) -> + begin + (* spiwack: tries first to apply the run-time compilation + behavior of the constructor, as in 2/ above *) + try + Bspecial ((Retroknowledge.get_vm_constant_dynamic_info + (!global_env).retroknowledge + (kind_of_term c)), + [| |]) + with Not_found -> + let oib = lookup_mind kn !global_env in + let oip = oib.mind_packets.(j) in + let num,arity = oip.mind_reloc_tbl.(i-1) in + let nparams = oib.mind_nparams in + if nparams + arity = 0 then Bstrconst(Const_b0 num) + else Bconstruct_app(num,nparams,arity,[||]) + end | _ -> Bconstr c (* compilation des applications *) @@ -413,6 +474,7 @@ let rec get_allias env kn = | BCallias kn' -> get_allias env kn' | _ -> kn + (* compilation des expressions *) let rec compile_constr reloc c sz cont = @@ -424,8 +486,7 @@ let rec compile_constr reloc c sz cont = | Rel i -> pos_rel i reloc sz :: cont | Var id -> pos_named id reloc :: cont - | Const kn -> Kgetglobal (get_allias !global_env kn) :: cont - + | Const kn -> compile_const reloc kn [||] sz cont | Sort _ | Ind _ | Construct _ -> compile_str_cst reloc (str_const c) sz cont @@ -452,6 +513,7 @@ let rec compile_constr reloc c sz cont = begin match kind_of_term f with | Construct _ -> compile_str_cst reloc (str_const c) sz cont + | Const kn -> compile_const reloc kn args sz cont | _ -> comp_app compile_constr compile_constr reloc f args sz cont end | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> @@ -569,11 +631,19 @@ let rec compile_constr reloc c sz cont = done; c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; let code_sw = - match branch1 with - | Klabel lbl -> Kpush_retaddr lbl :: !c + match branch1 with + (* spiwack : branch1 can't be a lbl anymore it's a Branch instead + | Klabel lbl -> Kpush_retaddr lbl :: !c *) + | Kbranch lbl -> Kpush_retaddr lbl :: !c | _ -> !c in - compile_constr reloc a sz code_sw + compile_constr reloc a sz + (try + let entry = Term.Ind ind in + Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge + entry code_sw + with Not_found -> + code_sw) and compile_str_cst reloc sc sz cont = match sc with @@ -588,6 +658,40 @@ and compile_str_cst reloc sc sz cont = comp_app (fun _ _ _ cont -> code_construct tag nparams arity cont) compile_str_cst reloc () args sz cont + | Bspecial (comp_fx, args) -> comp_fx reloc args sz cont + + +(* spiwack : compilation of constants with their arguments. + Makes a special treatment with 31-bit integer addition *) +and compile_const = + let code_construct kn cont = + let f_cont = + let else_lbl = Label.create () in + Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: + Kaddint31:: Kreturn 0:: Klabel else_lbl:: + (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) + Kgetglobal (get_allias !global_env kn):: + Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) + in + let lbl = Label.create () in + fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; + Kclosure(lbl, 0)::cont + in + fun reloc-> fun kn -> fun args -> fun sz -> fun cont -> + let nargs = Array.length args in + (* spiwack: checks if there is a specific way to compile the constant + if there is not, Not_found is raised, and the function + falls back on its normal behavior *) + try + Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge + (kind_of_term (mkConst kn)) reloc args sz cont + with Not_found -> + if nargs = 0 then + Kgetglobal (get_allias !global_env kn) :: cont + else + comp_app (fun _ _ _ cont -> + Kgetglobal (get_allias !global_env kn) :: cont) + compile_constr reloc () args sz cont let compile env c = set_global_env env; @@ -625,3 +729,138 @@ let compile_constant_body env body opaque boxed = let to_patch = to_memory res in BCdefined (false, to_patch) + +(* spiwack: additional function which allow different part of compilation of the + 31-bit integers *) + +let make_areconst n else_lbl cont = + if n <=0 then + cont + else + Kareconst (n, else_lbl)::cont + + +(* try to compile int31 as a const_b0. Succeed if all the arguments are closed + fails otherwise by raising NotClosed*) +let compile_structured_int31 fc args = + if not fc then raise Not_found else + Const_b0 + (Array.fold_left + (fun temp_i -> fun t -> match kind_of_term t with + | Construct (_,d) -> 2*temp_i+d-1 + | _ -> raise NotClosed) + 0 args + ) + +(* this function is used for the compilation of the constructor of + the int31, it is used when it appears not fully applied, or + applied to at least one non-closed digit *) +let dynamic_int31_compilation fc reloc args sz cont = + if not fc then raise Not_found else + let nargs = Array.length args in + if nargs = 31 then + let (escape,labeled_cont) = make_branch cont in + let else_lbl = Label.create() in + comp_args compile_str_cst reloc args sz + ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) + else + let code_construct cont = (* spiwack: variant of the global code_construct + which handles dynamic compilation of + integers *) + let f_cont = + let else_lbl = Label.create () in + [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl); + Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0] + in + let lbl = Label.create() in + fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)]; + Kclosure(lbl,0) :: cont + in + if nargs = 0 then + code_construct cont + else + comp_app (fun _ _ _ cont -> code_construct cont) + compile_str_cst reloc () args sz cont + +(*(* template compilation for 2ary operation, it probably possible + to make a generic such function with arity abstracted *) +let op2_compilation op = + let code_construct normal cont = (*kn cont =*) + let f_cont = + let else_lbl = Label.create () in + Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: + op:: Kreturn 0:: Klabel else_lbl:: + (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) + (*Kgetglobal (get_allias !global_env kn):: *) + normal:: + Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) + in + let lbl = Label.create () in + fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; + Kclosure(lbl, 0)::cont + in + fun normal fc _ reloc args sz cont -> + if not fc then raise Not_found else + let nargs = Array.length args in + if nargs=2 then (*if it is a fully applied addition*) + let (escape, labeled_cont) = make_branch cont in + let else_lbl = Label.create () in + comp_args compile_constr reloc args sz + (Kisconst else_lbl::(make_areconst 1 else_lbl + (*Kaddint31::escape::Klabel else_lbl::Kpush::*) + (op::escape::Klabel else_lbl::Kpush:: + (* works as comp_app with nargs = 2 and non-tailcall cont*) + (*Kgetglobal (get_allias !global_env kn):: *) + normal:: + Kapply 2::labeled_cont))) + else if nargs=0 then + code_construct normal cont + else + comp_app (fun _ _ _ cont -> code_construct normal cont) + compile_constr reloc () args sz cont *) + +(*template for n-ary operation, invariant: n>=1, + the operations does the following : + 1/ checks if all the arguments are constants (i.e. non-block values) + 2/ if they are, uses the "op" instruction to execute + 3/ if at least one is not, branches to the normal behavior: + Kgetglobal (get_allias !global_env kn) *) +let op_compilation n op = + let code_construct kn cont = + let f_cont = + let else_lbl = Label.create () in + Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: + op:: Kreturn 0:: Klabel else_lbl:: + (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) + Kgetglobal (get_allias !global_env kn):: + Kappterm(n, n):: [] (* = discard_dead_code [Kreturn 0] *) + in + let lbl = Label.create () in + fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; + Kclosure(lbl, 0)::cont + in + fun kn fc reloc args sz cont -> + if not fc then raise Not_found else + let nargs = Array.length args in + if nargs=n then (*if it is a fully applied addition*) + let (escape, labeled_cont) = make_branch cont in + let else_lbl = Label.create () in + comp_args compile_constr reloc args sz + (Kisconst else_lbl::(make_areconst (n-1) else_lbl + (*Kaddint31::escape::Klabel else_lbl::Kpush::*) + (op::escape::Klabel else_lbl::Kpush:: + (* works as comp_app with nargs = n and non-tailcall cont*) + Kgetglobal (get_allias !global_env kn):: + Kapply n::labeled_cont))) + else if nargs=0 then + code_construct kn cont + else + comp_app (fun _ _ _ cont -> code_construct kn cont) + compile_constr reloc () args sz cont + +let int31_escape_before_match fc cont = + if not fc then + raise Not_found + else + let escape_lbl, labeled_cont = label_code cont in + (Kisconst escape_lbl)::Kdecompint31::labeled_cont diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index f761e4f60..829ac46e2 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -6,7 +6,6 @@ open Declarations open Pre_env - val compile : env -> constr -> bytecodes * bytecodes * fv (* init, fun, fv *) @@ -15,3 +14,28 @@ val compile_constant_body : (* opaque *) (* boxed *) +(* arnaud : a commenter *) +(* spiwack: this function contains the information needed to perform + the static compilation of int31 (trying and obtaining + a 31-bit integer in processor representation at compile time) *) +val compile_structured_int31 : bool -> constr array -> + structured_constant + +(* this function contains the information needed to perform + the dynamic compilation of int31 (trying and obtaining a + 31-bit integer in processor representation at runtime when + it failed at compile time *) +val dynamic_int31_compilation : bool -> comp_env -> + block array -> + int -> bytecodes -> bytecodes + +(*spiwack: template for the compilation n-ary operation, invariant: n>=1. + works as follow: checks if all the arguments are non-pointers + if they are applies the operation (second argument) if not + all of them are, returns to a coq definition (third argument) *) +val op_compilation : int -> instruction -> constant -> bool -> comp_env -> + constr array -> int -> bytecodes-> bytecodes + +(*spiwack: compiling function to insert dynamic decompilation before + matching integers (in case they are in processor representation) *) +val int31_escape_before_match : bool -> bytecodes -> bytecodes diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 1b6d8923e..dffb0f2d5 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -111,7 +111,10 @@ let out_label_with_orig orig lbl = Label_defined def -> out_int((def - orig) asr 2) | Label_undefined patchlist -> - if patchlist = [] then + (* spiwack: patchlist is supposed to be non-empty all the time + thus I commented that out. If there is no problem I suggest + removing it for next release (cur: 8.1) *) + (*if patchlist = [] then *) (!label_table).(lbl) <- Label_undefined((!out_position, orig) :: patchlist); out_int 0 @@ -222,9 +225,28 @@ let emit_instr = function | Ksetfield n -> if n <= 1 then out (opSETFIELD0+n) else (out opSETFIELD;out_int n) + | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr") + (* spiwack *) + | Kbranch lbl -> out opBRANCH; out_label lbl + | Kaddint31 -> out opADDINT31 + | Kaddcint31 -> out opADDCINT31 + | Kaddcarrycint31 -> out opADDCARRYCINT31 + | Ksubint31 -> out opSUBINT31 + | Ksubcint31 -> out opSUBCINT31 + | Ksubcarrycint31 -> out opSUBCARRYCINT31 + | Kmulint31 -> out opMULINT31 + | Kmulcint31 -> out opMULCINT31 + | Kdiv21int31 -> out opDIV21INT31 + | Kdivint31 -> out opDIVINT31 + | Kaddmuldivint31 -> out opADDMULDIVINT31 + | Kcompareint31 -> out opCOMPAREINT31 + | Kisconst lbl -> out opISCONST; out_label lbl + | Kareconst(n,lbl) -> out opARECONST; out_int n; out_label lbl + | Kcompint31 -> out opCOMPINT31 + | Kdecompint31 -> out opDECOMPINT31 + (*/spiwack *) | Kstop -> out opSTOP - | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr") (* Emission of a list of instructions. Include some peephole optimization. *) diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 1be251a50..eb49ba620 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -285,5 +285,6 @@ and module_body = mod_user_type : module_type_body option; mod_type : module_type_body; mod_equiv : module_path option; - mod_constraints : constraints } + mod_constraints : constraints; + mod_retroknowledge : Retroknowledge.action list} diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 7f7f7dcc3..2f32d8639 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -218,7 +218,8 @@ and module_body = mod_user_type : module_type_body option; mod_type : module_type_body; mod_equiv : module_path option; - mod_constraints : constraints } + mod_constraints : constraints; + mod_retroknowledge : Retroknowledge.action list} (* [type_of(mod_expr)] <: [mod_user_type] (if given) *) (* if equiv given then constraints are empty *) diff --git a/kernel/environ.ml b/kernel/environ.ml index a9ba253b0..683527045 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -358,6 +358,7 @@ let insert_after_hyp (ctxt,vals) id d check = | _, _ -> assert false in aux ctxt vals + (* To be used in Logic.clear_hyps *) let remove_hyps ids check_context check_value (ctxt, vals) = let ctxt,vals,rmv = @@ -371,3 +372,222 @@ let remove_hyps ids check_context check_value (ctxt, vals) = ctxt vals ([],[],[]) in ((ctxt,vals),rmv) + + + + + +(*spiwack: the following functions assemble the pieces of the retroknowledge + note that the "consistent" register function is available in the module + Safetyping, Environ only synchronizes the proactive and the reactive parts*) + +open Retroknowledge + +(* lifting of the "get" functions works also for "mem"*) +let retroknowledge f env = + f env.retroknowledge + +let registered env field = + retroknowledge mem env field + +(* spiwack: this unregistration function is not in operation yet. It should + not be used *) +(* this unregistration function assumes that no "constr" can hold two different + places in the retroknowledge. There is no reason why it shouldn't be true, + but in case someone needs it, remember to add special branches to the + unregister function *) +let unregister env field = + match field with + | KInt31 (_,Int31Type) -> + (*there is only one matching kind due to the fact that Environ.env + is abstract, and that the only function which add elements to the + retroknowledge is Environ.register which enforces this shape *) + let Ind i31t = retroknowledge find env field in + let i31c = Construct (i31t, 1) in + {env with retroknowledge = + remove (retroknowledge clear_info env i31c) field} + |_ -> {env with retroknowledge = + try + remove (retroknowledge clear_info env + (retroknowledge find env field)) field + with Not_found -> + retroknowledge remove env field} + + + +(* the Environ.register function syncrhonizes the proactive and reactive + retroknowledge. *) +let register = + + (* subfunction used for static decompilation of int31 (after a vm_compute, + see pretyping/vnorm.ml for more information) *) + let constr_of_int31 = + let nth_digit_plus_one i n = (* calculates the nth (starting with 0) + digit of i and adds 1 to it + (nth_digit_plus_one 1 3 = 2) *) + if (land) i ((lsl) 1 n) = 0 then + 1 + else + 2 + in + fun ind -> fun digit_ind -> fun tag -> + let array_of_int i = + Array.init 31 (fun n -> mkConstruct + (digit_ind, nth_digit_plus_one i (30-n))) + in + mkApp(mkConstruct(ind, 1), array_of_int tag) + in + + (* subfunction which adds the information bound to the constructor of + the int31 type to the reactive retroknowledge *) + let add_int31c retroknowledge c = + let rk = add_vm_constant_static_info retroknowledge c + Cbytegen.compile_structured_int31 + in + add_vm_constant_dynamic_info rk c Cbytegen.dynamic_int31_compilation + in + + (* subfunction which adds the compiling information of an + int31 operation which has a specific vm instruction (associates + it to the name of the coq definition in the reactive retroknowledge) *) + let add_int31_op retroknowledge v n op kn = + add_vm_compiling_info retroknowledge v (Cbytegen.op_compilation n op kn) + in + +fun env field value -> + (* subfunction which shortens the (very often use) registration of binary + operators to the reactive retroknowledge. *) + let add_int31_binop_from_const op = + match value with + | Const kn -> retroknowledge add_int31_op env value 2 + op kn + | _ -> anomaly "Environ.register: should be a constant" + in + (* subfunction which completes the function constr_of_int31 above + by performing the actual retroknowledge operations *) + let add_int31_decompilation_from_type rk = + (* invariant : the type of bits is registered, otherwise the function + would raise Not_found. The invariant is enforced in safe_typing.ml *) + match field with + | KInt31 (grp, Int31Type) -> + (match Retroknowledge.find rk (KInt31 (grp,Int31Bits)) with + | Ind i31bit_type -> + (match value with + | Ind i31t -> + Retroknowledge.add_vm_decompile_constant_info rk + value (constr_of_int31 i31t i31bit_type) + | _ -> anomaly "Environ.register: should be an inductive type") + | _ -> anomaly "Environ.register: Int31Bits should be an inductive type") + | _ -> anomaly "Environ.register: add_int31_decompilation_from_type called with an abnormal field" + in + {env with retroknowledge = + let retroknowledge_with_reactive_info = + match field with + | KInt31 (_, Int31Type) -> + let i31c = match value with + | Ind i31t -> (Construct (i31t, 1)) + | _ -> anomaly "Environ.register: should be an inductive type" + in + add_int31_decompilation_from_type + (add_vm_before_match_info + (retroknowledge add_int31c env i31c) + value Cbytegen.int31_escape_before_match) + | KInt31 (_, Int31Plus) -> add_int31_binop_from_const Cbytecodes.Kaddint31 + | KInt31 (_, Int31PlusC) -> add_int31_binop_from_const Cbytecodes.Kaddcint31 + | KInt31 (_, Int31PlusCarryC) -> add_int31_binop_from_const Cbytecodes.Kaddcarrycint31 + | KInt31 (_, Int31Minus) -> add_int31_binop_from_const Cbytecodes.Ksubint31 + | KInt31 (_, Int31MinusC) -> add_int31_binop_from_const Cbytecodes.Ksubcint31 + | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const + Cbytecodes.Ksubcarrycint31 + | KInt31 (_, Int31PlusC) -> add_int31_binop_from_const Cbytecodes.Kaddcint31 + | KInt31 (_, Int31Times) -> add_int31_binop_from_const Cbytecodes.Kmulint31 + | KInt31 (_, Int31TimesC) -> add_int31_binop_from_const Cbytecodes.Kmulcint31 + | KInt31 (_, Int31Div21) -> (* this is a ternary operation *) + (match value with + | Const kn -> + retroknowledge add_int31_op env value 3 + Cbytecodes.Kdiv21int31 kn + | _ -> anomaly "Environ.register: should be a constant") + | KInt31 (_, Int31Div) -> add_int31_binop_from_const Cbytecodes.Kdivint31 + | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *) + (match value with + | Const kn -> + retroknowledge add_int31_op env value 3 + Cbytecodes.Kaddmuldivint31 kn + | _ -> anomaly "Environ.register: should be a constant") + | KInt31 (_, Int31Compare) -> add_int31_binop_from_const Cbytecodes.Kcompareint31 + | _ -> env.retroknowledge + in + Retroknowledge.add_field retroknowledge_with_reactive_info field value + } + + +(* spiwack: the following definitions are used by the function + needed_assumption which gives as an output the set of all + axioms and sections variables on which a given term depends + in a context (expectingly the Global context) *) +type assumption = + | Variable of identifier*constr + | Axiom of constant*constr + +module OrderedAssumption = +struct + type t = assumption + let compare = compare +end + +module AssumptionSet = Set.Make (OrderedAssumption) + +(* definition for redability purposes *) +let ( ** ) s1 s2 = AssumptionSet.union s1 s2 + +let rec needed_assumptions t env = + (* goes recursively into the terms to see if it depends on assumptions + the 3 important cases are : Var _ which simply means that the term refers + to a section variable, + Rel _ which means the term is a variable + which has been bound earlier by a Lambda or a Prod (returns [] ) + Const _ where we need to first unfold + the constant and return the needed assumptions of its body in the + environnement *) + match kind_of_term t with + | Var id -> AssumptionSet.singleton (Variable (id,named_type id env)) + | Meta _ | Evar _ -> assert false + | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) -> + (needed_assumptions e1 env)**(needed_assumptions e2 env) + | LetIn (_,e1,e2,e3) ->(needed_assumptions e1 env)** + (needed_assumptions e2 env)** + (needed_assumptions e3 env) + | App (e1, e_array) -> (needed_assumptions e1 env)** + (Array.fold_right (fun e -> fun s -> + (needed_assumptions e env)**s) + e_array AssumptionSet.empty) + | Case (_,e1,e2,e_array) -> (needed_assumptions e1 env)** + (needed_assumptions e2 env)** + (Array.fold_right (fun e -> fun s -> + (needed_assumptions e env)**s) + e_array AssumptionSet.empty) + | Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) -> + Array.fold_right (fun e -> fun s -> + (needed_assumptions e env)**s) + e1_array + (Array.fold_right (fun e -> fun s -> + (needed_assumptions e env)**s) + e2_array AssumptionSet.empty) + | Const kn -> + let cb = lookup_constant kn env in + (match cb.Declarations.const_body with + | None -> + let ctype = + match cb.Declarations.const_type with + | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level) + | NonPolymorphicType t -> t + in + AssumptionSet.singleton (Axiom (kn,ctype)) + | Some body -> needed_assumptions (Declarations.force body) env) + | _ -> AssumptionSet.empty (* closed atomic types + rel *) + +(* /spiwack *) + + + diff --git a/kernel/environ.mli b/kernel/environ.mli index 96c2ba276..293c55a69 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -219,3 +219,27 @@ val insert_after_hyp : named_context_val -> variable -> val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val * identifier list + +(* spiwack: functions manipulating the retroknowledge *) +open Retroknowledge + +val retroknowledge : (retroknowledge->'a) -> env -> 'a + +val registered : env -> field -> bool + +val unregister : env -> field -> env + +val register : env -> field -> Retroknowledge.entry -> env + +(* spiwack: a few declarations for the "Print Assumption" command *) +type assumption = + | Variable of identifier*Term.constr + | Axiom of constant*Term.constr + +module OrderedAssumption : Set.OrderedType with type t = assumption + +module AssumptionSet : Set.S with type elt = assumption + +val needed_assumptions : constr -> env -> AssumptionSet.t + + diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index ad5df805b..93d01f12a 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -170,7 +170,8 @@ and translate_module env me = mod_user_type = Some mtb; mod_type = mtb; mod_equiv = None; - mod_constraints = Constraint.empty } + mod_constraints = Constraint.empty; + mod_retroknowledge = [] } | Some mexpr, _ -> let meq_o = (* do we have a transparent module ? *) try (* TODO: transparent field in module_entry *) @@ -193,7 +194,11 @@ and translate_module env me = mod_user_type = mod_user_type; mod_expr = Some meb; mod_equiv = meq_o; - mod_constraints = cst } + mod_constraints = cst; + mod_retroknowledge = []} (* spiwack: not so sure about that. It may + cause a bug when closing nested modules. + If it does, I don't really know how to + fix the bug.*) (* translate_mexpr : env -> module_expr -> module_expr_body * module_type_body *) and translate_mexpr env mexpr = match mexpr with diff --git a/kernel/modops.ml b/kernel/modops.ml index 96d19552a..3e89112ae 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -95,14 +95,16 @@ let module_body_of_spec msb = mod_equiv = msb.msb_equiv; mod_expr = None; mod_user_type = None; - mod_constraints = Constraint.empty} + mod_constraints = Constraint.empty; + mod_retroknowledge = []} let module_body_of_type mtb = { mod_type = mtb; mod_equiv = None; mod_expr = None; mod_user_type = None; - mod_constraints = Constraint.empty} + mod_constraints = Constraint.empty; + mod_retroknowledge = []} (* the constraints are not important here *) @@ -170,6 +172,32 @@ and subst_module sub mb = let subst_signature_msid msid mp = subst_signature (map_msid msid mp) + +(* spiwack: here comes the function which takes care of importing + the retroknowledge declared in the library *) +(* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) +let add_retroknowledge msid mp = + let subst = add_msid msid mp empty_subst in + let subst_and_perform rkaction env = + match rkaction with + | Retroknowledge.RKRegister (f, e) -> + Environ.register env f + (match e with + | Const kn -> kind_of_term (subst_mps subst (mkConst kn)) + | Ind ind -> kind_of_term (subst_mps subst (mkInd ind)) + | _ -> anomaly "Modops.add_retroknowledge: had to import an unsupported kind of term") + in + fun lclrk env -> + (* The order of the declaration matters, for instance (and it's at the + time this comment is being written, the only relevent instance) the + int31 type registration absolutely needs int31 bits to be registered. + Since the local_retroknowledge is stored in reverse order (each new + registration is added at the top of the list) we need a fold_right + for things to go right (the pun is not intented). So we lose + tail recursivity, but the world will have exploded before any module + imports 10 000 retroknowledge registration.*) + List.fold_right subst_and_perform lclrk env + (* we assume that the substitution of "mp" into "msid" is already done (or unnecessary) *) let rec add_signature mp sign env = @@ -192,7 +220,8 @@ and add_module mp mb env = match scrape_modtype env mb.mod_type with | MTBident _ -> anomaly "scrape_modtype does not work!" | MTBsig (msid,sign) -> - add_signature mp (subst_signature_msid msid mp sign) env + add_retroknowledge msid mp (mb.mod_retroknowledge) + (add_signature mp (subst_signature_msid msid mp sign) env) | MTBfunsig _ -> env @@ -306,7 +335,7 @@ and strengthen_sig env msid sign mp = match sign with let env' = add_module (MPdot (MPself msid,l)) (module_body_of_spec mb) - env + env in let rest' = strengthen_sig env' msid rest mp in item'::rest' diff --git a/kernel/modops.mli b/kernel/modops.mli index c209eac1a..d7cdb59ac 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -49,7 +49,7 @@ val add_signature : (* adds a module and its components, but not the constraints *) val add_module : - module_path -> module_body -> env -> env + module_path -> module_body -> env -> env val check_modpath_equiv : env -> module_path -> module_path -> unit diff --git a/kernel/names.ml b/kernel/names.ml index 09c98eafc..c153169ab 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -332,3 +332,41 @@ type id_key = inv_rel_key tableKey +(* spiwack : internal representation printing *) + +let string_of_identifier id = id +let string_of_module_ident id = id +let string_of_label lbl = lbl (* not public *) +let string_of_dir_path path = "["^String.concat "; " (List.map string_of_module_ident path)^"]" +let string_of_name = + function + | Name id -> "Name "^id + | Anonymous -> "Anonymous" + +let rec string_of_module_path = (* not public *) + function + | MPfile path -> "MPfile "^string_of_dir_path path + | MPbound _ -> "MPbound "^"?" (*of mod_bound_id*) + | MPself _ -> "MPself "^"?" (* of mod_self_id *) + | MPdot (mpath, lbl) -> + "MPdot ("^string_of_module_path mpath^", "^string_of_label lbl^")" + (* of module_path * label *) + +let string_of_kernel_name = (* not public *) + function + |(mpath, path, lbl) -> + "("^string_of_module_path mpath^", "^ + string_of_dir_path path^", "^ + string_of_label lbl ^")" + +let string_of_constant = string_of_kernel_name +let string_of_mutual_inductive = string_of_kernel_name +let string_of_inductive = + function + | (mind, i) -> "("^string_of_mutual_inductive mind^", "^string_of_int i^")" +let string_of_constructor = + function + | (ind, i) -> "("^string_of_inductive ind^", "^string_of_int i^")" + + +(* /spiwack *) diff --git a/kernel/names.mli b/kernel/names.mli index 64edf1702..dee798da0 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -174,3 +174,15 @@ type inv_rel_key = int (* index in the [rel_context] part of environment of de Bruijn indice *) type id_key = inv_rel_key tableKey + + + +(* spiwack : function used for printing identifiers *) +val string_of_identifier : identifier-> string +val string_of_module_ident : module_ident-> string +val string_of_dir_path : dir_path -> string +val string_of_name : name -> string +val string_of_constant : constant -> string +val string_of_mutual_inductive : mutual_inductive -> string +val string_of_inductive : inductive -> string +val string_of_constructor : constructor -> string diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 7a7e00e90..4f2498dc3 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -48,7 +48,8 @@ type env = { env_rel_context : rel_context; env_rel_val : lazy_val list; env_nb_rel : int; - env_stratification : stratification } + env_stratification : stratification; + retroknowledge : Retroknowledge.retroknowledge } type named_context_val = named_context * named_vals @@ -67,7 +68,8 @@ let empty_env = { env_nb_rel = 0; env_stratification = { env_universes = initial_universes; - env_engagement = None } } + env_engagement = None }; + retroknowledge = Retroknowledge.initial_retroknowledge } (* Rel context *) diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 728f28be0..511f56e65 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -48,7 +48,8 @@ type env = { env_rel_context : rel_context; env_rel_val : lazy_val list; env_nb_rel : int; - env_stratification : stratification } + env_stratification : stratification; + retroknowledge : Retroknowledge.retroknowledge } type named_context_val = named_context * named_vals @@ -80,5 +81,3 @@ val lookup_mind : mutual_inductive -> env -> mutual_inductive_body (* Find the ultimate inductive in the [mind_equiv] chain *) val scrape_mind : env -> mutual_inductive -> mutual_inductive - - diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml new file mode 100644 index 000000000..f064cd8b9 --- /dev/null +++ b/kernel/retroknowledge.ml @@ -0,0 +1,277 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \V/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: retroknowledge.ml ??? 2006-??-?? ??:??:??Z spiwack $ *) + +open Term +open Names + +(* Type declarations, these types shouldn't be exported they are accessed + through specific functions. As being mutable and all it is wiser *) +(* These types are put into two distinct categories: proactive and reactive. + Proactive information allows to find the name of a combinator, constructor + or inductive type handling a specific function. + Reactive information is, on the other hand, everything you need to know + about a specific name.*) + +(* aliased type for clarity purpose*) +type entry = (constr, types) kind_of_term + +(* the following types correspond to the different "things" + the kernel can learn about. These are the fields of the proactive knowledge*) +type nat_field = + | NatType + | NatPlus + | NatTimes + +type n_field = + | NPositive + | NType + | NTwice + | NTwicePlusOne + | NPhi + | NPhiInv + | NPlus + | NTimes + +type int31_field = + | Int31Bits + | Int31Type + | Int31Twice + | Int31TwicePlusOne + | Int31Phi + | Int31PhiInv + | Int31Plus + | Int31PlusC + | Int31PlusCarryC + | Int31Minus + | Int31MinusC + | Int31MinusCarryC + | Int31Times + | Int31TimesC + | Int31Div21 + | Int31Div + | Int31AddMulDiv + | Int31Compare + +type field = + | KEq + | KNat of nat_field + | KN of n_field + | KInt31 of string*int31_field + + +(* record representing all the flags of the internal state of the kernel *) +type flags = {fastcomputation : bool} + + + + + +(*A definition of maps from strings to pro_int31, to be able + to have any amount of coq representation for the 31bits integers *) +module OrderedField = +struct + type t = field + let compare = compare +end + +module Proactive = Map.Make (OrderedField) + + +type proactive = entry Proactive.t + +(* the reactive knowledge is represented as a functionaly map + from the type of terms (actually it is the terms whose outermost + layer is unfolded (typically by Term.kind_of_term)) to the + type reactive_end which is a record containing all the kind of reactive + information needed *) +(* todo: because of the bug with output state, reactive_end should eventually + contain no function. A forseen possibility is to make it a map from + a finite type describing the fields to the field of proactive retroknowledge + (and then to make as many functions as needed in environ.ml) *) + +module OrderedEntry = +struct + type t = entry + let compare = compare +end + +module Reactive = Map.Make (OrderedEntry) + +type reactive_end = {(*information required by the compiler of the VM *) + vm_compiling : + (*fastcomputation flag -> continuation -> result *) + (bool->Cbytecodes.comp_env->constr array -> + int->Cbytecodes.bytecodes->Cbytecodes.bytecodes) + option; + vm_constant_static : + (*fastcomputation flag -> constructor -> args -> result*) + (bool->constr array->Cbytecodes.structured_constant) + option; + vm_constant_dynamic : + (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *) + (bool->Cbytecodes.comp_env->Cbytecodes.block array->int-> + Cbytecodes.bytecodes->Cbytecodes.bytecodes) + option; + (* fastcomputation flag -> cont -> result *) + vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option; + (* tag (= compiled int for instance) -> result *) + vm_decompile_const : (int -> Term.constr) option} + + + +and reactive = reactive_end Reactive.t + +and retroknowledge = {flags : flags; proactive : proactive; reactive : reactive} + +(* This type represent an atomic action of the retroknowledge. It + is stored in the compiled libraries *) +(* As per now, there is only the possibility of registering things + the possibility of unregistering or changing the flag is under study *) +type action = + | RKRegister of field*entry + + +(*initialisation*) +let initial_flags = + {fastcomputation = true;} + +let initial_proactive = + (Proactive.empty:proactive) + +let initial_reactive = + (Reactive.empty:reactive) + +let initial_retroknowledge = + {flags = initial_flags; + proactive = initial_proactive; + reactive = initial_reactive } + +let empty_reactive_end = + { vm_compiling = None ; + vm_constant_static = None; + vm_constant_dynamic = None; + vm_before_match = None; + vm_decompile_const = None } + + + + +(* acces functions for proactive retroknowledge *) +let add_field knowledge field value = + {knowledge with proactive = Proactive.add field value knowledge.proactive} + +let mem knowledge field = + Proactive.mem field knowledge.proactive + +let remove knowledge field = + {knowledge with proactive = Proactive.remove field knowledge.proactive} + +let find knowledge field = + Proactive.find field knowledge.proactive + + + + + +(*access functions for reactive retroknowledge*) + +(* used for compiling of functions (add, mult, etc..) *) +let get_vm_compiling_info knowledge key = + match (Reactive.find key knowledge.reactive).vm_compiling + with + | None -> raise Not_found + | Some f -> f knowledge.flags.fastcomputation + +(* used for compilation of fully applied constructors *) +let get_vm_constant_static_info knowledge key = + match (Reactive.find key knowledge.reactive).vm_constant_static + with + | None -> raise Not_found + | Some f -> f knowledge.flags.fastcomputation + +(* used for compilation of partially applied constructors *) +let get_vm_constant_dynamic_info knowledge key = + match (Reactive.find key knowledge.reactive).vm_constant_dynamic + with + | None -> raise Not_found + | Some f -> f knowledge.flags.fastcomputation + +let get_vm_before_match_info knowledge key = + match (Reactive.find key knowledge.reactive).vm_before_match + with + | None -> raise Not_found + | Some f -> f knowledge.flags.fastcomputation + +let get_vm_decompile_constant_info knowledge key = + match (Reactive.find key knowledge.reactive).vm_decompile_const + with + | None -> raise Not_found + | Some f -> f + + + +(* functions manipulating reactive knowledge *) +let add_vm_compiling_info knowledge value nfo = + {knowledge with reactive = + try + Reactive.add value + {(Reactive.find value (knowledge.reactive)) with vm_compiling = Some nfo} + knowledge.reactive + with Not_found -> + Reactive.add value {empty_reactive_end with vm_compiling = Some nfo} + knowledge.reactive + } + +let add_vm_constant_static_info knowledge value nfo = + {knowledge with reactive = + try + Reactive.add value + {(Reactive.find value (knowledge.reactive)) with vm_constant_static = Some nfo} + knowledge.reactive + with Not_found -> + Reactive.add value {empty_reactive_end with vm_constant_static = Some nfo} + knowledge.reactive + } + +let add_vm_constant_dynamic_info knowledge value nfo = + {knowledge with reactive = + try + Reactive.add value + {(Reactive.find value (knowledge.reactive)) with vm_constant_dynamic = Some nfo} + knowledge.reactive + with Not_found -> + Reactive.add value {empty_reactive_end with vm_constant_dynamic = Some nfo} + knowledge.reactive + } + +let add_vm_before_match_info knowledge value nfo = + {knowledge with reactive = + try + Reactive.add value + {(Reactive.find value (knowledge.reactive)) with vm_before_match = Some nfo} + knowledge.reactive + with Not_found -> + Reactive.add value {empty_reactive_end with vm_before_match = Some nfo} + knowledge.reactive + } + +let add_vm_decompile_constant_info knowledge value nfo = + {knowledge with reactive = + try + Reactive.add value + {(Reactive.find value (knowledge.reactive)) with vm_decompile_const = Some nfo} + knowledge.reactive + with Not_found -> + Reactive.add value {empty_reactive_end with vm_decompile_const = Some nfo} + knowledge.reactive + } + +let clear_info knowledge value = + {knowledge with reactive = Reactive.remove value knowledge.reactive} diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli new file mode 100644 index 000000000..cba055560 --- /dev/null +++ b/kernel/retroknowledge.mli @@ -0,0 +1,152 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: retroknowledge.mli ??? 2006-??-?? ??:??:??Z spiwack $ i*) + +(*i*) +open Names +open Term +(*i*) + +type retroknowledge + +(* aliased type for clarity purpose*) +type entry = (constr, types) kind_of_term + +(* the following types correspond to the different "things" + the kernel can learn about.*) +type nat_field = + | NatType + | NatPlus + | NatTimes + +type n_field = + | NPositive + | NType + | NTwice + | NTwicePlusOne + | NPhi + | NPhiInv + | NPlus + | NTimes + +type int31_field = + | Int31Bits + | Int31Type + | Int31Twice + | Int31TwicePlusOne + | Int31Phi + | Int31PhiInv + | Int31Plus + | Int31PlusC + | Int31PlusCarryC + | Int31Minus + | Int31MinusC + | Int31MinusCarryC + | Int31Times + | Int31TimesC + | Int31Div21 + | Int31Div + | Int31AddMulDiv + | Int31Compare + +type field = + | KEq + | KNat of nat_field + | KN of n_field + | KInt31 of string*int31_field + + +(* This type represent an atomic action of the retroknowledge. It + is stored in the compiled libraries *) +(* As per now, there is only the possibility of registering things + the possibility of unregistering or changing the flag is under study *) +type action = + | RKRegister of field*entry + + +(* initial value for retroknowledge *) +val initial_retroknowledge : retroknowledge + + +(* Given an identifier id (usually Const _) + and the continuation cont of the bytecode compilation + returns the compilation of id in cont if it has a specific treatment + or raises Not_found if id should be compiled as usual *) +val get_vm_compiling_info : retroknowledge -> entry -> Cbytecodes.comp_env -> + constr array -> + int -> Cbytecodes.bytecodes-> Cbytecodes.bytecodes +(*Given an identifier id (usually Construct _) + and its argument array, returns a function that tries an ad-hoc optimisated + compilation (in the case of the 31-bit integers it means compiling them + directly into an integer) + raises Not_found if id should be compiled as usual, and expectingly + CBytecodes.NotClosed if the term is not a closed constructor pattern + (a constant for the compiler) *) +val get_vm_constant_static_info : retroknowledge -> entry -> + constr array -> + Cbytecodes.structured_constant + +(*Given an identifier id (usually Construct _ ) + its argument array and a continuation, returns the compiled version + of id+args+cont when id has a specific treatment (in the case of + 31-bit integers, that would be the dynamic compilation into integers) + or raises Not_found if id should be compiled as usual *) +val get_vm_constant_dynamic_info : retroknowledge -> entry -> + Cbytecodes.comp_env -> + Cbytecodes.block array -> + int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes +(* Given a type identifier, this function is used before compiling a match + over this type. In the case of 31-bit integers for instance, it is used + to add the instruction sequence which would perform a dynamic decompilation + in case the argument of the match is not in coq representation *) +val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes + -> Cbytecodes.bytecodes + +(* Given a type identifier, this function is used by pretyping/vnorm.ml to + recover the elements of that type from their compiled form if it's non + standard (it is used (and can be used) only when the compiled form + is not a block *) +val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr + + +(* the following functions are solely used in Pre_env and Environ to implement + the functions register and unregister (and mem) of Environ *) +val add_field : retroknowledge -> field -> entry -> retroknowledge +val mem : retroknowledge -> field -> bool +val remove : retroknowledge -> field -> retroknowledge +val find : retroknowledge -> field -> entry + +(* the following function manipulate the reactive information of values + they are only used by the functions of Pre_env, and Environ to implement + the functions register and unregister of Environ *) +val add_vm_compiling_info : retroknowledge-> entry -> + (bool -> Cbytecodes.comp_env -> constr array -> int -> + Cbytecodes.bytecodes -> Cbytecodes.bytecodes) -> + retroknowledge +val add_vm_constant_static_info : retroknowledge-> entry -> + (bool->constr array-> + Cbytecodes.structured_constant) -> + retroknowledge +val add_vm_constant_dynamic_info : retroknowledge-> entry -> + (bool -> Cbytecodes.comp_env -> + Cbytecodes.block array -> int -> + Cbytecodes.bytecodes -> Cbytecodes.bytecodes) -> + retroknowledge +val add_vm_before_match_info : retroknowledge -> entry -> + (bool->Cbytecodes.bytecodes->Cbytecodes.bytecodes) -> + retroknowledge + +val add_vm_decompile_constant_info : retroknowledge -> entry -> + (int -> constr) -> retroknowledge + + +val clear_info : retroknowledge-> entry -> retroknowledge + + + diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 9cfce4303..efc2fa865 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -52,7 +52,8 @@ type safe_environment = revsign : module_signature_body; revstruct : module_structure_body; imports : library_info list; - loads : (module_path * module_body) list } + loads : (module_path * module_body) list; + local_retroknowledge : Retroknowledge.action list} (* { old = senv.old; @@ -79,12 +80,65 @@ let rec empty_environment = revsign = []; revstruct = []; imports = []; - loads = [] } + loads = []; + local_retroknowledge = [] } let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env + + + + + + + + +(*spiwack: functions for safe retroknowledge *) + +(* terms which are closed under the environnement env, i.e + terms which only depends on constant who are themselves closed *) +let closed env term = + AssumptionSet.is_empty (needed_assumptions env term) + +(* the set of safe terms in an environement any recursive set of + terms who are known not to prove inconsistent statement. It should + include at least all the closed terms. But it could contain other ones + like the axiom of excluded middle for instance *) +let safe = + closed + + + +(* universal lifting, used for the "get" operations mostly *) +let retroknowledge f senv = + Environ.retroknowledge f (env_of_senv senv) + +let register senv field value by_clause = + (* todo : value closed, by_clause safe, by_clause of the proper type*) + (* spiwack : updates the safe_env with the information that the register + action has to be performed (again) when the environement is imported *) + {senv with env = Environ.register senv.env field value; + local_retroknowledge = + Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge + } + +(* spiwack : currently unused *) +let unregister senv field = + (*spiwack: todo: do things properly or delete *) + {senv with env = Environ.unregister senv.env field} +(* /spiwack *) + + + + + + + + + + (* Insertion of section variables. They are now typed before being added to the environment. *) @@ -154,7 +208,8 @@ let add_constant dir l decl senv = revsign = (l,SPBconst cb)::senv.revsign; revstruct = (l,SEBconst cb)::senv.revstruct; imports = senv.imports; - loads = senv.loads } + loads = senv.loads ; + local_retroknowledge = senv.local_retroknowledge } (* Insertion of inductive types. *) @@ -181,7 +236,8 @@ let add_mind dir l mie senv = revsign = (l,SPBmind mib)::senv.revsign; revstruct = (l,SEBmind mib)::senv.revstruct; imports = senv.imports; - loads = senv.loads } + loads = senv.loads; + local_retroknowledge = senv.local_retroknowledge } (* Insertion of module types *) @@ -199,8 +255,8 @@ let add_modtype l mte senv = revsign = (l,SPBmodtype mtb)::senv.revsign; revstruct = (l,SEBmodtype mtb)::senv.revstruct; imports = senv.imports; - loads = senv.loads } - + loads = senv.loads; + local_retroknowledge = senv.local_retroknowledge } (* full_add_module adds module with universes and constraints *) @@ -224,7 +280,8 @@ let add_module l me senv = revsign = (l,SPBmodule mspec)::senv.revsign; revstruct = (l,SEBmodule mb)::senv.revstruct; imports = senv.imports; - loads = senv.loads } + loads = senv.loads; + local_retroknowledge = senv.local_retroknowledge } (* Interactive modules *) @@ -246,7 +303,9 @@ let start_module l senv = revsign = []; revstruct = []; imports = senv.imports; - loads = [] } + loads = []; + (* spiwack : not sure, but I hope it's correct *) + local_retroknowledge = [] } let end_module l restype senv = let oldsenv = senv.old in @@ -285,7 +344,8 @@ let end_module l restype senv = mod_user_type = mod_user_type; mod_type = mtb; mod_equiv = None; - mod_constraints = cst } + mod_constraints = cst; + mod_retroknowledge = senv.local_retroknowledge} in let mspec = { msb_modtype = mtb; @@ -310,7 +370,8 @@ let end_module l restype senv = revsign = (l,SPBmodule mspec)::oldsenv.revsign; revstruct = (l,SEBmodule mb)::oldsenv.revstruct; imports = senv.imports; - loads = senv.loads@oldsenv.loads } + loads = senv.loads@oldsenv.loads; + local_retroknowledge = senv.local_retroknowledge@oldsenv.local_retroknowledge } (* Adding parameters to modules or module types *) @@ -334,7 +395,8 @@ let add_module_parameter mbid mte senv = revsign = []; revstruct = []; imports = senv.imports; - loads = [] } + loads = []; + local_retroknowledge = senv.local_retroknowledge } (* Interactive module types *) @@ -356,7 +418,9 @@ let start_modtype l senv = revsign = []; revstruct = []; imports = senv.imports; - loads = [] } + loads = []; + (* spiwack: not 100% sure, but I think it should be like that *) + local_retroknowledge = []} let end_modtype l senv = let oldsenv = senv.old in @@ -396,7 +460,11 @@ let end_modtype l senv = revsign = (l,SPBmodtype mtb)::oldsenv.revsign; revstruct = (l,SEBmodtype mtb)::oldsenv.revstruct; imports = senv.imports; - loads = senv.loads@oldsenv.loads } + loads = senv.loads@oldsenv.loads; + (* spiwack : if there is a bug with retroknowledge in nested modules + it's likely to come from here *) + local_retroknowledge = + senv.local_retroknowledge@oldsenv.local_retroknowledge} let current_modpath senv = senv.modinfo.modpath @@ -422,7 +490,6 @@ let set_engagement c senv = type compiled_library = dir_path * module_body * library_info list * engagement option - (* We check that only initial state Require's were performed before [start_library] was called *) @@ -455,7 +522,10 @@ let start_library dir senv = revsign = []; revstruct = []; imports = senv.imports; - loads = [] } + loads = []; + local_retroknowledge = [] } + + let export senv dir = @@ -475,7 +545,8 @@ let export senv dir = mod_type = MTBsig (modinfo.msid, List.rev senv.revsign); mod_user_type = None; mod_equiv = None; - mod_constraints = Constraint.empty } + mod_constraints = Constraint.empty; + mod_retroknowledge = senv.local_retroknowledge} in modinfo.msid, (dir,mb,senv.imports,engagement senv.env) @@ -492,6 +563,8 @@ let check_imports senv needed = in List.iter check needed + + (* we have an inefficiency: Since loaded files are added to the environment every time a module is closed, their components are calculated many times. Thic could be avoided in several ways: @@ -571,3 +644,6 @@ let j_type j = j.uj_type let safe_infer senv = infer (env_of_senv senv) let typing senv = Typeops.typing (env_of_senv senv) + + + diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 1b4d932b5..fe028c073 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -126,3 +126,12 @@ val safe_infer : safe_environment -> constr -> judgment * Univ.constraints val typing : safe_environment -> constr -> judgment + +(*spiwack: safe retroknowledge functionalities *) + +open Retroknowledge + +val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a + +val register : safe_environment -> field -> Retroknowledge.entry -> constr + -> safe_environment diff --git a/kernel/term.ml b/kernel/term.ml index 6a0fe60f6..3386f45f5 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -1182,3 +1182,49 @@ type values +(* spiwack : internal representation printing *) +let string_of_sorts = + function + | Prop Pos -> "Prop Pos" + | Prop Null -> "Prop Null" + | Type u -> "Type "^string_of_universe u + +let string_of_cast_kind = + function + |VMcast -> "VMcast" + | DEFAULTcast -> "DEFAULTcast" + +let rec string_of_constr = + let string_of_term string_of_expr string_of_type = function + | Rel i -> "Rel "^string_of_int i + | Var id -> "Var "^string_of_identifier id + | Meta mv -> "Meta "^"mv?" (* need a function for printing metavariables *) + | Evar ev -> "Evar "^"ev?" (* ?? of 'constr pexistential *) + | Sort s -> "Sort "^string_of_sorts s + | Cast (e,ck,t) -> + "Cast ("^string_of_expr e^", "^string_of_cast_kind ck^", "^ + string_of_type t^")" + | Prod (n, t1, t2) -> + "Prod ("^string_of_name n^", "^string_of_type t1^", "^ + string_of_type t2^")" + | Lambda (n,t,e) -> + "Lambda ("^string_of_name n^", "^string_of_type t^", "^ + string_of_expr e^")" + | LetIn (n, e1, t, e2) -> + "LetIn ("^string_of_name n^", "^string_of_expr e1^", "^ + string_of_type t^", "^string_of_expr e2^")" + | App (e, args) -> "App ("^string_of_expr e^", [|"^ + String.concat "; " (Array.to_list (Array.map string_of_expr args)) ^ + "|])" + | Const c -> "Const "^string_of_constant c + | Ind ind -> "Ind "^string_of_inductive ind + | Construct ctr -> "Construct "^string_of_constructor ctr + | Case(_,_,_,_) -> "Case ..." + (* of case_info * 'constr * 'constr * 'constr array *) + | Fix _ -> "Fix ..." (* of ('constr, 'types) pfixpoint *) + | CoFix _ -> "CoFix ..." (* of ('constr, 'types) pcofixpoint *) +in +fun x -> string_of_term string_of_constr string_of_constr x + + +(* /spiwack *) diff --git a/kernel/term.mli b/kernel/term.mli index 0d40da969..4133ca892 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -547,3 +547,9 @@ val hcons1_types : types -> types (**************************************) type values + + +(*************************************************************) + +(* spiwack: printing of internal representation of constr *) +val string_of_constr : constr -> string diff --git a/kernel/univ.ml b/kernel/univ.ml index 17bd10fc9..1abc393b5 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -575,3 +575,18 @@ module Huniv = let hcons1_univ u = let _,_,hdir,_,_,_ = Names.hcons_names() in Hashcons.simple_hcons Huniv.f hdir u + + + +(* spiwack: function for internal representation printing *) +let string_of_universe = + let string_of_universe_level = function + | Base -> "Base" + | Level (path,i) -> "Level ("^Names.string_of_dir_path path^", "^string_of_int i^")" +in +function + | Atom u -> "Atom "^string_of_universe_level u + | Max (l1,l2) -> "Max (["^ + String.concat "; " (List.map string_of_universe_level l1)^"], ["^ + String.concat "; " (List.map string_of_universe_level l2) + ^"])" diff --git a/kernel/univ.mli b/kernel/univ.mli index 518c4a62b..39505173e 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -77,3 +77,7 @@ val pr_universes : universes -> Pp.std_ppcmds val dump_universes : out_channel -> universes -> unit val hcons1_univ : universe -> universe + + +(* spiwack: function for internal representation printing *) +val string_of_universe : universe -> string diff --git a/lib/bigint.ml b/lib/bigint.ml index 680424275..a836d0e07 100644 --- a/lib/bigint.ml +++ b/lib/bigint.ml @@ -350,6 +350,29 @@ let is_pos_or_zero n = is_pos_or_zero (ints_of_z n) let pr_bigint n = str (to_string n) +(* spiwack: computes n^m *) +(* The basic idea of the algorithm is that n^(2m) = (n^2)^m *) +(* In practice the algorithm performs : + k*n^0 = k + k*n^(2m) = k*(n*n)^m + k*n^(2m+1) = (n*k)*(n*n)^m *) +let pow = + let rec pow_aux odd_rest n m = (* odd_rest is the k from above *) + if is_neg_or_zero m then + odd_rest + else + let (quo,rem) = div2_with_rest m in + pow_aux + ((* [if m mod 2 = 1]*) + if rem then + mult n odd_rest + else + odd_rest ) + (* quo = [m/2] *) + (mult n n) quo + in + pow_aux one + (* Testing suite *) let check () = diff --git a/lib/bigint.mli b/lib/bigint.mli index f363d536a..69b035c45 100644 --- a/lib/bigint.mli +++ b/lib/bigint.mli @@ -42,4 +42,6 @@ val is_pos_or_zero : bigint -> bool val is_neg_or_zero : bigint -> bool val neg : bigint -> bigint +val pow : bigint -> bigint -> bigint + val pr_bigint : bigint -> std_ppcmds diff --git a/library/global.ml b/library/global.ml index 30281bcc7..0ee5533f3 100644 --- a/library/global.ml +++ b/library/global.ml @@ -151,3 +151,10 @@ let type_of_reference env = function Inductive.type_of_constructor cstr specif let type_of_global t = type_of_reference (env ()) t + + +(* spiwack: register/unregister functions for retroknowledge *) +let register field value by_clause = + let entry = kind_of_term value in + let senv = Safe_typing.register !global_env field entry by_clause in + global_env := senv diff --git a/library/global.mli b/library/global.mli index 6842a44eb..8633dba76 100644 --- a/library/global.mli +++ b/library/global.mli @@ -91,3 +91,6 @@ val import : compiled_library -> Digest.t -> module_path val type_of_global : Libnames.global_reference -> types val env_of_context : Environ.named_context_val -> Environ.env + +(* spiwack: register/unregister function for retroknowledge *) +val register : Retroknowledge.field -> constr -> constr -> unit diff --git a/parsing/g_intsyntax.ml b/parsing/g_intsyntax.ml new file mode 100644 index 000000000..e1cbbb7e0 --- /dev/null +++ b/parsing/g_intsyntax.ml @@ -0,0 +1,266 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $ $ i*) + +(* digit-based syntax for int31 and bigint *) + +open Bigint +open Libnames +open Rawterm + +(* arnaud : plan : + - path des modules int31 et bigint dans des variables + - nom des constructeurs dans des variables + - nom des scopes dans des variables + - fonction qui cree les int31 en fonction d'un entier (ce sont des bigint de coq) + <= div2 with rest 31 fois, dans un tableau d'args preconstruit + - fonction qui cree un bigint de hauteur n (en appelant deux fois la fonction + a la hauteur n-1 (sauf dans les cas ou il y a du 0)) + /!\ attention aux nombres negatifs *) + +(*** Constants for locating the int31 and bigN ***) + + + +let make_dir l = Names.make_dirpath (List.map Names.id_of_string (List.rev l)) +let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id) + +(* copied on g_zsyntax.ml, where it is said to be a temporary hack*) +(* takes a path an identifier in the form of a string list and a string, + returns a kernel_name *) +let make_kn dir id = Libnames.encode_kn (make_dir dir) (Names.id_of_string id) + + +(* int31 stuff *) +let int31_module = ["Coq"; "Ints"; "Int31"] +let int31_path = make_path int31_module "int31" +let int31_id = make_kn int31_module + + +let int31_construct = ConstructRef ((int31_id "int31",0),1) + +let int31_0 = ConstructRef ((int31_id "digits",0),1) +let int31_1 = ConstructRef ((int31_id "digits",0),2) + + +(* bigint stuff*) +let zn2z_module = ["Coq"; "Ints"; "Basic_type"] +let zn2z_path = make_path zn2z_module "zn2z" +let zn2z_id = make_kn zn2z_module + +let zn2z_W0 = ConstructRef ((zn2z_id "zn2z",0),1) +let zn2z_WW = ConstructRef ((zn2z_id "zn2z",0),2) + +let bigN_module = ["Coq"; "Ints"; "BigN"] +let bigN_path = make_path bigN_module "bigN" +(* big ugly hack *) +let bigN_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigN_module)), + Names.mk_label "BigN")), + [], Names.id_of_string id) : Names.kernel_name) + +(* number of inlined level of bigN (actually the level 0 to n_inlined-1 are inlined) *) +let n_inlined = of_string "13" +let bigN_constructor = + (* converts a bigint into an int the ugly way *) + let rec to_int i = + if equal i zero then + 0 + else + let (quo,rem) = div2_with_rest i in + if rem then + 2*(to_int quo)+1 + else + 2*(to_int quo) + in + fun i -> + ConstructRef ((bigN_id "t_",0), + if less_than i n_inlined then + (to_int i)+1 + else + (to_int n_inlined)+1 + ) + +(*** Definition of the Non_closed exception, used in the pretty printing ***) +exception Non_closed + +(*** Parsing for int31 in digital notation ***) + +(* parses a *non-negative* integer (from bigint.ml) into an int31 + wraps modulo 2^31 *) +let int31_of_pos_bigint dloc n = + let ref_construct = RRef (dloc, int31_construct) in + let ref_0 = RRef (dloc, int31_0) in + let ref_1 = RRef (dloc, int31_1) in + let rec args counter n = + if counter <= 0 then + [] + else + let (q,r) = div2_with_rest n in + (if r then ref_1 else ref_0)::(args (counter-1) q) + in + RApp (dloc, ref_construct, List.rev (args 31 n)) + +let error_negative dloc = + Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers") + +let interp_int31 dloc n = + if is_pos_or_zero n then + int31_of_pos_bigint dloc n + else + error_negative dloc + +(* Pretty prints an int31 *) + +let bigint_of_int31 = + let rec args_parsing args cur = + match args with + | [] -> cur + | (RRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur) + | (RRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | _ -> raise Non_closed + in + function + | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero + | _ -> raise Non_closed + +let uninterp_int31 i = + try + Some (bigint_of_int31 i) + with Non_closed -> + None + +(* Actually declares the interpreter for int31 *) +let _ = Notation.declare_numeral_interpreter "int31_scope" + (int31_path, int31_module) + interp_int31 + ([RRef (Util.dummy_loc, int31_construct)], + uninterp_int31, + true) + + +(*** Parsing for BigN in digital notation ***) +(* the base for BigN (in Coq) that is 2^31 in our case *) +let base = pow two (of_string "31") + +(* base of the bigN of height N : *) +let rank n = pow base (pow two n) + +(* splits a number bi at height n, that is the rest needs 2^n int31 to be stored + it is expected to be used only when the quotient would also need 2^n int31 to be + stored *) +let split_at n bi = + euclid bi (rank (sub_1 n)) + +(* search the height of the Coq bigint needed to represent the integer bi *) +let height bi = + let rec height_aux n = + if less_than bi (rank n) then + n + else + height_aux (add_1 n) + in + height_aux zero + + +(* n must be a non-negative integer (from bigint.ml) *) +let word_of_pos_bigint dloc hght n = + let ref_W0 = RRef (dloc, zn2z_W0) in + let ref_WW = RRef (dloc, zn2z_WW) in + let rec decomp hgt n = + if is_neg_or_zero hgt then + int31_of_pos_bigint dloc n + else if equal n zero then + RApp (dloc, ref_W0, [RHole (dloc, Evd.InternalHole)]) + else + let (h,l) = split_at hgt n in + RApp (dloc, ref_WW, [RHole (dloc, Evd.InternalHole); + decomp (sub_1 hgt) h; + decomp (sub_1 hgt) l]) + in + decomp hght n + +let bigN_of_pos_bigint dloc n = + let ref_constructor i = RRef (dloc, bigN_constructor i) in + let result h word = RApp (dloc, ref_constructor h, if less_than h n_inlined then + [word] + else + [RHole (dloc, Evd.InternalHole); + word]) + in + let hght = height n in + result hght (word_of_pos_bigint dloc hght n) + +let bigN_error_negative dloc = + Util.user_err_loc (dloc, "interp_bigN", Pp.str "bogN are only non-negative numbers") + +let interp_bigN dloc n = + if is_pos_or_zero n then + bigN_of_pos_bigint dloc n + else + bigN_error_negative dloc + + +(* Pretty prints a bigN *) + +let bigint_of_word = + let rec get_height rc = + match rc with + | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW -> + let hleft = get_height lft in + let hright = get_height rght in + if less_than hleft hright then + hright + else + hleft + | _ -> zero + in + let rec transform hght rc = + match rc with + | RApp (_,RRef(_,c),_) when c = zn2z_W0-> zero + | RApp (_,RRef(_,c), [_;lft;rght]) when c=zn2z_WW-> add (mult (rank hght) + (transform (sub_1 hght) lft)) + (transform (sub_1 hght) rght) + | _ -> bigint_of_int31 rc + in + fun rc -> + let hght = get_height rc in + transform hght rc + +let bigint_of_bigN rc= + match rc with + | RApp (_,_,[one_arg]) -> bigint_of_word one_arg + | RApp (_,_,[_;second_arg]) -> bigint_of_word second_arg + | _ -> raise Non_closed + +let uninterp_bigN rc = + try + Some (bigint_of_bigN rc) + with Non_closed -> + None + + +(* declare the list of constructors of bigN used in the declaration of the + numeral interpreter *) + +let bigN_list_of_constructors = + let rec build i = + if less_than i (add_1 n_inlined) then + RRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i)) + else + [] + in + build zero + +(* Actually declares the interpreter for bigN *) +let _ = Notation.declare_numeral_interpreter "bigN_scope" + (bigN_path, bigN_module) + interp_bigN + (bigN_list_of_constructors, + uninterp_bigN, + true) diff --git a/parsing/g_intsyntax.mli b/parsing/g_intsyntax.mli new file mode 100644 index 000000000..c74ae5788 --- /dev/null +++ b/parsing/g_intsyntax.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + + +(*i $$ i*) + + +(* digit based syntax for int31 and bigint *) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 8c6e1a547..73e366c93 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -626,7 +626,8 @@ GEXTEND Gram | IDENT "Scope"; s = IDENT -> PrintScope s | IDENT "Visibility"; s = OPT IDENT -> PrintVisibility s | IDENT "Implicit"; qid = global -> PrintImplicit qid - | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses fopt ] ] + | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses fopt + | IDENT "Assumptions"; qid = global -> PrintNeededAssumptions qid ] ] ; class_rawexpr: [ [ IDENT "Funclass" -> FunClass diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml index 7ccd8dd65..62af97b43 100644 --- a/parsing/ppvernac.ml +++ b/parsing/ppvernac.ml @@ -814,12 +814,15 @@ let rec pr_vernac = function | PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid | PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid | PrintInspect n -> str"Inspect" ++ spc() ++ int n - | PrintSetoids -> str"Print Setoids" + | PrintSetoids -> str"Print Setoids" | PrintScopes -> str"Print Scopes" | PrintScope s -> str"Print Scope" ++ spc() ++ str s | PrintVisibility s -> str"Print Visibility" ++ pr_opt str s | PrintAbout qid -> str"About" ++ spc() ++ pr_reference qid | PrintImplicit qid -> str"Print Implicit" ++ spc() ++ pr_reference qid +(* spiwack: command printing all the axioms and section variables used in a + term *) + | PrintNeededAssumptions qid -> str"Print Needed Assumptions"++spc()++pr_reference qid in pr_printable p | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_pattern_expr | VernacLocate loc -> diff --git a/parsing/printer.ml b/parsing/printer.ml index 7272ee697..df078f302 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -468,3 +468,30 @@ let pr_prim_rule = function let prterm = pr_lconstr + +(* spiwack a little printer function for sets of Environ.assumption *) +(* arnaud : tester "Print Assumptions" *) +let pr_assumptionset env s = + if not (Environ.AssumptionSet.is_empty s) then + let (vars, axioms) = Environ.AssumptionSet.partition + (function |Variable _ -> true | _ -> false) s + in + (if not (Environ.AssumptionSet.is_empty vars) then + str "Section Variables:" ++ fnl () ++ + (Environ.AssumptionSet.fold + (function Variable (id,typ ) -> fun s -> + str (string_of_identifier id)++str " : "++pr_ltype typ++spc ()++s) + vars (fnl ())) + else + mt () + )++ + if not (Environ.AssumptionSet.is_empty axioms) then + str "Axioms:" ++ fnl () ++ + (Environ.AssumptionSet.fold + (function Axiom (cst, typ) -> fun s -> (pr_constant env cst)++str " : "++pr_ltype typ++spc ()++s) + axioms (mt ())) + else + mt () + else + raise Not_found + diff --git a/parsing/printer.mli b/parsing/printer.mli index 00cf4984d..4e09e0251 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -108,6 +108,11 @@ val emacs_str : string -> string -> string val prterm : constr -> std_ppcmds (* = pr_lconstr *) + +(* spiwack: A printer for sets of Environ.assumption *) +val pr_assumptionset : env -> Environ.AssumptionSet.t -> std_ppcmds + + type printer_pr = { pr_subgoals : string option -> evar_map -> goal list -> std_ppcmds; pr_subgoal : int -> goal list -> std_ppcmds; @@ -117,3 +122,4 @@ type printer_pr = { val set_printer_pr : printer_pr -> unit val default_printer_pr : printer_pr + diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 46d67406a..8103bdafb 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -52,14 +52,63 @@ let type_constructor mind mib typ params = let _,ctyp = decompose_prod_n nparams ctyp in substl (List.rev (Array.to_list params)) ctyp +(* arnaud: to clean +(* spiwack: auxiliary fonction for decompiling 31-bit integers + into their corresponding constr *) +let constr_of_int31 = + let nth_digit_plus_one i n = (* calculates the nth (starting with 0) + digit of i and adds 1 to it + (nth_digit_plus_one 1 3 = 2) *) + if (land) i ((lsl) 1 n) = 0 then + 1 + else + 2 + in + fun tag -> fun ind-> + let digit_ind = Retroknowledge.digits_of_int31 ind + in + let array_of_int i = + Array.init 31 (fun n -> mkConstruct(digit_ind, nth_digit_plus_one i (30-n))) + in + mkApp(mkConstruct(ind, 1), array_of_int tag) *) + +(* /spiwack *) +(* arnaud +let construct_of_constr_const env tag typ = + let ind,params = find_rectype env typ in + (* arnaud:improve comment ? *) + (* spiwack: branching for 31-bits integers *) +(* arnaud: + if Retroknowledge.isInt31t ind then + constr_of_int31 tag ind + else *) + try + retroknowledge Retroknowledge.get_vm_decompile_constant_info env (Ind ind) tag + with Not_found -> + let (_,mip) = lookup_mind_specif env ind in + let i = invert_tag true tag mip.mind_reloc_tbl in + applistc (mkConstruct(ind,i)) params *) + let construct_of_constr const env tag typ = let (mind,_ as ind), allargs = find_rectype_a env typ in - let mib,mip = lookup_mind_specif env ind in - let nparams = mib.mind_nparams in - let i = invert_tag const tag mip.mind_reloc_tbl in - let params = Array.sub allargs 0 nparams in - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in - (mkApp(mkConstruct(ind,i), params), ctyp) + (* spiwack : here be a branch for specific decompilation handled by retroknowledge *) + try + if const then + ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (Ind ind) tag), + typ) (*spiwack: this may need to be changed in case there are parameters in the + type which may cause a constant value to have an arity. + (type_constructor seems to be all about parameters actually) + but it shouldn't really matter since constant values don't use + their ctyp in the rest of the code.*) + else + raise Not_found (* No retroknowledge function (yet) for block decompilation *) + with Not_found -> + let mib,mip = lookup_mind_specif env ind in + let nparams = mib.mind_nparams in + let i = invert_tag const tag mip.mind_reloc_tbl in + let params = Array.sub allargs 0 nparams in + let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in + (mkApp(mkConstruct(ind,i), params), ctyp) let construct_of_constr_const env tag typ = fst (construct_of_constr true env tag typ) diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 498afee99..327bd24f7 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -236,3 +236,108 @@ let raw_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause snd let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x) +(* spiwack argument for the commands of the retroknowledge *) + +let (wit_r_nat_field, globwit_r_nat_field, rawwit_r_nat_field) = + Genarg.create_arg "r_nat_field" +let (wit_r_n_field, globwit_r_n_field, rawwit_r_n_field) = + Genarg.create_arg "r_n_field" +let (wit_r_int31_field, globwit_r_int31_field, rawwit_r_int31_field) = + Genarg.create_arg "r_int31_field" +let (wit_r_field, globwit_r_field, rawwit_r_field) = + Genarg.create_arg "r_field" + +(* spiwack: the print functions are incomplete, but I don't know what they are + used for *) +let pr_r_nat_field _ _ _ natf = + str "nat " ++ + match natf with + | Retroknowledge.NatType -> str "type" + | Retroknowledge.NatPlus -> str "plus" + | Retroknowledge.NatTimes -> str "times" + +let pr_r_n_field _ _ _ nf = + str "binary N " ++ + match nf with + | Retroknowledge.NPositive -> str "positive" + | Retroknowledge.NType -> str "type" + | Retroknowledge.NTwice -> str "twice" + | Retroknowledge.NTwicePlusOne -> str "twice plus one" + | Retroknowledge.NPhi -> str "phi" + | Retroknowledge.NPhiInv -> str "phi inv" + | Retroknowledge.NPlus -> str "plus" + | Retroknowledge.NTimes -> str "times" + +let pr_r_int31_field _ _ _ i31f = + str "int31 " ++ + match i31f with + | Retroknowledge.Int31Bits -> str "bits" + | Retroknowledge.Int31Type -> str "type" + | Retroknowledge.Int31Twice -> str "twice" + | Retroknowledge.Int31TwicePlusOne -> str "twice plus one" + | Retroknowledge.Int31Phi -> str "phi" + | Retroknowledge.Int31PhiInv -> str "phi inv" + | Retroknowledge.Int31Plus -> str "plus" + | Retroknowledge.Int31Times -> str "times" + +let pr_retroknowledge_field _ _ _ f = + match f with + | Retroknowledge.KEq -> str "equality" + | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf + | Retroknowledge.KN nf -> pr_r_n_field () () () nf + | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field () () () i31f) ++ + str "in " ++ str group + +ARGUMENT EXTEND retroknowledge_nat +TYPED AS r_nat_field +PRINTED BY pr_r_nat_field +| [ "nat" "type" ] -> [ Retroknowledge.NatType ] +| [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ] +| [ "nat" "times" ] -> [ Retroknowledge.NatTimes ] +END + + +ARGUMENT EXTEND retroknowledge_binary_n +TYPED AS r_n_field +PRINTED BY pr_r_n_field +| [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] +| [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] +| [ "binary" "N" "twice" ] -> [ Retroknowledge.NTwice ] +| [ "binary" "N" "twice" "plus" "one" ] -> [ Retroknowledge.NTwicePlusOne ] +| [ "binary" "N" "phi" ] -> [ Retroknowledge.NPhi ] +| [ "binary" "N" "phi" "inv" ] -> [ Retroknowledge.NPhiInv ] +| [ "binary" "N" "plus" ] -> [ Retroknowledge.NPlus ] +| [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ] +END + +ARGUMENT EXTEND retroknowledge_int31 +TYPED AS r_int31_field +PRINTED BY pr_r_int31_field +| [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] +| [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] +| [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ] +| [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ] +| [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ] +| [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ] +| [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ] +| [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ] +| [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ] +| [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ] +| [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ] +| [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ] +| [ "int31" "times" ] -> [ Retroknowledge.Int31Times ] +| [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] +| [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] +| [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] +| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] +| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] +END + +ARGUMENT EXTEND retroknowledge_field +TYPED AS r_field +PRINTED BY pr_retroknowledge_field +| [ "equality" ] -> [ Retroknowledge.KEq ] +| [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] +| [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ] +| [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ] +END
\ No newline at end of file diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 6534163bb..a1da9d2b3 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -50,3 +50,11 @@ val glob_in_arg_hyp_to_clause : (Names.identifier list option * bool) -> Tacti val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.e val rawwit_by_arg_tac : raw_tactic_expr option raw_abstract_argument_type val wit_by_arg_tac : glob_tactic_expr option closed_abstract_argument_type + + + +(* Spiwack: Primitive for retroknowledge registration *) + +val retroknowledge_field : Retroknowledge.field Pcoq.Gram.Entry.e +val rawwit_retroknowledge_field : Retroknowledge.field raw_abstract_argument_type +val wit_retroknowledge_field : Retroknowledge.field closed_abstract_argument_type diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 4ee02e0b8..d51d17aaf 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -400,14 +400,47 @@ VERNAC COMMAND EXTEND ImplicitTactic [ Tacinterp.declare_implicit_tactic (Tacinterp.interp tac) ] END + + + +(*spiwack : Vernac commands for retroknowledge *) + +VERNAC COMMAND EXTEND RetroknowledgeRegister + | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> + [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in + let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in + Global.register f tc tb ] +END + +(* spiwack : Vernac commands for developement *) + +(* arnaud : comment out/clear ? *) +VERNAC COMMAND EXTEND InternalRepresentation (* Prints internal representation of the argument *) +| [ "Internal" "Representation" "of" constr(t) ] -> + [ let t' = Constrintern.interp_constr Evd.empty (Global.env ()) t in + pp (str (string_of_constr t'))] +END + +VERNAC COMMAND EXTEND Bytecode (* Prints Bytecode representation of the argument *) +| [ "Bytecode" "of" constr(t) ] -> + [ let t' = Constrintern.interp_constr Evd.empty (Global.env ()) t in + let (bc,_,_) = Cbytegen.compile (Environ.pre_env (Global.env ())) t' in + pp (str (Cbytecodes.string_of_instr bc))] +END + +(* /spiwack *) + + TACTIC EXTEND apply_in | ["apply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in false id [c] ] | ["apply" constr_with_bindings(c) "," constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] -> [ apply_in false id (c::cl) ] END + TACTIC EXTEND eapply_in | ["eapply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in true id [c] ] | ["epply" constr_with_bindings(c) "," constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] -> [ apply_in true id (c::cl) ] END + diff --git a/theories/Ints/Basic_type.v b/theories/Ints/Basic_type.v new file mode 100644 index 000000000..f481f3942 --- /dev/null +++ b/theories/Ints/Basic_type.v @@ -0,0 +1,64 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZDivModAux. +Require Import ZPowerAux. + +Open Local Scope Z_scope. + +Section Carry. + + Variable A : Set. + + Inductive carry : Set := + | C0 : A -> carry + | C1 : A -> carry. + +End Carry. + +Section Zn2Z. + + Variable znz : Set. + + Inductive zn2z : Set := + | W0 : zn2z + | WW : znz -> znz -> zn2z. + + Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) := + match x with + | W0 => 0 + | WW xh xl => w_to_Z xh * wB + w_to_Z xl + end. + + Definition base digits := Zpower 2 (Zpos digits). + + Definition interp_carry sign B (interp:znz -> Z) c := + match c with + | C0 x => interp x + | C1 x => sign*B + interp x + end. + +End Zn2Z. + +Implicit Arguments W0 [znz]. + +Fixpoint word_tr (w:Set) (n:nat) {struct n} : Set := + match n with + | O => w + | S n => word_tr (zn2z w) n + end. + +Fixpoint word (w:Set) (n:nat) {struct n} : Set := + match n with + | O => w + | S n => zn2z (word w n) + end. + diff --git a/theories/Ints/BigN.v b/theories/Ints/BigN.v new file mode 100644 index 000000000..47a58e278 --- /dev/null +++ b/theories/Ints/BigN.v @@ -0,0 +1,111 @@ +Require Export Int31. +Require Import NMake. +Require Import ZnZ. + +Open Scope int31_scope. + +Definition int31_op : znz_op int31. + split. + + (* Conversion functions with Z *) + exact (31%positive). (* number of digits *) + exact (phi). (* conversion to Z *) + exact (positive_to_int31). (* positive -> N*int31 : p => N,i where p = N*2^31+phi i *) + exact (head031). (* number of head 0 *) + + (* Basic constructors *) + exact 0. (* 0 *) + exact 1. (* 1 *) + exact Tn. (* 2^31 - 1 *) + (* A function which given two int31 i and j, returns a double word + which is worth i*2^31+j *) + exact (fun i j => match (match i ?= 0 with | Eq => j ?= 0 | not0 => not0 end) with | Eq => W0 | _ => WW i j end). + (* two special cases where i and j are respectively taken equal to 0 *) + exact (fun i => match i ?= 0 with | Eq => W0 | _ => WW i 0 end). + exact (fun j => match j ?= 0 with | Eq => W0 | _ => WW 0 j end). + + (* Comparison *) + exact compare31. + exact (fun i => match i ?= 0 with | Eq => true | _ => false end). + + (* Basic arithmetic operations *) + (* opposite functions *) + exact (fun i => 0 -c i). + exact (fun i => 0 - i). + exact (fun i => 0-i-1). (* the carry is always -1*) + (* successor and addition functions *) + exact (fun i => i +c 1). + exact add31c. + exact add31carryc. + exact (fun i => i + 1). + exact add31. + exact (fun i j => i + j + 1). + (* predecessor and subtraction functions *) + exact (fun i => i -c 1). + exact sub31c. + exact sub31carryc. + exact (fun i => i - 1). + exact sub31. + exact (fun i j => i - j - 1). + (* multiplication functions *) + exact mul31c. + exact mul31. + exact (fun x => x *c x). + + (* special (euclidian) division operations *) + exact div3121. + exact div31. (* this is supposed to be the special case of division a/b where a > b *) + exact div31. + (* euclidian division remainder *) + (* again special case for a > b *) + exact (fun i j => let (_,r) := i/j in r). + exact (fun i j => let (_,r) := i/j in r). + (* gcd functions *) + exact gcd31. (*gcd_gt*) + exact gcd31. (*gcd*) + + (* shift operations *) + exact (fun p => let (_,i) := positive_to_int31 p in addmuldiv31 i). (*add_mul_div with positive ? *) + exact (fun p i => let (n,j) := positive_to_int31 p in (*modulo 2^p (p positive) *) + match n with + | N0 => let (_,r) := i/j in r + | _ => i + end). + (* is i even ? *) + exact (fun i => let (_,r) := i/2 in + match r ?= 0 with + | Eq => true + | _ => false + end). + + (* square root operations *) + exact sqrt312. (* sqrt2 *) + exact sqrt31. (* sqr *) +Defined. + +Definition int31_spec : znz_spec int31_op. +Admitted. + + + +Module Int31_words <: W0Type. + Definition w := int31. + Definition w_op := int31_op. + Definition w_spec := int31_spec. +End Int31_words. + +Module BigN := NMake.Make Int31_words. + +Definition bigN := BigN.t. + +Delimit Scope bigN_scope with bigN. +Bind Scope bigN_scope with bigN. +Bind Scope bigN_scope with BigN.t. +Bind Scope bigN_scope with BigN.t_. + +Notation " i + j " := (BigN.add i j) : bigN_scope. +Notation " i - j " := (BigN.sub i j) : bigN_scope. +Notation " i * j " := (BigN.mul i j) : bigN_scope. +Notation " i / j " := (BigN.div i j) : bigN_scope. +Notation " i ?= j " := (BigN.compare i j) : bigN_scope. + diff --git a/theories/Ints/Int31.v b/theories/Ints/Int31.v new file mode 100644 index 000000000..7ddccfec8 --- /dev/null +++ b/theories/Ints/Int31.v @@ -0,0 +1,388 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $ $ i*) + +(* Require Import Notations.*) +Require Export ZArith. +Require Export Basic_type. + +Unset Boxed Definitions. + +Inductive digits : Type := |D0 |D1. + +Inductive int31 : Type := +| I31 : digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits ->digits -> int31 +. + +(* spiwack: Registration of the type of integers, so that the matchs in + the functions below perform dynamic decompilation (otherwise some segfault + occur when they are applied to one non-closed term and one closed term *) +Register digits as int31 bits in "coq_int31" by True. +Register int31 as int31 type in "coq_int31" by True. + +Delimit Scope int31_scope with int31. +Bind Scope int31_scope with int31. +Open Scope int31_scope. + + +Definition size := 31%nat. +Definition sizeN := 31%N. + +Definition On := I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0. +Definition In := I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D1. +Definition Tn := I31 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1 D1. +Definition Twon := I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D1 D0. + +Definition sneakr b i := + match i with + | I31 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 => + I31 b b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 + end +. + +Definition sneakl b i := + match i with + | I31 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 => + I31 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 b + end +. + +Definition firstl i := + match i with + | I31 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 => b1 + end +. + +Definition firstr i := + match i with + | I31 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25 b26 b27 b28 b29 b30 b31 => b31 + end +. + +Definition iszero i := + match i with + | I31 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 => true + | _ => false + end +. + + +(* abstract definition : smallest b > 0 s.t. phi_inv b = 0 (see below) *) +Definition base := Eval compute in (fix base_aux (counter:nat) := + match counter with + | 0%nat => 1%Z + | S n => Zdouble (base_aux n) + end) size +. + +Definition shiftl := sneakl D0. +Definition shiftr := sneakr D0. + +Definition twice := sneakl D0. +Definition twice_plus_one := sneakl D1. + + + +(*recursors*) + +Fixpoint recl_aux (iter:nat) (A:Type) (case0:A) (caserec:digits->int31->A->A) + (i:int31) {struct iter} : A := + match iter with + | 0%nat => case0 + | S next => + if iszero i then + case0 + else + let si := shiftl i in + caserec (firstl i) si (recl_aux next A case0 caserec si) + end +. +Fixpoint recr_aux (iter:nat) (A:Type) (case0:A) (caserec:digits->int31->A->A) + (i:int31) {struct iter} : A := + match iter with + | 0%nat => case0 + | S next => + if iszero i then + case0 + else + let si := shiftr i in + caserec (firstr i) si (recr_aux next A case0 caserec si) + end +. + +Definition recl := recl_aux size. +Definition recr := recr_aux size. + + +Definition phi := + recr Z (0%Z) (fun b _ rec => (match b with | D0 => Zdouble | D1 => Zdouble_plus_one end) rec) +. + + +(* abstract definition : phi_inv (2n) = 2*phi_inv n /\ + phi_inv 2n+1 = 2*(phi_inv n) + 1 *) +Definition phi_inv := +(* simple incrementation *) +let incr := + recr int31 In (fun b si rec => match b with | D0 => sneakl D1 si | D1 => sneakl D0 rec end) +in +fun n => + match n with + | Z0 => On + | Zpos p =>(fix phi_inv_positive (p:positive) := + match p with + | xI q => twice_plus_one (phi_inv_positive q) + | xO q => twice (phi_inv_positive q) + | xH => In + end) p + | Zneg p =>incr ((fix complement_negative (p:positive) := + match p with + | xI q => twice (complement_negative q) + | xO q => twice_plus_one (complement_negative q) + | xH => twice Tn + end) p) + end +. + +(* like phi_inv but returns a double word (zn2z int31) *) +Definition phi_inv2 n := + match n with + | Z0 => W0 + | _ => WW (phi_inv (n/base)%Z) (phi_inv n) + end +. + +(* like phi but takes a double word (two args) *) +Definition phi2 nh nl := + ((phi nh)*base+(phi nl))%Z. + +(* addition modulo 2^31 *) +Definition add31 (n m : int31) := phi_inv ((phi n)+(phi m)). +Notation "n + m" := (add31 n m) : int31_scope. + +(* addition with carry (the result is thus exact) *) +Definition add31c (n m : int31) := + let npm := n+m in + match (phi npm ?= (phi n)+(phi m))%Z with (* spiwack : when executed in non-compiled*) + | Eq => C0 npm (* mode, (phi n)+(phi m) is computed twice*) + | _ => C1 npm (* it may be considered to optimize it *) + end +. +Notation "n '+c' m" := (add31c n m) (at level 50, no associativity) : int31_scope. + +(* addition plus one with carry (the result is thus exact) *) +Definition add31carryc (n m : int31) := + let npmpone_exact := ((phi n)+(phi m)+1)%Z in + let npmpone := phi_inv npmpone_exact in + match (phi npmpone ?= npmpone_exact)%Z with + | Eq => C0 npmpone + | _ => C1 npmpone + end +. + + +(* subtraction modulo 2^31 *) +Definition sub31 (n m : int31) := phi_inv ((phi n)-(phi m)). +Notation "n - m" := (sub31 n m) : int31_scope. + +(* subtraction with carry (thus exact) *) +Definition sub31c (n m : int31) := + let nmm := n-m in + match (phi nmm ?= (phi n)-(phi m))%Z with + | Eq => C0 nmm + | _ => C1 nmm + end +. +Notation "n '-c' m" := (sub31c n m) (at level 50, no associativity) : int31_scope. + +(* subtraction minus one with carry (thus exact) *) +Definition sub31carryc (n m : int31) := + let nmmmone_exact := ((phi n)-(phi m)-1)%Z in + let nmmmone := phi_inv nmmmone_exact in + match (phi nmmmone ?= nmmmone_exact)%Z with + | Eq => C0 nmmmone + | _ => C1 nmmmone + end +. + + +(* multiplication modulo 2^31 *) +Definition mul31 (n m : int31) := phi_inv ((phi n)*(phi m)). +Notation "n * m" := (mul31 n m) : int31_scope. + + + +(* multiplication with double word result (thus exact) *) +Definition mul31c (n m : int31) := phi_inv2 ((phi n)*(phi m)). +Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scope. + +(* division of a double size word modulo 2^31 *) +Definition div3121 (nh nl m : int31) := + let (q,r) := Zdiv_eucl (phi2 nh nl) (phi m) in + (phi_inv q, phi_inv r) +. + +(* division modulo 2^31 *) +Definition div31 (n m : int31) := + let (q,r) := Zdiv_eucl (phi n) (phi m) in + (phi_inv q, phi_inv r) +. +Notation "n / m" := (div31 n m) : int31_scope. + +(* unsigned comparison *) +Definition compare31 (n m : int31) := ((phi n)?=(phi m))%Z. +Notation "n ?= m" := (compare31 n m) (at level 70, no associativity) : int31_scope. + +(* [iter_int31 i A f x] = f^i x *) +Definition iter_int31 i A f x := + recr (A->A) (fun x => x) (fun b si rec => match b with + | D0 => fun x => rec (rec x) + | D1 => fun x => f (rec (rec x)) + end) + i x +. + +(* [addmuldiv31 p i j] = i*2^p+y/2^(31-p) (modulo 2^31) *) +Definition addmuldiv31 p i j := + let (res, _ ) := + iter_int31 p (int31*int31) (fun ij => let (i,j) := ij in + (sneakl (firstl j) i, shiftl j)) + (i,j) + in + res +. + + +Register add31 as int31 plus in "coq_int31" by True. +Register add31c as int31 plusc in "coq_int31" by True. +Register add31carryc as int31 pluscarryc in "coq_int31" by True. +Register sub31 as int31 minus in "coq_int31" by True. +Register sub31c as int31 minusc in "coq_int31" by True. +Register sub31carryc as int31 minuscarryc in "coq_int31" by True. +Register mul31 as int31 times in "coq_int31" by True. +Register mul31c as int31 timesc in "coq_int31" by True. +Register div3121 as int31 div21 in "coq_int31" by True. +Register div31 as int31 div in "coq_int31" by True. +Register compare31 as int31 compare in "coq_int31" by True. +Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True. + +Definition gcd31 (i j:int31) := + (fix euler (guard:nat) (i j:int31) {struct guard} := + match guard with + | 0%nat => In + | S p => match j ?= On with + | Eq => i + | _ => euler p j (let (_, r ) := i/j in r) + end + end) + size i j +. + +Definition sqrt31 (i:int31) := + match i ?= On with + | Eq => On + | _ => + (fix babylon (guard:nat) (r:int31) {struct guard} := + match guard with + | 0%nat => r + | S p => + let (quo, _) := i/r in + match quo ?= r with + | Eq => r + | _ => let (avrg, _) := (quo+r)/(Twon) in babylon p avrg + end + end) + size (let (approx, _) := (i/Twon) in approx+In) (* approx + 1 > 0 *) + end +. + +Definition sqrt312 (ih il:int31) := + match (match ih ?= On with | Eq => il ?= On | not0 => not0 end) with + | Eq => (On, C0 On) + | _ => let root := + (fix dichotomy (guard:nat) (r upper lower:int31) {struct guard} := + match guard with + | 0%nat => r (* arnaud : pas On *) + | S p => + match r*c r with + | W0 => dichotomy p + (let (quo, _) := (r+upper)/Twon in quo) + upper r (* because 0 < WW ih il *) + | WW jh jl => match (match ih ?= jh with + | Eq => il ?= jl + | noteq => noteq + end) + with + | Eq => r + | Lt => + match (r + In)*c (r + In) with + | W0 => (* this case should not araise *) + dichotomy p + (let (quo, _) := (r+upper)/Twon in quo) + upper r + | WW jh1 jl1 => + match (match ih ?= jh1 with + | Eq => il ?= jl1 + | noteq => noteq + end) + with + | Eq => r + In + | Gt => r + | Lt => dichotomy p + (let (quo, _) := (r+upper)/Twon in quo) + upper r + end + end + | Gt => dichotomy p + (let (quo, _) := (r+lower)/Twon in quo) + r lower + end + end + end) + size (let (quo,_) := Tn/Twon in quo) Tn On + in + let square := root *c root in + let rem := match square with + | W0 => C0 il (* this case should not occure *) + | WW sh sl => match il -c sl with + | C0 reml => match ih - sh ?= On with + | Eq => C0 reml + | _ => C1 reml + end + | C1 reml => match ih - sh - In ?= On with + | Eq => C0 reml + | _ => C1 reml + end + end + end + in + (root, rem) + end +. + +Definition positive_to_int31 (p:positive) := + (fix aux (max_digit:nat) (p:positive) {struct p} : (N*int31)%type := + match max_digit with + | 0%nat => (Npos p, On) + | S md => match p with + | xO p' => let (r,i) := aux md p' in (r, Twon*i) + | xI p' => let (r,i) := aux md p' in (r, Twon*i+In) + | xH => (N0, In) + end + end) + size p +. + +Definition head031 (i:int31) := + recl _ (fun _ => sizeN) (fun b si rec n => match b with + | D0 => rec (n+1)%N + | D1 => n + end) + i 0%N +.
\ No newline at end of file diff --git a/theories/Ints/List/Iterator.v b/theories/Ints/List/Iterator.v new file mode 100644 index 000000000..327a1454b --- /dev/null +++ b/theories/Ints/List/Iterator.v @@ -0,0 +1,180 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Export List. +Require Export LPermutation. +Require Import Arith. + +Section Iterator. +Variables A B : Set. +Variable zero : B. +Variable f : A -> B. +Variable g : B -> B -> B. +Hypothesis g_zero : forall a, g a zero = a. +Hypothesis g_trans : forall a b c, g a (g b c) = g (g a b) c. +Hypothesis g_sym : forall a b, g a b = g b a. + +Definition iter := fold_right (fun a r => g (f a) r) zero. +Hint Unfold iter . + +Theorem iter_app: forall l1 l2, iter (app l1 l2) = g (iter l1) (iter l2). +intros l1; elim l1; simpl; auto. +intros l2; rewrite g_sym; auto. +intros a l H l2; rewrite H. +rewrite g_trans; auto. +Qed. + +Theorem iter_permutation: forall l1 l2, permutation l1 l2 -> iter l1 = iter l2. +intros l1 l2 H; elim H; simpl; auto; clear H l1 l2. +intros a l1 l2 H1 H2; apply f_equal2 with ( f := g ); auto. +intros a b l; (repeat rewrite g_trans). +apply f_equal2 with ( f := g ); auto. +intros l1 l2 l3 H H0 H1 H2; apply trans_equal with ( 1 := H0 ); auto. +Qed. + +Lemma iter_inv: + forall P l, + P zero -> + (forall a b, P a -> P b -> P (g a b)) -> + (forall x, In x l -> P (f x)) -> P (iter l). +intros P l H H0; (elim l; simpl; auto). +Qed. +Variable next : A -> A. + +Fixpoint progression (m : A) (n : nat) {struct n} : list A := + match n with 0 => nil + | S n1 => cons m (progression (next m) n1) end. + +Fixpoint next_n (c : A) (n : nat) {struct n} : A := + match n with 0 => c | S n1 => next_n (next c) n1 end. + +Theorem progression_app: + forall a b n m, + le m n -> + b = next_n a m -> + progression a n = app (progression a m) (progression b (n - m)). +intros a b n m; generalize a b n; clear a b n; elim m; clear m; simpl. +intros a b n H H0; apply f_equal2 with ( f := progression ); auto with arith. +intros m H a b n; case n; simpl; clear n. +intros H1; absurd (0 < 1 + m); auto with arith. +intros n H0 H1; apply f_equal2 with ( f := @cons A ); auto with arith. +Qed. + +Let iter_progression := fun m n => iter (progression m n). + +Theorem iter_progression_app: + forall a b n m, + le m n -> + b = next_n a m -> + iter (progression a n) = + g (iter (progression a m)) (iter (progression b (n - m))). +intros a b n m H H0; unfold iter_progression; rewrite (progression_app a b n m); + (try apply iter_app); auto. +Qed. + +Theorem length_progression: forall z n, length (progression z n) = n. +intros z n; generalize z; elim n; simpl; auto. +Qed. + +End Iterator. +Implicit Arguments iter [A B]. +Implicit Arguments progression [A]. +Implicit Arguments next_n [A]. +Hint Unfold iter . +Hint Unfold progression . +Hint Unfold next_n . + +Theorem iter_ext: + forall (A B : Set) zero (f1 : A -> B) f2 g l, + (forall a, In a l -> f1 a = f2 a) -> iter zero f1 g l = iter zero f2 g l. +intros A B zero f1 f2 g l; elim l; simpl; auto. +intros a l0 H H0; apply f_equal2 with ( f := g ); auto. +Qed. + +Theorem iter_map: + forall (A B C : Set) zero (f : B -> C) g (k : A -> B) l, + iter zero f g (map k l) = iter zero (fun x => f (k x)) g l. +intros A B C zero f g k l; elim l; simpl; auto. +intros; apply f_equal2 with ( f := g ); auto with arith. +Qed. + +Theorem iter_comp: + forall (A B : Set) zero (f1 f2 : A -> B) g l, + (forall a, g a zero = a) -> + (forall a b c, g a (g b c) = g (g a b) c) -> + (forall a b, g a b = g b a) -> + g (iter zero f1 g l) (iter zero f2 g l) = + iter zero (fun x => g (f1 x) (f2 x)) g l. +intros A B zero f1 f2 g l g_zero g_trans g_sym; elim l; simpl; auto. +intros a l0 H; rewrite <- H; (repeat rewrite <- g_trans). +apply f_equal2 with ( f := g ); auto. +(repeat rewrite g_trans); apply f_equal2 with ( f := g ); auto. +Qed. + +Theorem iter_com: + forall (A B : Set) zero (f : A -> A -> B) g l1 l2, + (forall a, g a zero = a) -> + (forall a b c, g a (g b c) = g (g a b) c) -> + (forall a b, g a b = g b a) -> + iter zero (fun x => iter zero (fun y => f x y) g l1) g l2 = + iter zero (fun y => iter zero (fun x => f x y) g l2) g l1. +intros A B zero f g l1 l2 H H0 H1; generalize l2; elim l1; simpl; auto; + clear l1 l2. +intros l2; elim l2; simpl; auto with arith. +intros; rewrite H1; rewrite H; auto with arith. +intros a l1 H2 l2; case l2; clear l2; simpl; auto. +elim l1; simpl; auto with arith. +intros; rewrite H1; rewrite H; auto with arith. +intros b l2. +rewrite <- (iter_comp + _ _ zero (fun x => f x a) + (fun x => iter zero (fun (y : A) => f x y) g l1)); auto with arith. +rewrite <- (iter_comp + _ _ zero (fun y => f b y) + (fun y => iter zero (fun (x : A) => f x y) g l2)); auto with arith. +(repeat rewrite H0); auto. +apply f_equal2 with ( f := g ); auto. +(repeat rewrite <- H0); auto. +apply f_equal2 with ( f := g ); auto. +Qed. + +Theorem iter_comp_const: + forall (A B : Set) zero (f : A -> B) g k l, + k zero = zero -> + (forall a b, k (g a b) = g (k a) (k b)) -> + k (iter zero f g l) = iter zero (fun x => k (f x)) g l. +intros A B zero f g k l H H0; elim l; simpl; auto. +intros a l0 H1; rewrite H0; apply f_equal2 with ( f := g ); auto. +Qed. + +Lemma next_n_S: forall n m, next_n S n m = plus n m. +intros n m; generalize n; elim m; clear n m; simpl; auto with arith. +intros m H n; case n; simpl; auto with arith. +rewrite H; auto with arith. +intros n1; rewrite H; simpl; auto with arith. +Qed. + +Theorem progression_S_le_init: + forall n m p, In p (progression S n m) -> le n p. +intros n m; generalize n; elim m; clear n m; simpl; auto. +intros; contradiction. +intros m H n p [H1|H1]; auto with arith. +subst n; auto. +apply le_S_n; auto with arith. +Qed. + +Theorem progression_S_le_end: + forall n m p, In p (progression S n m) -> lt p (n + m). +intros n m; generalize n; elim m; clear n m; simpl; auto. +intros; contradiction. +intros m H n p [H1|H1]; auto with arith. +subst n; auto with arith. +rewrite <- plus_n_Sm; auto with arith. +rewrite <- plus_n_Sm; auto with arith. +generalize (H (S n) p); auto with arith. +Qed. diff --git a/theories/Ints/List/LPermutation.v b/theories/Ints/List/LPermutation.v new file mode 100644 index 000000000..9270ded43 --- /dev/null +++ b/theories/Ints/List/LPermutation.v @@ -0,0 +1,509 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + Permutation.v + + Defintion and properties of permutations + **********************************************************************) +Require Export List. +Require Export ListAux. + +Section permutation. +Variable A : Set. + +(************************************** + Definition of permutations as sequences of adjacent transpositions + **************************************) + +Inductive permutation : list A -> list A -> Prop := + | permutation_nil : permutation nil nil + | permutation_skip : + forall (a : A) (l1 l2 : list A), + permutation l2 l1 -> permutation (a :: l2) (a :: l1) + | permutation_swap : + forall (a b : A) (l : list A), permutation (a :: b :: l) (b :: a :: l) + | permutation_trans : + forall l1 l2 l3 : list A, + permutation l1 l2 -> permutation l2 l3 -> permutation l1 l3. +Hint Constructors permutation. + +(************************************** + Reflexivity + **************************************) + +Theorem permutation_refl : forall l : list A, permutation l l. +simple induction l. +apply permutation_nil. +intros a l1 H. +apply permutation_skip with (1 := H). +Qed. +Hint Resolve permutation_refl. + +(************************************** + Symmetry + **************************************) + +Theorem permutation_sym : + forall l m : list A, permutation l m -> permutation m l. +intros l1 l2 H'; elim H'. +apply permutation_nil. +intros a l1' l2' H1 H2. +apply permutation_skip with (1 := H2). +intros a b l1'. +apply permutation_swap. +intros l1' l2' l3' H1 H2 H3 H4. +apply permutation_trans with (1 := H4) (2 := H2). +Qed. + +(************************************** + Compatibility with list length + **************************************) + +Theorem permutation_length : + forall l m : list A, permutation l m -> length l = length m. +intros l m H'; elim H'; simpl in |- *; auto. +intros l1 l2 l3 H'0 H'1 H'2 H'3. +rewrite <- H'3; auto. +Qed. + +(************************************** + A permutation of the nil list is the nil list + **************************************) + +Theorem permutation_nil_inv : forall l : list A, permutation l nil -> l = nil. +intros l H; generalize (permutation_length _ _ H); case l; simpl in |- *; + auto. +intros; discriminate. +Qed. + +(************************************** + A permutation of the singleton list is the singleton list + **************************************) + +Let permutation_one_inv_aux : + forall l1 l2 : list A, + permutation l1 l2 -> forall a : A, l1 = a :: nil -> l2 = a :: nil. +intros l1 l2 H; elim H; clear H l1 l2; auto. +intros a l3 l4 H0 H1 b H2. +eq_tac. +injection H2; auto. +apply permutation_nil_inv; auto. +injection H2; intros H3 H4; rewrite <- H3; auto. +apply permutation_sym; auto. +intros; discriminate. +Qed. + +Theorem permutation_one_inv : + forall (a : A) (l : list A), permutation (a :: nil) l -> l = a :: nil. +intros a l H; apply permutation_one_inv_aux with (l1 := a :: nil); auto. +Qed. + +(************************************** + Compatibility with the belonging + **************************************) + +Theorem permutation_in : + forall (a : A) (l m : list A), permutation l m -> In a l -> In a m. +intros a l m H; elim H; simpl in |- *; auto; intuition. +Qed. + +(************************************** + Compatibility with the append function + **************************************) + +Theorem permutation_app_comp : + forall l1 l2 l3 l4, + permutation l1 l2 -> permutation l3 l4 -> permutation (l1 ++ l3) (l2 ++ l4). +intros l1 l2 l3 l4 H1; generalize l3 l4; elim H1; clear H1 l1 l2 l3 l4; + simpl in |- *; auto. +intros a b l l3 l4 H. +cut (permutation (l ++ l3) (l ++ l4)); auto. +intros; apply permutation_trans with (a :: b :: l ++ l4); auto. +elim l; simpl in |- *; auto. +intros l1 l2 l3 H H0 H1 H2 l4 l5 H3. +apply permutation_trans with (l2 ++ l4); auto. +Qed. +Hint Resolve permutation_app_comp. + +(************************************** + Swap two sublists + **************************************) + +Theorem permutation_app_swap : + forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1). +intros l1; elim l1; auto. +intros; rewrite <- app_nil_end; auto. +intros a l H l2. +replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l). +apply permutation_trans with (l ++ l2 ++ a :: nil); auto. +apply permutation_trans with (((a :: nil) ++ l2) ++ l); auto. +simpl in |- *; auto. +apply permutation_trans with (l ++ (a :: nil) ++ l2); auto. +apply permutation_sym; auto. +replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l). +apply permutation_app_comp; auto. +elim l2; simpl in |- *; auto. +intros a0 l0 H0. +apply permutation_trans with (a0 :: a :: l0); auto. +apply (app_ass l2 (a :: nil) l). +apply (app_ass l2 (a :: nil) l). +Qed. + +(************************************** + A transposition is a permutation + **************************************) + +Theorem permutation_transposition : + forall a b l1 l2 l3, + permutation (l1 ++ a :: l2 ++ b :: l3) (l1 ++ b :: l2 ++ a :: l3). +intros a b l1 l2 l3. +apply permutation_app_comp; auto. +change + (permutation ((a :: nil) ++ l2 ++ (b :: nil) ++ l3) + ((b :: nil) ++ l2 ++ (a :: nil) ++ l3)) in |- *. +repeat rewrite <- app_ass. +apply permutation_app_comp; auto. +apply permutation_trans with ((b :: nil) ++ (a :: nil) ++ l2); auto. +apply permutation_app_swap; auto. +repeat rewrite app_ass. +apply permutation_app_comp; auto. +apply permutation_app_swap; auto. +Qed. + +(************************************** + An element of a list can be put on top of the list to get a permutation + **************************************) + +Theorem in_permutation_ex : + forall a l, In a l -> exists l1 : list A, permutation (a :: l1) l. +intros a l; elim l; simpl in |- *; auto. +intros H; case H; auto. +intros a0 l0 H [H0| H0]. +exists l0; rewrite H0; auto. +case H; auto; intros l1 Hl1; exists (a0 :: l1). +apply permutation_trans with (a0 :: a :: l1); auto. +Qed. + +(************************************** + A permutation of a cons can be inverted + **************************************) + +Let permutation_cons_ex_aux : + forall (a : A) (l1 l2 : list A), + permutation l1 l2 -> + forall l11 l12 : list A, + l1 = l11 ++ a :: l12 -> + exists l3 : list A, + (exists l4 : list A, + l2 = l3 ++ a :: l4 /\ permutation (l11 ++ l12) (l3 ++ l4)). +intros a l1 l2 H; elim H; clear H l1 l2. +intros l11 l12; case l11; simpl in |- *; intros; discriminate. +intros a0 l1 l2 H H0 l11 l12; case l11; simpl in |- *. +exists (nil (A:=A)); exists l1; simpl in |- *; split; auto. +eq_tac; injection H1; auto. +injection H1; intros H2 H3; rewrite <- H2; auto. +intros a1 l111 H1. +case (H0 l111 l12); auto. +injection H1; auto. +intros l3 (l4, (Hl1, Hl2)). +exists (a0 :: l3); exists l4; split; simpl in |- *; auto. +eq_tac; injection H1; auto. +injection H1; intros H2 H3; rewrite H3; auto. +intros a0 b l l11 l12; case l11; simpl in |- *. +case l12; try (intros; discriminate). +intros a1 l0 H; exists (b :: nil); exists l0; simpl in |- *; split; auto. +repeat eq_tac; injection H; auto. +injection H; intros H1 H2 H3; rewrite H2; auto. +intros a1 l111; case l111; simpl in |- *. +intros H; exists (nil (A:=A)); exists (a0 :: l12); simpl in |- *; split; auto. +repeat eq_tac; injection H; auto. +injection H; intros H1 H2 H3; rewrite H3; auto. +intros a2 H1111 H; exists (a2 :: a1 :: H1111); exists l12; simpl in |- *; + split; auto. +repeat eq_tac; injection H; auto. +intros l1 l2 l3 H H0 H1 H2 l11 l12 H3. +case H0 with (1 := H3). +intros l4 (l5, (Hl1, Hl2)). +case H2 with (1 := Hl1). +intros l6 (l7, (Hl3, Hl4)). +exists l6; exists l7; split; auto. +apply permutation_trans with (1 := Hl2); auto. +Qed. + +Theorem permutation_cons_ex : + forall (a : A) (l1 l2 : list A), + permutation (a :: l1) l2 -> + exists l3 : list A, + (exists l4 : list A, l2 = l3 ++ a :: l4 /\ permutation l1 (l3 ++ l4)). +intros a l1 l2 H. +apply (permutation_cons_ex_aux a (a :: l1) l2 H nil l1); simpl in |- *; auto. +Qed. + +(************************************** + A permutation can be simply inverted if the two list starts with a cons + **************************************) + +Theorem permutation_inv : + forall (a : A) (l1 l2 : list A), + permutation (a :: l1) (a :: l2) -> permutation l1 l2. +intros a l1 l2 H; case permutation_cons_ex with (1 := H). +intros l3 (l4, (Hl1, Hl2)). +apply permutation_trans with (1 := Hl2). +generalize Hl1; case l3; simpl in |- *; auto. +intros H1; injection H1; intros H2; rewrite H2; auto. +intros a0 l5 H1; injection H1; intros H2 H3; rewrite H2; rewrite H3; auto. +apply permutation_trans with (a0 :: l4 ++ l5); auto. +apply permutation_skip; apply permutation_app_swap. +apply (permutation_app_swap (a0 :: l4) l5). +Qed. + +(************************************** + Take a list and return tle list of all pairs of an element of the + list and the remaining list + **************************************) + +Fixpoint split_one (l : list A) : list (A * list A) := + match l with + | nil => nil (A:=A * list A) + | a :: l1 => + (a, l1) + :: map (fun p : A * list A => (fst p, a :: snd p)) (split_one l1) + end. + +(************************************** + The pairs of the list are a permutation + **************************************) + +Theorem split_one_permutation : + forall (a : A) (l1 l2 : list A), + In (a, l1) (split_one l2) -> permutation (a :: l1) l2. +intros a l1 l2; generalize a l1; elim l2; clear a l1 l2; simpl in |- *; auto. +intros a l1 H1; case H1. +intros a l H a0 l1 [H0| H0]. +injection H0; intros H1 H2; rewrite H2; rewrite H1; auto. +generalize H H0; elim (split_one l); simpl in |- *; auto. +intros H1 H2; case H2. +intros a1 l0 H1 H2 [H3| H3]; auto. +injection H3; intros H4 H5; (rewrite <- H4; rewrite <- H5). +apply permutation_trans with (a :: fst a1 :: snd a1); auto. +apply permutation_skip. +apply H2; auto. +case a1; simpl in |- *; auto. +Qed. + +(************************************** + All elements of the list are there + **************************************) + +Theorem split_one_in_ex : + forall (a : A) (l1 : list A), + In a l1 -> exists l2 : list A, In (a, l2) (split_one l1). +intros a l1; elim l1; simpl in |- *; auto. +intros H; case H. +intros a0 l H [H0| H0]; auto. +exists l; left; eq_tac; auto. +case H; auto. +intros x H1; exists (a0 :: x); right; auto. +apply + (in_map (fun p : A * list A => (fst p, a0 :: snd p)) (split_one l) (a, x)); + auto. +Qed. + +(************************************** + An auxillary function to generate all permutations + **************************************) + +Fixpoint all_permutations_aux (l : list A) (n : nat) {struct n} : + list (list A) := + match n with + | O => nil :: nil + | S n1 => + flat_map + (fun p : A * list A => + map (cons (fst p)) (all_permutations_aux (snd p) n1)) ( + split_one l) + end. +(************************************** + Generate all the permutations + **************************************) + +Definition all_permutations (l : list A) := all_permutations_aux l (length l). + +(************************************** + All the elements of the list are permutations + **************************************) + +Let all_permutations_aux_permutation : + forall (n : nat) (l1 l2 : list A), + n = length l2 -> In l1 (all_permutations_aux l2 n) -> permutation l1 l2. +intros n; elim n; simpl in |- *; auto. +intros l1 l2; case l2. +simpl in |- *; intros H0 [H1| H1]. +rewrite <- H1; auto. +case H1. +simpl in |- *; intros; discriminate. +intros n0 H l1 l2 H0 H1. +case in_flat_map_ex with (1 := H1). +clear H1; intros x; case x; clear x; intros a1 l3 (H1, H2). +case in_map_inv with (1 := H2). +simpl in |- *; intros y (H3, H4). +rewrite H4; auto. +apply permutation_trans with (a1 :: l3); auto. +apply permutation_skip; auto. +apply H with (2 := H3). +apply eq_add_S. +apply trans_equal with (1 := H0). +change (length l2 = length (a1 :: l3)) in |- *. +apply permutation_length; auto. +apply permutation_sym; apply split_one_permutation; auto. +apply split_one_permutation; auto. +Qed. + +Theorem all_permutations_permutation : + forall l1 l2 : list A, In l1 (all_permutations l2) -> permutation l1 l2. +intros l1 l2 H; apply all_permutations_aux_permutation with (n := length l2); + auto. +Qed. + +(************************************** + A permutation is in the list + **************************************) + +Let permutation_all_permutations_aux : + forall (n : nat) (l1 l2 : list A), + n = length l2 -> permutation l1 l2 -> In l1 (all_permutations_aux l2 n). +intros n; elim n; simpl in |- *; auto. +intros l1 l2; case l2. +intros H H0; rewrite permutation_nil_inv with (1 := H0); auto with datatypes. +simpl in |- *; intros; discriminate. +intros n0 H l1; case l1. +intros l2 H0 H1; + rewrite permutation_nil_inv with (1 := permutation_sym _ _ H1) in H0; + discriminate. +clear l1; intros a1 l1 l2 H1 H2. +case (split_one_in_ex a1 l2); auto. +apply permutation_in with (1 := H2); auto with datatypes. +intros x H0. +apply in_flat_map with (b := (a1, x)); auto. +apply in_map; simpl in |- *. +apply H; auto. +apply eq_add_S. +apply trans_equal with (1 := H1). +change (length l2 = length (a1 :: x)) in |- *. +apply permutation_length; auto. +apply permutation_sym; apply split_one_permutation; auto. +apply permutation_inv with (a := a1). +apply permutation_trans with (1 := H2). +apply permutation_sym; apply split_one_permutation; auto. +Qed. + +Theorem permutation_all_permutations : + forall l1 l2 : list A, permutation l1 l2 -> In l1 (all_permutations l2). +intros l1 l2 H; unfold all_permutations in |- *; + apply permutation_all_permutations_aux; auto. +Qed. + +(************************************** + Permutation is decidable + **************************************) + +Definition permutation_dec : + (forall a b : A, {a = b} + {a <> b}) -> + forall l1 l2 : list A, {permutation l1 l2} + {~ permutation l1 l2}. +intros H l1 l2. +case (In_dec (list_eq_dec H) l1 (all_permutations l2)). +intros i; left; apply all_permutations_permutation; auto. +intros i; right; contradict i; apply permutation_all_permutations; auto. +Defined. + +End permutation. + +(************************************** + Hints + **************************************) + +Hint Constructors permutation. +Hint Resolve permutation_refl. +Hint Resolve permutation_app_comp. +Hint Resolve permutation_app_swap. + +(************************************** + Implicits + **************************************) + +Implicit Arguments permutation [A]. +Implicit Arguments split_one [A]. +Implicit Arguments all_permutations [A]. +Implicit Arguments permutation_dec [A]. + +(************************************** + Permutation is compatible with map + **************************************) + +Theorem permutation_map : + forall (A B : Set) (f : A -> B) l1 l2, + permutation l1 l2 -> permutation (map f l1) (map f l2). +intros A B f l1 l2 H; elim H; simpl in |- *; auto. +intros l0 l3 l4 H0 H1 H2 H3; apply permutation_trans with (2 := H3); auto. +Qed. +Hint Resolve permutation_map. + +(************************************** + Permutation of a map can be inverted + *************************************) + +Let permutation_map_ex_aux : + forall (A B : Set) (f : A -> B) l1 l2 l3, + permutation l1 l2 -> + l1 = map f l3 -> exists l4, permutation l4 l3 /\ l2 = map f l4. +intros A1 B1 f l1 l2 l3 H; generalize l3; elim H; clear H l1 l2 l3. +intros l3; case l3; simpl in |- *; auto. +intros H; exists (nil (A:=A1)); auto. +intros; discriminate. +intros a0 l1 l2 H H0 l3; case l3; simpl in |- *; auto. +intros; discriminate. +intros a1 l H1; case (H0 l); auto. +injection H1; auto. +intros l5 (H2, H3); exists (a1 :: l5); split; simpl in |- *; auto. +eq_tac; auto; injection H1; auto. +intros a0 b l l3; case l3. +intros; discriminate. +intros a1 l0; case l0; simpl in |- *. +intros; discriminate. +intros a2 l1 H; exists (a2 :: a1 :: l1); split; simpl in |- *; auto. +repeat eq_tac; injection H; auto. +intros l1 l2 l3 H H0 H1 H2 l0 H3. +case H0 with (1 := H3); auto. +intros l4 (HH1, HH2). +case H2 with (1 := HH2); auto. +intros l5 (HH3, HH4); exists l5; split; auto. +apply permutation_trans with (1 := HH3); auto. +Qed. + +Theorem permutation_map_ex : + forall (A B : Set) (f : A -> B) l1 l2, + permutation (map f l1) l2 -> + exists l3, permutation l3 l1 /\ l2 = map f l3. +intros A0 B f l1 l2 H; apply permutation_map_ex_aux with (l1 := map f l1); + auto. +Qed. + +(************************************** + Permutation is compatible with flat_map + **************************************) + +Theorem permutation_flat_map : + forall (A B : Set) (f : A -> list B) l1 l2, + permutation l1 l2 -> permutation (flat_map f l1) (flat_map f l2). +intros A B f l1 l2 H; elim H; simpl in |- *; auto. +intros a b l; auto. +repeat rewrite <- app_ass. +apply permutation_app_comp; auto. +intros k3 l4 l5 H0 H1 H2 H3; apply permutation_trans with (1 := H1); auto. +Qed. diff --git a/theories/Ints/List/ListAux.v b/theories/Ints/List/ListAux.v new file mode 100644 index 000000000..5a6541c95 --- /dev/null +++ b/theories/Ints/List/ListAux.v @@ -0,0 +1,272 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + Aux.v + + Auxillary functions & Theorems + **********************************************************************) +Require Export List. +Require Export Arith. +Require Export Tactic. +Require Import Inverse_Image. +Require Import Wf_nat. + +(************************************** + Some properties on list operators: app, map,... +**************************************) + +Section List. +Variables (A : Set) (B : Set) (C : Set). +Variable f : A -> B. + +(************************************** + An induction theorem for list based on length +**************************************) + +Theorem list_length_ind: + forall (P : list A -> Prop), + (forall (l1 : list A), + (forall (l2 : list A), length l2 < length l1 -> P l2) -> P l1) -> + forall (l : list A), P l. +intros P H l; + apply well_founded_ind with ( R := fun (x y : list A) => length x < length y ); + auto. +apply wf_inverse_image with ( R := lt ); auto. +apply lt_wf. +Qed. + +Definition list_length_induction: + forall (P : list A -> Set), + (forall (l1 : list A), + (forall (l2 : list A), length l2 < length l1 -> P l2) -> P l1) -> + forall (l : list A), P l. +intros P H l; + apply well_founded_induction + with ( R := fun (x y : list A) => length x < length y ); auto. +apply wf_inverse_image with ( R := lt ); auto. +apply lt_wf. +Qed. + +Theorem in_ex_app: + forall (a : A) (l : list A), + In a l -> (exists l1 : list A , exists l2 : list A , l = l1 ++ (a :: l2) ). +intros a l; elim l; clear l; simpl; auto. +intros H; case H. +intros a1 l H [H1|H1]; auto. +exists (nil (A:=A)); exists l; simpl; auto. +eq_tac; auto. +case H; auto; intros l1 [l2 Hl2]; exists (a1 :: l1); exists l2; simpl; auto. +eq_tac; auto. +Qed. + +(************************************** + Properties on app +**************************************) + +Theorem length_app: + forall (l1 l2 : list A), length (l1 ++ l2) = length l1 + length l2. +intros l1; elim l1; simpl; auto. +Qed. + +Theorem app_inv_head: + forall (l1 l2 l3 : list A), l1 ++ l2 = l1 ++ l3 -> l2 = l3. +intros l1; elim l1; simpl; auto. +intros a l H l2 l3 H0; apply H; injection H0; auto. +Qed. + +Theorem app_inv_tail: + forall (l1 l2 l3 : list A), l2 ++ l1 = l3 ++ l1 -> l2 = l3. +intros l1 l2; generalize l1; elim l2; clear l1 l2; simpl; auto. +intros l1 l3; case l3; auto. +intros b l H; absurd (length ((b :: l) ++ l1) <= length l1). +simpl; rewrite length_app; auto with arith. +rewrite <- H; auto with arith. +intros a l H l1 l3; case l3. +simpl; intros H1; absurd (length (a :: (l ++ l1)) <= length l1). +simpl; rewrite length_app; auto with arith. +rewrite H1; auto with arith. +simpl; intros b l0 H0; injection H0. +intros H1 H2; eq_tac; auto. +apply H with ( 1 := H1 ); auto. +Qed. + +Theorem app_inv_app: + forall l1 l2 l3 l4 a, + l1 ++ l2 = l3 ++ (a :: l4) -> + (exists l5 : list A , l1 = l3 ++ (a :: l5) ) \/ + (exists l5 , l2 = l5 ++ (a :: l4) ). +intros l1; elim l1; simpl; auto. +intros l2 l3 l4 a H; right; exists l3; auto. +intros a l H l2 l3 l4 a0; case l3; simpl. +intros H0; left; exists l; eq_tac; injection H0; auto. +intros b l0 H0; case (H l2 l0 l4 a0); auto. +injection H0; auto. +intros [l5 H1]. +left; exists l5; eq_tac; injection H0; auto. +Qed. + +Theorem app_inv_app2: + forall l1 l2 l3 l4 a b, + l1 ++ l2 = l3 ++ (a :: (b :: l4)) -> + (exists l5 : list A , l1 = l3 ++ (a :: (b :: l5)) ) \/ + ((exists l5 , l2 = l5 ++ (a :: (b :: l4)) ) \/ + l1 = l3 ++ (a :: nil) /\ l2 = b :: l4). +intros l1; elim l1; simpl; auto. +intros l2 l3 l4 a b H; right; left; exists l3; auto. +intros a l H l2 l3 l4 a0 b; case l3; simpl. +case l; simpl. +intros H0; right; right; injection H0; split; auto. +eq_tac; auto. +intros b0 l0 H0; left; exists l0; injection H0; intros; (repeat eq_tac); auto. +intros b0 l0 H0; case (H l2 l0 l4 a0 b); auto. +injection H0; auto. +intros [l5 HH1]; left; exists l5; eq_tac; auto; injection H0; auto. +intros [H1|[H1 H2]]; auto. +right; right; split; auto; eq_tac; auto; injection H0; auto. +Qed. + +Theorem same_length_ex: + forall (a : A) l1 l2 l3, + length (l1 ++ (a :: l2)) = length l3 -> + (exists l4 , + exists l5 , + exists b : B , + length l1 = length l4 /\ (length l2 = length l5 /\ l3 = l4 ++ (b :: l5)) ). +intros a l1; elim l1; simpl; auto. +intros l2 l3; case l3; simpl; (try (intros; discriminate)). +intros b l H; exists (nil (A:=B)); exists l; exists b; (repeat (split; auto)). +intros a0 l H l2 l3; case l3; simpl; (try (intros; discriminate)). +intros b l0 H0. +case (H l2 l0); auto. +intros l4 [l5 [b1 [HH1 [HH2 HH3]]]]. +exists (b :: l4); exists l5; exists b1; (repeat (simpl; split; auto)). +eq_tac; auto. +Qed. + +(************************************** + Properties on map +**************************************) + +Theorem in_map_inv: + forall (b : B) (l : list A), + In b (map f l) -> (exists a : A , In a l /\ b = f a ). +intros b l; elim l; simpl; auto. +intros tmp; case tmp. +intros a0 l0 H [H1|H1]; auto. +exists a0; auto. +case (H H1); intros a1 [H2 H3]; exists a1; auto. +Qed. + +Theorem in_map_fst_inv: + forall a (l : list (B * C)), + In a (map (fst (B:=_)) l) -> (exists c , In (a, c) l ). +intros a l; elim l; simpl; auto. +intros H; case H. +intros a0 l0 H [H0|H0]; auto. +exists (snd a0); left; rewrite <- H0; case a0; simpl; auto. +case H; auto; intros l1 Hl1; exists l1; auto. +Qed. + +Theorem length_map: forall l, length (map f l) = length l. +intros l; elim l; simpl; auto. +Qed. + +Theorem map_app: forall l1 l2, map f (l1 ++ l2) = map f l1 ++ map f l2. +intros l; elim l; simpl; auto. +intros a l0 H l2; eq_tac; auto. +Qed. + +Theorem map_length_decompose: + forall l1 l2 l3 l4, + length l1 = length l2 -> + map f (app l1 l3) = app l2 l4 -> map f l1 = l2 /\ map f l3 = l4. +intros l1; elim l1; simpl; auto; clear l1. +intros l2; case l2; simpl; auto. +intros; discriminate. +intros a l1 Rec l2; case l2; simpl; clear l2; auto. +intros; discriminate. +intros b l2 l3 l4 H1 H2. +injection H2; clear H2; intros H2 H3. +case (Rec l2 l3 l4); auto. +intros H4 H5; split; auto. +eq_tac; auto. +Qed. + +(************************************** + Properties of flat_map +**************************************) + +Theorem in_flat_map: + forall (l : list B) (f : B -> list C) a b, + In a (f b) -> In b l -> In a (flat_map f l). +intros l g; elim l; simpl; auto. +intros a l0 H a0 b H0 [H1|H1]; apply in_or_app; auto. +left; rewrite H1; auto. +right; apply H with ( b := b ); auto. +Qed. + +Theorem in_flat_map_ex: + forall (l : list B) (f : B -> list C) a, + In a (flat_map f l) -> (exists b , In b l /\ In a (f b) ). +intros l g; elim l; simpl; auto. +intros a H; case H. +intros a l0 H a0 H0; case in_app_or with ( 1 := H0 ); simpl; auto. +intros H1; exists a; auto. +intros H1; case H with ( 1 := H1 ). +intros b [H2 H3]; exists b; simpl; auto. +Qed. + +(************************************** + Properties of fold_left +**************************************) + +Theorem fold_left_invol: + forall (f: A -> B -> A) (P: A -> Prop) l a, + P a -> (forall x y, P x -> P (f x y)) -> P (fold_left f l a). +intros f1 P l; elim l; simpl; auto. +Qed. + +Theorem fold_left_invol_in: + forall (f: A -> B -> A) (P: A -> Prop) l a b, + In b l -> (forall x, P (f x b)) -> (forall x y, P x -> P (f x y)) -> + P (fold_left f l a). +intros f1 P l; elim l; simpl; auto. +intros a1 b HH; case HH. +intros a1 l1 Rec a2 b [V|V] V1 V2; subst; auto. +apply fold_left_invol; auto. +apply Rec with (b := b); auto. +Qed. + +End List. + + +(************************************** + Propertie of list_prod +**************************************) + +Theorem length_list_prod: + forall (A : Set) (l1 l2 : list A), + length (list_prod l1 l2) = length l1 * length l2. +intros A l1 l2; elim l1; simpl; auto. +intros a l H; rewrite length_app; rewrite length_map; rewrite H; auto. +Qed. + +Theorem in_list_prod_inv: + forall (A B : Set) a l1 l2, + In a (list_prod l1 l2) -> + (exists b : A , exists c : B , a = (b, c) /\ (In b l1 /\ In c l2) ). +intros A B a l1 l2; elim l1; simpl; auto; clear l1. +intros H; case H. +intros a1 l1 H1 H2. +case in_app_or with ( 1 := H2 ); intros H3; auto. +case in_map_inv with ( 1 := H3 ); intros b1 [Hb1 Hb2]; auto. +exists a1; exists b1; split; auto. +case H1; auto; intros b1 [c1 [Hb1 [Hb2 Hb3]]]. +exists b1; exists c1; split; auto. +Qed. diff --git a/theories/Ints/List/UList.v b/theories/Ints/List/UList.v new file mode 100644 index 000000000..5248a8b1f --- /dev/null +++ b/theories/Ints/List/UList.v @@ -0,0 +1,286 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(*********************************************************************** + UList.v + + Definition of list with distinct elements + + Definition: ulist +************************************************************************) +Require Import List. +Require Import Arith. +Require Import Permutation. +Require Import ListSet. + +Section UniqueList. +Variable A : Set. +Variable eqA_dec : forall (a b : A), ({ a = b }) + ({ a <> b }). +(* A list is unique if there is not twice the same element in the list *) + +Inductive ulist : list A -> Prop := + ulist_nil: ulist nil + | ulist_cons: forall a l, ~ In a l -> ulist l -> ulist (a :: l) . +Hint Constructors ulist . +(* Inversion theorem *) + +Theorem ulist_inv: forall a l, ulist (a :: l) -> ulist l. +intros a l H; inversion H; auto. +Qed. +(* The append of two unique list is unique if the list are distinct *) + +Theorem ulist_app: + forall l1 l2, + ulist l1 -> + ulist l2 -> (forall (a : A), In a l1 -> In a l2 -> False) -> ulist (l1 ++ l2). +intros L1; elim L1; simpl; auto. +intros a l H l2 H0 H1 H2; apply ulist_cons; simpl; auto. +red; intros H3; case in_app_or with ( 1 := H3 ); auto; intros H4. +inversion H0; auto. +apply H2 with a; auto. +apply H; auto. +apply ulist_inv with ( 1 := H0 ); auto. +intros a0 H3 H4; apply (H2 a0); auto. +Qed. +(* Iinversion theorem the appended list *) + +Theorem ulist_app_inv: + forall l1 l2 (a : A), ulist (l1 ++ l2) -> In a l1 -> In a l2 -> False. +intros l1; elim l1; simpl; auto. +intros a l H l2 a0 H0 [H1|H1] H2. +inversion H0 as [|a1 l0 H3 H4 H5]; auto. +case H4; rewrite H1; auto with datatypes. +apply (H l2 a0); auto. +apply ulist_inv with ( 1 := H0 ); auto. +Qed. +(* Iinversion theorem the appended list *) + +Theorem ulist_app_inv_l: forall (l1 l2 : list A), ulist (l1 ++ l2) -> ulist l1. +intros l1; elim l1; simpl; auto. +intros a l H l2 H0. +inversion H0 as [|il1 iH1 iH2 il2 [iH4 iH5]]; apply ulist_cons; auto. +intros H5; case iH2; auto with datatypes. +apply H with l2; auto. +Qed. +(* Iinversion theorem the appended list *) + +Theorem ulist_app_inv_r: forall (l1 l2 : list A), ulist (l1 ++ l2) -> ulist l2. +intros l1; elim l1; simpl; auto. +intros a l H l2 H0; inversion H0; auto. +Qed. +(* Uniqueness is decidable *) + +Definition ulist_dec: forall l, ({ ulist l }) + ({ ~ ulist l }). +intros l; elim l; auto. +intros a l1 [H|H]; auto. +case (In_dec eqA_dec a l1); intros H2; auto. +right; red; intros H1; inversion H1; auto. +right; intros H1; case H; apply ulist_inv with ( 1 := H1 ). +Defined. +(* Uniqueness is compatible with permutation *) + +Theorem ulist_perm: + forall (l1 l2 : list A), permutation l1 l2 -> ulist l1 -> ulist l2. +intros l1 l2 H; elim H; clear H l1 l2; simpl; auto. +intros a l1 l2 H0 H1 H2; apply ulist_cons; auto. +inversion_clear H2 as [|ia il iH1 iH2 [iH3 iH4]]; auto. +intros H3; case iH1; + apply permutation_in with ( 1 := permutation_sym _ _ _ H0 ); auto. +inversion H2; auto. +intros a b L H0; apply ulist_cons; auto. +inversion_clear H0 as [|ia il iH1 iH2]; auto. +inversion_clear iH2 as [|ia il iH3 iH4]; auto. +intros H; case H; auto. +intros H1; case iH1; rewrite H1; simpl; auto. +apply ulist_cons; auto. +inversion_clear H0 as [|ia il iH1 iH2]; auto. +intros H; case iH1; simpl; auto. +inversion_clear H0 as [|ia il iH1 iH2]; auto. +inversion iH2; auto. +Qed. + +Theorem ulist_def: + forall l a, + In a l -> ulist l -> ~ (exists l1 , permutation l (a :: (a :: l1)) ). +intros l a H H0 [l1 H1]. +absurd (ulist (a :: (a :: l1))); auto. +intros H2; inversion_clear H2; simpl; auto with datatypes. +apply ulist_perm with ( 1 := H1 ); auto. +Qed. + +Theorem ulist_incl_permutation: + forall (l1 l2 : list A), + ulist l1 -> incl l1 l2 -> (exists l3 , permutation l2 (l1 ++ l3) ). +intros l1; elim l1; simpl; auto. +intros l2 H H0; exists l2; simpl; auto. +intros a l H l2 H0 H1; auto. +case (in_permutation_ex _ a l2); auto with datatypes. +intros l3 Hl3. +case (H l3); auto. +apply ulist_inv with ( 1 := H0 ); auto. +intros b Hb. +assert (H2: In b (a :: l3)). +apply permutation_in with ( 1 := permutation_sym _ _ _ Hl3 ); + auto with datatypes. +simpl in H2 |-; case H2; intros H3; simpl; auto. +inversion_clear H0 as [|c lc Hk1]; auto. +case Hk1; subst a; auto. +intros l4 H4; exists l4. +apply permutation_trans with (a :: l3); auto. +apply permutation_sym; auto. +Qed. + +Theorem ulist_eq_permutation: + forall (l1 l2 : list A), + ulist l1 -> incl l1 l2 -> length l1 = length l2 -> permutation l1 l2. +intros l1 l2 H1 H2 H3. +case (ulist_incl_permutation l1 l2); auto. +intros l3 H4. +assert (H5: l3 = @nil A). +generalize (permutation_length _ _ _ H4); rewrite length_app; rewrite H3. +rewrite plus_comm; case l3; simpl; auto. +intros a l H5; absurd (lt (length l2) (length l2)); auto with arith. +pattern (length l2) at 2; rewrite H5; auto with arith. +replace l1 with (app l1 l3); auto. +apply permutation_sym; auto. +rewrite H5; rewrite app_nil_end; auto. +Qed. + + +Theorem ulist_incl_length: + forall (l1 l2 : list A), ulist l1 -> incl l1 l2 -> le (length l1) (length l2). +intros l1 l2 H1 Hi; case ulist_incl_permutation with ( 2 := Hi ); auto. +intros l3 Hl3; rewrite permutation_length with ( 1 := Hl3 ); auto. +rewrite length_app; simpl; auto with arith. +Qed. + +Theorem ulist_incl2_permutation: + forall (l1 l2 : list A), + ulist l1 -> ulist l2 -> incl l1 l2 -> incl l2 l1 -> permutation l1 l2. +intros l1 l2 H1 H2 H3 H4. +apply ulist_eq_permutation; auto. +apply le_antisym; apply ulist_incl_length; auto. +Qed. + + +Theorem ulist_incl_length_strict: + forall (l1 l2 : list A), + ulist l1 -> incl l1 l2 -> ~ incl l2 l1 -> lt (length l1) (length l2). +intros l1 l2 H1 Hi Hi0; case ulist_incl_permutation with ( 2 := Hi ); auto. +intros l3 Hl3; rewrite permutation_length with ( 1 := Hl3 ); auto. +rewrite length_app; simpl; auto with arith. +generalize Hl3; case l3; simpl; auto with arith. +rewrite <- app_nil_end; auto. +intros H2; case Hi0; auto. +intros a HH; apply permutation_in with ( 1 := H2 ); auto. +intros a l Hl0; (rewrite plus_comm; simpl; rewrite plus_comm; auto with arith). +Qed. + +Theorem in_inv_dec: + forall (a b : A) l, In a (cons b l) -> a = b \/ ~ a = b /\ In a l. +intros a b l H; case (eqA_dec a b); auto; intros H1. +right; split; auto; inversion H; auto. +case H1; auto. +Qed. + +Theorem in_ex_app_first: + forall (a : A) (l : list A), + In a l -> + (exists l1 : list A , exists l2 : list A , l = l1 ++ (a :: l2) /\ ~ In a l1 ). +intros a l; elim l; clear l; auto. +intros H; case H. +intros a1 l H H1; auto. +generalize (in_inv_dec _ _ _ H1); intros [H2|[H2 H3]]. +exists (nil (A:=A)); exists l; simpl; split; auto. +eq_tac; auto. +case H; auto; intros l1 [l2 [Hl2 Hl3]]; exists (a1 :: l1); exists l2; simpl; + split; auto. +eq_tac; auto. +intros H4; case H4; auto. +Qed. + +Theorem ulist_inv_ulist: + forall (l : list A), + ~ ulist l -> + (exists a , + exists l1 , + exists l2 , + exists l3 , l = l1 ++ ((a :: l2) ++ (a :: l3)) /\ ulist (l1 ++ (a :: l2)) ). +intros l; elim l using list_length_ind; clear l. +intros l; case l; simpl; auto; clear l. +intros Rec H0; case H0; auto. +intros a l H H0. +case (In_dec eqA_dec a l); intros H1; auto. +case in_ex_app_first with ( 1 := H1 ); intros l1 [l2 [Hl1 Hl2]]; subst l. +case (ulist_dec l1); intros H2. +exists a; exists (@nil A); exists l1; exists l2; split; auto. +simpl; apply ulist_cons; auto. +case (H l1); auto. +rewrite length_app; auto with arith. +intros b [l3 [l4 [l5 [Hl3 Hl4]]]]; subst l1. +exists b; exists (a :: l3); exists l4; exists (l5 ++ (a :: l2)); split; simpl; + auto. +(repeat (rewrite <- ass_app; simpl)); auto. +apply ulist_cons; auto. +contradict Hl2; auto. +replace (l3 ++ (b :: (l4 ++ (b :: l5)))) with ((l3 ++ (b :: l4)) ++ (b :: l5)); + auto with datatypes. +(repeat (rewrite <- ass_app; simpl)); auto. +case (H l); auto; intros a1 [l1 [l2 [l3 [Hl3 Hl4]]]]; subst l. +exists a1; exists (a :: l1); exists l2; exists l3; split; auto. +simpl; apply ulist_cons; auto. +contradict H1. +replace (l1 ++ (a1 :: (l2 ++ (a1 :: l3)))) + with ((l1 ++ (a1 :: l2)) ++ (a1 :: l3)); auto with datatypes. +(repeat (rewrite <- ass_app; simpl)); auto. +Qed. + +Theorem incl_length_repetition: + forall (l1 l2 : list A), + incl l1 l2 -> + lt (length l2) (length l1) -> + (exists a , + exists ll1 , + exists ll2 , + exists ll3 , + l1 = ll1 ++ ((a :: ll2) ++ (a :: ll3)) /\ ulist (ll1 ++ (a :: ll2)) ). +intros l1 l2 H H0; apply ulist_inv_ulist. +intros H1; absurd (le (length l1) (length l2)); auto with arith. +apply ulist_incl_length; auto. +Qed. + +End UniqueList. +Implicit Arguments ulist [A]. +Hint Constructors ulist . + +Theorem ulist_map: + forall (A B : Set) (f : A -> B) l, + (forall x y, (In x l) -> (In y l) -> f x = f y -> x = y) -> ulist l -> ulist (map f l). +intros a b f l Hf Hl; generalize Hf; elim Hl; clear Hf; auto. +simpl; auto. +intros a1 l1 H1 H2 H3 Hf; simpl. +apply ulist_cons; auto with datatypes. +contradict H1. +case in_map_inv with ( 1 := H1 ); auto with datatypes. +intros b1 [Hb1 Hb2]. +replace a1 with b1; auto with datatypes. +Qed. + +Theorem ulist_list_prod: + forall (A : Set) (l1 l2 : list A), + ulist l1 -> ulist l2 -> ulist (list_prod l1 l2). +intros A l1 l2 Hl1 Hl2; elim Hl1; simpl; auto. +intros a l H1 H2 H3; apply ulist_app; auto. +apply ulist_map; auto. +intros x y _ _ H; inversion H; auto. +intros p Hp1 Hp2; case H1. +case in_map_inv with ( 1 := Hp1 ); intros a1 [Ha1 Ha2]; auto. +case in_list_prod_inv with ( 1 := Hp2 ); intros b1 [c1 [Hb1 [Hb2 Hb3]]]; auto. +replace a with b1; auto. +rewrite Ha2 in Hb1; injection Hb1; auto. +Qed. diff --git a/theories/Ints/List/ZProgression.v b/theories/Ints/List/ZProgression.v new file mode 100644 index 000000000..e4c15e38d --- /dev/null +++ b/theories/Ints/List/ZProgression.v @@ -0,0 +1,105 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Export Iterator. +Require Import ZArith. +Require Export UList. +Open Scope Z_scope. + +Theorem next_n_Z: forall n m, next_n Zsucc n m = n + Z_of_nat m. +intros n m; generalize n; elim m; clear n m. +intros n; simpl; auto with zarith. +intros m H n. +replace (n + Z_of_nat (S m)) with (Zsucc n + Z_of_nat m); auto with zarith. +rewrite <- H; auto with zarith. +rewrite inj_S; auto with zarith. +Qed. + +Theorem Zprogression_end: + forall n m, + progression Zsucc n (S m) = + app (progression Zsucc n m) (cons (n + Z_of_nat m) nil). +intros n m; generalize n; elim m; clear n m. +simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith. +intros m1 Hm1 n1. +apply trans_equal with (cons n1 (progression Zsucc (Zsucc n1) (S m1))); auto. +rewrite Hm1. +replace (Zsucc n1 + Z_of_nat m1) with (n1 + Z_of_nat (S m1)); auto with zarith. +replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1); auto with zarith. +rewrite inj_S; auto with zarith. +Qed. + +Theorem Zprogression_pred_end: + forall n m, + progression Zpred n (S m) = + app (progression Zpred n m) (cons (n - Z_of_nat m) nil). +intros n m; generalize n; elim m; clear n m. +simpl; intros; apply f_equal2 with ( f := @cons Z ); auto with zarith. +intros m1 Hm1 n1. +apply trans_equal with (cons n1 (progression Zpred (Zpred n1) (S m1))); auto. +rewrite Hm1. +replace (Zpred n1 - Z_of_nat m1) with (n1 - Z_of_nat (S m1)); auto with zarith. +replace (Z_of_nat (S m1)) with (1 + Z_of_nat m1); auto with zarith. +unfold Zpred; ring. +rewrite inj_S; auto with zarith. +Qed. + +Theorem Zprogression_opp: + forall n m, + rev (progression Zsucc n m) = progression Zpred (n + Z_of_nat (pred m)) m. +intros n m; generalize n; elim m; clear n m. +simpl; auto. +intros m Hm n. +rewrite (Zprogression_end n); auto. +rewrite distr_rev. +rewrite Hm; simpl; auto. +case m. +simpl; auto. +intros m1; + replace (n + Z_of_nat (pred (S m1))) with (Zpred (n + Z_of_nat (S m1))); auto. +rewrite inj_S; simpl; (unfold Zpred; unfold Zsucc); auto with zarith. +Qed. + +Theorem Zprogression_le_init: + forall n m p, In p (progression Zsucc n m) -> (n <= p). +intros n m; generalize n; elim m; clear n m; simpl; auto. +intros; contradiction. +intros m H n p [H1|H1]; auto with zarith. +generalize (H _ _ H1); auto with zarith. +Qed. + +Theorem Zprogression_le_end: + forall n m p, In p (progression Zsucc n m) -> (p < n + Z_of_nat m). +intros n m; generalize n; elim m; clear n m; auto. +intros; contradiction. +intros m H n p H1; simpl in H1 |-; case H1; clear H1; intros H1; + auto with zarith. +subst n; auto with zarith. +apply Zle_lt_trans with (p + 0); auto with zarith. +apply Zplus_lt_compat_l; red; simpl; auto with zarith. +apply Zlt_le_trans with (Zsucc n + Z_of_nat m); auto with zarith. +rewrite inj_S; rewrite Zplus_succ_comm; auto with zarith. +Qed. + +Theorem ulist_Zprogression: forall a n, ulist (progression Zsucc a n). +intros a n; generalize a; elim n; clear a n; simpl; auto with zarith. +intros n H1 a; apply ulist_cons; auto. +intros H2; absurd (Zsucc a <= a); auto with zarith. +apply Zprogression_le_init with ( 1 := H2 ). +Qed. + +Theorem in_Zprogression: + forall a b n, ( a <= b < a + Z_of_nat n ) -> In b (progression Zsucc a n). +intros a b n; generalize a b; elim n; clear a b n; auto with zarith. +simpl; auto with zarith. +intros n H a b. +replace (a + Z_of_nat (S n)) with (Zsucc a + Z_of_nat n); auto with zarith. +intros [H1 H2]; simpl; auto with zarith. +case (Zle_lt_or_eq _ _ H1); auto with zarith. +rewrite inj_S; auto with zarith. +Qed. diff --git a/theories/Ints/Tactic.v b/theories/Ints/Tactic.v new file mode 100644 index 000000000..a1654da68 --- /dev/null +++ b/theories/Ints/Tactic.v @@ -0,0 +1,84 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + + +(********************************************************************** + Tactic.v + Useful tactics + **********************************************************************) + +(************************************** + A simple tactic to end a proof +**************************************) +Ltac finish := intros; auto; trivial; discriminate. + + +(************************************** + A tactic for proof by contradiction + with contradict H + H: ~A |- B gives |- A + H: ~A |- ~ B gives H: B |- A + H: A |- B gives |- ~ A + H: A |- B gives |- ~ A + H: A |- ~ B gives H: A |- ~ A +**************************************) + +Ltac contradict name := + let term := type of name in ( + match term with + (~_) => + match goal with + |- ~ _ => let x := fresh in + (intros x; case name; + generalize x; clear x name; + intro name) + | |- _ => case name; clear name + end + | _ => + match goal with + |- ~ _ => let x := fresh in + (intros x; absurd term; + [idtac | exact name]; generalize x; clear x name; + intros name) + | |- _ => generalize name; absurd term; + [idtac | exact name]; clear name + end + end). + + +(************************************** + A tactic to do case analysis keeping the equality +**************************************) + +Ltac case_eq name := + generalize (refl_equal name); pattern name at -1 in |- *; case name. + + +(************************************** + A tactic to use f_equal? theorems +**************************************) + +Ltac eq_tac := + match goal with + |- (?f _ = ?f _) => apply f_equal with (f := f) + | |- (?f ?X _ = ?f ?X _) => apply f_equal with (f := f X) + | |- (?f _ _ = ?f _ _) => apply f_equal2 with (f := f) + | |- (?f ?X ?Y _ = ?f ?X ?Y _) => apply f_equal with (f := f X Y) + | |- (?f ?X _ _ = ?f ?X _ _) => apply f_equal2 with (f := f X) + | |- (?f _ _ _ = ?f _ _ _) => apply f_equal3 with (f := f) + | |- (?f ?X ?Y ?Z _ = ?f ?X ?Y ?Z _) => apply f_equal with (f := f X Y Z) + | |- (?f ?X ?Y _ _ = ?f ?X ?Y _ _) => apply f_equal2 with (f := f X Y) + | |- (?f ?X _ _ _ = ?f ?X _ _ _) => apply f_equal3 with (f := f X) + | |- (?f _ _ _ _ _ = ?f _ _ _ _) => apply f_equal4 with (f := f) + end. + +(************************************** + A stupid tactic that tries auto also after applying sym_equal +**************************************) + +Ltac sauto := (intros; apply sym_equal; auto; fail) || auto. diff --git a/theories/Ints/Z/IntsZmisc.v b/theories/Ints/Z/IntsZmisc.v new file mode 100644 index 000000000..6fcaaa6e9 --- /dev/null +++ b/theories/Ints/Z/IntsZmisc.v @@ -0,0 +1,185 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Export ZArith. +Open Local Scope Z_scope. + +Coercion Zpos : positive >-> Z. +Coercion Z_of_N : N >-> Z. + +Lemma Zpos_plus : forall p q, Zpos (p + q) = p + q. +Proof. intros;trivial. Qed. + +Lemma Zpos_mult : forall p q, Zpos (p * q) = p * q. +Proof. intros;trivial. Qed. + +Lemma Zpos_xI_add : forall p, Zpos (xI p) = Zpos p + Zpos p + Zpos 1. +Proof. intros p;rewrite Zpos_xI;ring. Qed. + +Lemma Zpos_xO_add : forall p, Zpos (xO p) = Zpos p + Zpos p. +Proof. intros p;rewrite Zpos_xO;ring. Qed. + +Lemma Psucc_Zplus : forall p, Zpos (Psucc p) = p + 1. +Proof. intros p;rewrite Zpos_succ_morphism;unfold Zsucc;trivial. Qed. + +Hint Rewrite Zpos_xI_add Zpos_xO_add Pplus_carry_spec + Psucc_Zplus Zpos_plus : zmisc. + +Lemma Zlt_0_pos : forall p, 0 < Zpos p. +Proof. unfold Zlt;trivial. Qed. + + +Lemma Pminus_mask_carry_spec : forall p q, + Pminus_mask_carry p q = Pminus_mask p (Psucc q). +Proof. + intros p q;generalize q p;clear q p. + induction q;destruct p;simpl;try rewrite IHq;trivial. + destruct p;trivial. destruct p;trivial. +Qed. + +Hint Rewrite Pminus_mask_carry_spec : zmisc. + +Ltac zsimpl := autorewrite with zmisc. +Ltac CaseEq t := generalize (refl_equal t);pattern t at -1;case t. +Ltac generalizeclear H := generalize H;clear H. + +Lemma Pminus_mask_spec : + forall p q, + match Pminus_mask p q with + | IsNul => Zpos p = Zpos q + | IsPos k => Zpos p = q + k + | IsNeq => p < q + end. +Proof with zsimpl;auto with zarith. + induction p;destruct q;simpl;zsimpl; + match goal with + | [|- context [(Pminus_mask ?p1 ?q1)]] => + assert (H1 := IHp q1);destruct (Pminus_mask p1 q1) + | _ => idtac + end;simpl ... + inversion H1 ... inversion H1 ... + rewrite Psucc_Zplus in H1 ... + clear IHp;induction p;simpl ... + rewrite IHp;destruct (Pdouble_minus_one p) ... + assert (H:= Zlt_0_pos q) ... assert (H:= Zlt_0_pos q) ... +Qed. + +Definition PminusN x y := + match Pminus_mask x y with + | IsPos k => Npos k + | _ => N0 + end. + +Lemma PminusN_le : forall x y:positive, x <= y -> Z_of_N (PminusN y x) = y - x. +Proof. + intros x y Hle;unfold PminusN. + assert (H := Pminus_mask_spec y x);destruct (Pminus_mask y x). + rewrite H;unfold Z_of_N;auto with zarith. + rewrite H;unfold Z_of_N;auto with zarith. + elimtype False;omega. +Qed. + +Lemma Ppred_Zminus : forall p, 1< Zpos p -> (p-1)%Z = Ppred p. +Proof. destruct p;simpl;trivial. intros;elimtype False;omega. Qed. + + +Open Local Scope positive_scope. + +Delimit Scope P_scope with P. +Open Local Scope P_scope. + +Definition is_lt (n m : positive) := + match (n ?= m) Eq with + | Lt => true + | _ => false + end. +Infix "?<" := is_lt (at level 70, no associativity) : P_scope. + +Lemma is_lt_spec : forall n m, if n ?< m then n < m else m <= n. +Proof. + intros n m; unfold is_lt, Zlt, Zle, Zcompare. + rewrite (ZC4 m n);destruct ((n ?= m) Eq);trivial;try (intro;discriminate). +Qed. + +Definition is_eq a b := + match (a ?= b) Eq with + | Eq => true + | _ => false + end. +Infix "?=" := is_eq (at level 70, no associativity) : P_scope. + +Lemma is_eq_refl : forall n, n ?= n = true. +Proof. intros n;unfold is_eq;rewrite Pcompare_refl;trivial. Qed. + +Lemma is_eq_eq : forall n m, n ?= m = true -> n = m. +Proof. + unfold is_eq;intros n m H; apply Pcompare_Eq_eq; + destruct ((n ?= m)%positive Eq);trivial;try discriminate. +Qed. + +Lemma is_eq_spec_pos : forall n m, if n ?= m then n = m else m <> n. +Proof. + intros n m; CaseEq (n ?= m);intro H. + rewrite (is_eq_eq _ _ H);trivial. + intro H1;rewrite H1 in H;rewrite is_eq_refl in H;discriminate H. +Qed. + +Lemma is_eq_spec : forall n m, if n ?= m then Zpos n = m else Zpos m <> n. +Proof. + intros n m; CaseEq (n ?= m);intro H. + rewrite (is_eq_eq _ _ H);trivial. + intro H1;inversion H1. + rewrite H2 in H;rewrite is_eq_refl in H;discriminate H. +Qed. + +Definition is_Eq a b := + match a, b with + | N0, N0 => true + | Npos a', Npos b' => a' ?= b' + | _, _ => false + end. + +Lemma is_Eq_spec : + forall n m, if is_Eq n m then Z_of_N n = m else Z_of_N m <> n. +Proof. + destruct n;destruct m;simpl;trivial;try (intro;discriminate). + apply is_eq_spec. +Qed. + +(* [times x y] return [x * y], a litle bit more efficiant *) +Fixpoint times (x y : positive) {struct y} : positive := + match x, y with + | xH, _ => y + | _, xH => x + | xO x', xO y' => xO (xO (times x' y')) + | xO x', xI y' => xO (x' + xO (times x' y')) + | xI x', xO y' => xO (y' + xO (times x' y')) + | xI x', xI y' => xI (x' + y' + xO (times x' y')) + end. + +Infix "*" := times : P_scope. + +Lemma times_Zmult : forall p q, Zpos (p * q)%P = (p * q)%Z. +Proof. + intros p q;generalize q p;clear p q. + induction q;destruct p; unfold times; try fold (times p q); + autorewrite with zmisc; try rewrite IHq; ring. +Qed. + +Fixpoint square (x:positive) : positive := + match x with + | xH => xH + | xO x => xO (xO (square x)) + | xI x => xI (xO (square x + x)) + end. + +Lemma square_Zmult : forall x, Zpos (square x) = (x * x) %Z. +Proof. + induction x as [x IHx|x IHx |];unfold square;try (fold (square x)); + autorewrite with zmisc; try rewrite IHx; ring. +Qed. diff --git a/theories/Ints/Z/Pmod.v b/theories/Ints/Z/Pmod.v new file mode 100644 index 000000000..1ea08b4fa --- /dev/null +++ b/theories/Ints/Z/Pmod.v @@ -0,0 +1,565 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Require Import IntsZmisc. +Open Local Scope P_scope. + +(* [div_eucl a b] return [(q,r)] such that a = q*b + r *) +Fixpoint div_eucl (a b : positive) {struct a} : N * N := + match a with + | xH => if 1 ?< b then (0%N, 1%N) else (1%N, 0%N) + | xO a' => + let (q, r) := div_eucl a' b in + match q, r with + | N0, N0 => (0%N, 0%N) (* n'arrive jamais *) + | N0, Npos r => + if (xO r) ?< b then (0%N, Npos (xO r)) + else (1%N,PminusN (xO r) b) + | Npos q, N0 => (Npos (xO q), 0%N) + | Npos q, Npos r => + if (xO r) ?< b then (Npos (xO q), Npos (xO r)) + else (Npos (xI q),PminusN (xO r) b) + end + | xI a' => + let (q, r) := div_eucl a' b in + match q, r with + | N0, N0 => (0%N, 0%N) (* Impossible *) + | N0, Npos r => + if (xI r) ?< b then (0%N, Npos (xI r)) + else (1%N,PminusN (xI r) b) + | Npos q, N0 => if 1 ?< b then (Npos (xO q), 1%N) else (Npos (xI q), 0%N) + | Npos q, Npos r => + if (xI r) ?< b then (Npos (xO q), Npos (xI r)) + else (Npos (xI q),PminusN (xI r) b) + end + end. +Infix "/" := div_eucl : P_scope. + +Open Scope Z_scope. +Opaque Zmult. +Lemma div_eucl_spec : forall a b, + Zpos a = fst (a/b)%P * b + snd (a/b)%P + /\ snd (a/b)%P < b. +Proof with zsimpl;try apply Zlt_0_pos;try ((ring;fail) || omega). + intros a b;generalize a;clear a;induction a;simpl;zsimpl; + try (case IHa;clear IHa;repeat rewrite Zmult_0_l;zsimpl;intros H1 H2; + try rewrite H1; destruct (a/b)%P as [q r]; + destruct q as [|q];destruct r as [|r];simpl in *; + generalize H1 H2;clear H1 H2);repeat rewrite Zmult_0_l; + repeat rewrite Zplus_0_r; + zsimpl;simpl;intros; + match goal with + | [H : Zpos _ = 0 |- _] => discriminate H + | [|- context [ ?xx ?< b ]] => + assert (H3 := is_lt_spec xx b);destruct (xx ?< b) + | _ => idtac + end;simpl;try assert(H4 := Zlt_0_pos r);split;repeat rewrite Zplus_0_r; + try (generalize H3;zsimpl;intros); + try (rewrite PminusN_le;trivial) ... + assert (Zpos b = 1) ... rewrite H ... + assert (H4 := Zlt_0_pos b); assert (Zpos b = 1) ... +Qed. +Transparent Zmult. + +(******** Definition du modulo ************) + +(* [mod a b] return [a] modulo [b] *) +Fixpoint Pmod (a b : positive) {struct a} : N := + match a with + | xH => if 1 ?< b then 1%N else 0%N + | xO a' => + let r := Pmod a' b in + match r with + | N0 => 0%N + | Npos r' => + if (xO r') ?< b then Npos (xO r') + else PminusN (xO r') b + end + | xI a' => + let r := Pmod a' b in + match r with + | N0 => if 1 ?< b then 1%N else 0%N + | Npos r' => + if (xI r') ?< b then Npos (xI r') + else PminusN (xI r') b + end + end. + +Infix "mod" := Pmod (at level 40, no associativity) : P_scope. +Open Local Scope P_scope. + +Lemma Pmod_div_eucl : forall a b, a mod b = snd (a/b). +Proof with auto. + intros a b;generalize a;clear a;induction a;simpl; + try (rewrite IHa; + assert (H1 := div_eucl_spec a b); destruct (a/b) as [q r]; + destruct q as [|q];destruct r as [|r];simpl in *; + match goal with + | [|- context [ ?xx ?< b ]] => + assert (H2 := is_lt_spec xx b);destruct (xx ?< b) + | _ => idtac + end;simpl) ... + destruct H1 as [H3 H4];discriminate H3. + destruct (1 ?< b);simpl ... +Qed. + +Lemma mod1: forall a, a mod 1 = 0%N. +Proof. induction a;simpl;try rewrite IHa;trivial. Qed. + +Lemma mod_a_a_0 : forall a, a mod a = N0. +Proof. + intros a;generalize (div_eucl_spec a a);rewrite <- Pmod_div_eucl. + destruct (fst (a / a));unfold Z_of_N at 1. + rewrite Zmult_0_l;intros (H1,H2);elimtype False;omega. + assert (a<=p*a). + pattern (Zpos a) at 1;rewrite <- (Zmult_1_l a). + assert (H1:= Zlt_0_pos p);assert (H2:= Zle_0_pos a); + apply Zmult_le_compat;trivial;try omega. + destruct (a mod a)%P;auto with zarith. + unfold Z_of_N;assert (H1:= Zlt_0_pos p0);intros (H2,H3);elimtype False;omega. +Qed. + +Lemma mod_le_2r : forall (a b r: positive) (q:N), + Zpos a = b*q + r -> b <= a -> r < b -> 2*r <= a. +Proof. + intros a b r q H0 H1 H2. + assert (H3:=Zlt_0_pos a). assert (H4:=Zlt_0_pos b). assert (H5:=Zlt_0_pos r). + destruct q as [|q]. rewrite Zmult_0_r in H0. elimtype False;omega. + assert (H6:=Zlt_0_pos q). unfold Z_of_N in H0. + assert (Zpos r = a - b*q). omega. + simpl;zsimpl. pattern r at 2;rewrite H. + assert (b <= b * q). + pattern (Zpos b) at 1;rewrite <- (Zmult_1_r b). + apply Zmult_le_compat;try omega. + apply Zle_trans with (a - b * q + b). omega. + apply Zle_trans with (a - b + b);omega. +Qed. + +Lemma mod_lt : forall a b r, a mod b = Npos r -> r < b. +Proof. + intros a b r H;generalize (div_eucl_spec a b);rewrite <- Pmod_div_eucl; + rewrite H;simpl;intros (H1,H2);omega. +Qed. + +Lemma mod_le : forall a b r, a mod b = Npos r -> r <= b. +Proof. intros a b r H;assert (H1:= mod_lt _ _ _ H);omega. Qed. + +Lemma mod_le_a : forall a b r, a mod b = r -> r <= a. +Proof. + intros a b r H;generalize (div_eucl_spec a b);rewrite <- Pmod_div_eucl; + rewrite H;simpl;intros (H1,H2). + assert (0 <= fst (a / b) * b). + destruct (fst (a / b));simpl;auto with zarith. + auto with zarith. +Qed. + +Lemma lt_mod : forall a b, Zpos a < Zpos b -> (a mod b)%P = Npos a. +Proof. + intros a b H; rewrite Pmod_div_eucl. case (div_eucl_spec a b). + assert (0 <= snd(a/b)). destruct (snd(a/b));simpl;auto with zarith. + destruct (fst (a/b)). + unfold Z_of_N at 1;rewrite Zmult_0_l;rewrite Zplus_0_l. + destruct (snd (a/b));simpl; intros H1 H2;inversion H1;trivial. + unfold Z_of_N at 1;assert (b <= p*b). + pattern (Zpos b) at 1; rewrite <- (Zmult_1_l (Zpos b)). + assert (H1 := Zlt_0_pos p);apply Zmult_le_compat;try omega. + apply Zle_0_pos. + intros;elimtype False;omega. +Qed. + +Fixpoint gcd_log2 (a b c:positive) {struct c}: option positive := + match a mod b with + | N0 => Some b + | Npos r => + match b mod r, c with + | N0, _ => Some r + | Npos r', xH => None + | Npos r', xO c' => gcd_log2 r r' c' + | Npos r', xI c' => gcd_log2 r r' c' + end + end. + +Fixpoint egcd_log2 (a b c:positive) {struct c}: + option (Z * Z * positive) := + match a/b with + | (_, N0) => Some (0, 1, b) + | (q, Npos r) => + match b/r, c with + | (_, N0), _ => Some (1, -q, r) + | (q', Npos r'), xH => None + | (q', Npos r'), xO c' => + match egcd_log2 r r' c' with + None => None + | Some (u', v', w') => + let u := u' - v' * q' in + Some (u, v' - q * u, w') + end + | (q', Npos r'), xI c' => + match egcd_log2 r r' c' with + None => None + | Some (u', v', w') => + let u := u' - v' * q' in + Some (u, v' - q * u, w') + end + end + end. + +Lemma egcd_gcd_log2: forall c a b, + match egcd_log2 a b c, gcd_log2 a b c with + None, None => True + | Some (u,v,r), Some r' => r = r' + | _, _ => False + end. +induction c; simpl; auto; try + (intros a b; generalize (Pmod_div_eucl a b); case (a/b); simpl; + intros q r1 H; subst; case (a mod b); auto; + intros r; generalize (Pmod_div_eucl b r); case (b/r); simpl; + intros q' r1 H; subst; case (b mod r); auto; + intros r'; generalize (IHc r r'); case egcd_log2; auto; + intros ((p1,p2),p3); case gcd_log2; auto). +Qed. + +Ltac rw l := + match l with + | (?r, ?r1) => + match type of r with + True => rewrite <- r1 + | _ => rw r; rw r1 + end + | ?r => rewrite r + end. + +Lemma egcd_log2_ok: forall c a b, + match egcd_log2 a b c with + None => True + | Some (u,v,r) => u * a + v * b = r + end. +induction c; simpl; auto; + intros a b; generalize (div_eucl_spec a b); case (a/b); + simpl fst; simpl snd; intros q r1; case r1; try (intros; ring); + simpl; intros r (Hr1, Hr2); clear r1; + generalize (div_eucl_spec b r); case (b/r); + simpl fst; simpl snd; intros q' r1; case r1; + try (intros; rewrite Hr1; ring); + simpl; intros r' (Hr'1, Hr'2); clear r1; auto; + generalize (IHc r r'); case egcd_log2; auto; + intros ((u',v'),w'); case gcd_log2; auto; intros; + rw ((I, H), Hr1, Hr'1); ring. +Qed. + + +Fixpoint log2 (a:positive) : positive := + match a with + | xH => xH + | xO a => Psucc (log2 a) + | xI a => Psucc (log2 a) + end. + +Lemma gcd_log2_1: forall a c, gcd_log2 a xH c = Some xH. +Proof. destruct c;simpl;try rewrite mod1;trivial. Qed. + +Lemma log2_Zle :forall a b, Zpos a <= Zpos b -> log2 a <= log2 b. +Proof with zsimpl;try omega. + induction a;destruct b;zsimpl;intros;simpl ... + assert (log2 a <= log2 b) ... apply IHa ... + assert (log2 a <= log2 b) ... apply IHa ... + assert (H1 := Zlt_0_pos a);elimtype False;omega. + assert (log2 a <= log2 b) ... apply IHa ... + assert (log2 a <= log2 b) ... apply IHa ... + assert (H1 := Zlt_0_pos a);elimtype False;omega. + assert (H1 := Zlt_0_pos (log2 b)) ... + assert (H1 := Zlt_0_pos (log2 b)) ... +Qed. + +Lemma log2_1_inv : forall a, Zpos (log2 a) = 1 -> a = xH. +Proof. + destruct a;simpl;zsimpl;intros;trivial. + assert (H1:= Zlt_0_pos (log2 a));elimtype False;omega. + assert (H1:= Zlt_0_pos (log2 a));elimtype False;omega. +Qed. + +Lemma mod_log2 : + forall a b r:positive, a mod b = Npos r -> b <= a -> log2 r + 1 <= log2 a. +Proof. + intros; cut (log2 (xO r) <= log2 a). simpl;zsimpl;trivial. + apply log2_Zle. + replace (Zpos (xO r)) with (2 * r)%Z;trivial. + generalize (div_eucl_spec a b);rewrite <- Pmod_div_eucl;rewrite H. + rewrite Zmult_comm;intros [H1 H2];apply mod_le_2r with b (fst (a/b));trivial. +Qed. + +Lemma gcd_log2_None_aux : + forall c a b, Zpos b <= Zpos a -> log2 b <= log2 c -> + gcd_log2 a b c <> None. +Proof. + induction c;simpl;intros; + (CaseEq (a mod b);[intros Heq|intros r Heq];try (intro;discriminate)); + (CaseEq (b mod r);[intros Heq'|intros r' Heq'];try (intro;discriminate)). + apply IHc. apply mod_le with b;trivial. + generalize H0 (mod_log2 _ _ _ Heq' (mod_le _ _ _ Heq));zsimpl;intros;omega. + apply IHc. apply mod_le with b;trivial. + generalize H0 (mod_log2 _ _ _ Heq' (mod_le _ _ _ Heq));zsimpl;intros;omega. + assert (Zpos (log2 b) = 1). + assert (H1 := Zlt_0_pos (log2 b));omega. + rewrite (log2_1_inv _ H1) in Heq;rewrite mod1 in Heq;discriminate Heq. +Qed. + +Lemma gcd_log2_None : forall a b, Zpos b <= Zpos a -> gcd_log2 a b b <> None. +Proof. intros;apply gcd_log2_None_aux;auto with zarith. Qed. + +Lemma gcd_log2_Zle : + forall c1 c2 a b, log2 c1 <= log2 c2 -> + gcd_log2 a b c1 <> None -> gcd_log2 a b c2 = gcd_log2 a b c1. +Proof with zsimpl;trivial;try omega. + induction c1;destruct c2;simpl;intros; + (destruct (a mod b) as [|r];[idtac | destruct (b mod r)]) ... + apply IHc1;trivial. generalize H;zsimpl;intros;omega. + apply IHc1;trivial. generalize H;zsimpl;intros;omega. + elim H;destruct (log2 c1);trivial. + apply IHc1;trivial. generalize H;zsimpl;intros;omega. + apply IHc1;trivial. generalize H;zsimpl;intros;omega. + elim H;destruct (log2 c1);trivial. + elim H0;trivial. elim H0;trivial. +Qed. + +Lemma gcd_log2_Zle_log : + forall a b c, log2 b <= log2 c -> Zpos b <= Zpos a -> + gcd_log2 a b c = gcd_log2 a b b. +Proof. + intros a b c H1 H2; apply gcd_log2_Zle; trivial. + apply gcd_log2_None; trivial. +Qed. + +Lemma gcd_log2_mod0 : + forall a b c, a mod b = N0 -> gcd_log2 a b c = Some b. +Proof. intros a b c H;destruct c;simpl;rewrite H;trivial. Qed. + + +Require Import Zwf. + +Lemma Zwf_pos : well_founded (fun x y => Zpos x < Zpos y). +Proof. + unfold well_founded. + assert (forall x a ,x = Zpos a -> Acc (fun x y : positive => x < y) a). + intros x;assert (Hacc := Zwf_well_founded 0 x);induction Hacc;intros;subst x. + constructor;intros. apply H0 with (Zpos y);trivial. + split;auto with zarith. + intros a;apply H with (Zpos a);trivial. +Qed. + +Opaque Pmod. +Lemma gcd_log2_mod : forall a b, Zpos b <= Zpos a -> + forall r, a mod b = Npos r -> gcd_log2 a b b = gcd_log2 b r r. +Proof. + intros a b;generalize a;clear a; assert (Hacc := Zwf_pos b). + induction Hacc; intros a Hle r Hmod. + rename x into b. destruct b;simpl;rewrite Hmod. + CaseEq (xI b mod r)%P;intros. rewrite gcd_log2_mod0;trivial. + assert (H2 := mod_le _ _ _ H1);assert (H3 := mod_lt _ _ _ Hmod); + assert (H4 := mod_le _ _ _ Hmod). + rewrite (gcd_log2_Zle_log r p b);trivial. + symmetry;apply H0;trivial. + generalize (mod_log2 _ _ _ H1 H4);simpl;zsimpl;intros;omega. + CaseEq (xO b mod r)%P;intros. rewrite gcd_log2_mod0;trivial. + assert (H2 := mod_le _ _ _ H1);assert (H3 := mod_lt _ _ _ Hmod); + assert (H4 := mod_le _ _ _ Hmod). + rewrite (gcd_log2_Zle_log r p b);trivial. + symmetry;apply H0;trivial. + generalize (mod_log2 _ _ _ H1 H4);simpl;zsimpl;intros;omega. + rewrite mod1 in Hmod;discriminate Hmod. +Qed. + +Lemma gcd_log2_xO_Zle : + forall a b, Zpos b <= Zpos a -> gcd_log2 a b (xO b) = gcd_log2 a b b. +Proof. + intros a b Hle;apply gcd_log2_Zle. + simpl;zsimpl;auto with zarith. + apply gcd_log2_None_aux;auto with zarith. +Qed. + +Lemma gcd_log2_xO_Zlt : + forall a b, Zpos a < Zpos b -> gcd_log2 a b (xO b) = gcd_log2 b a a. +Proof. + intros a b H;simpl. assert (Hlt := Zlt_0_pos a). + assert (H0 := lt_mod _ _ H). + rewrite H0;simpl. + CaseEq (b mod a)%P;intros;simpl. + symmetry;apply gcd_log2_mod0;trivial. + assert (H2 := mod_lt _ _ _ H1). + rewrite (gcd_log2_Zle_log a p b);auto with zarith. + symmetry;apply gcd_log2_mod;auto with zarith. + apply log2_Zle. + replace (Zpos p) with (Z_of_N (Npos p));trivial. + apply mod_le_a with a;trivial. +Qed. + +Lemma gcd_log2_x0 : forall a b, gcd_log2 a b (xO b) <> None. +Proof. + intros;simpl;CaseEq (a mod b)%P;intros. intro;discriminate. + CaseEq (b mod p)%P;intros. intro;discriminate. + assert (H1 := mod_le_a _ _ _ H0). unfold Z_of_N in H1. + assert (H2 := mod_le _ _ _ H0). + apply gcd_log2_None_aux. trivial. + apply log2_Zle. trivial. +Qed. + +Lemma egcd_log2_x0 : forall a b, egcd_log2 a b (xO b) <> None. +Proof. +intros a b H; generalize (egcd_gcd_log2 (xO b) a b) (gcd_log2_x0 a b); + rw H; case gcd_log2; auto. +Qed. + +Definition gcd a b := + match gcd_log2 a b (xO b) with + | Some p => p + | None => (* can not appear *) 1%positive + end. + +Definition egcd a b := + match egcd_log2 a b (xO b) with + | Some p => p + | None => (* can not appear *) (1,1,1%positive) + end. + + +Lemma gcd_mod0 : forall a b, (a mod b)%P = N0 -> gcd a b = b. +Proof. + intros a b H;unfold gcd. + pattern (gcd_log2 a b (xO b)) at 1; + rewrite (gcd_log2_mod0 _ _ (xO b) H);trivial. +Qed. + +Lemma gcd1 : forall a, gcd a xH = xH. +Proof. intros a;rewrite gcd_mod0;[trivial|apply mod1]. Qed. + +Lemma gcd_mod : forall a b r, (a mod b)%P = Npos r -> + gcd a b = gcd b r. +Proof. + intros a b r H;unfold gcd. + assert (log2 r <= log2 (xO r)). simpl;zsimpl;omega. + assert (H1 := mod_lt _ _ _ H). + pattern (gcd_log2 b r (xO r)) at 1; rewrite gcd_log2_Zle_log;auto with zarith. + destruct (Z_lt_le_dec a b). + pattern (gcd_log2 a b (xO b)) at 1; rewrite gcd_log2_xO_Zlt;trivial. + rewrite (lt_mod _ _ z) in H;inversion H. + assert (r <= b). omega. + generalize (gcd_log2_None _ _ H2). + destruct (gcd_log2 b r r);intros;trivial. + assert (log2 b <= log2 (xO b)). simpl;zsimpl;omega. + pattern (gcd_log2 a b (xO b)) at 1; rewrite gcd_log2_Zle_log;auto with zarith. + pattern (gcd_log2 a b b) at 1;rewrite (gcd_log2_mod _ _ z _ H). + assert (r <= b). omega. + generalize (gcd_log2_None _ _ H3). + destruct (gcd_log2 b r r);intros;trivial. +Qed. + +Require Import ZArith. +Require Import Znumtheory. + +Hint Rewrite Zpos_mult times_Zmult square_Zmult Psucc_Zplus: zmisc. + +Ltac mauto := + trivial;autorewrite with zmisc;trivial;auto with zarith. + +Lemma gcd_Zis_gcd : forall a b:positive, (Zis_gcd b a (gcd b a)%P). +Proof with mauto. + intros a;assert (Hacc := Zwf_pos a);induction Hacc;rename x into a;intros. + generalize (div_eucl_spec b a)... + rewrite <- (Pmod_div_eucl b a). + CaseEq (b mod a)%P;[intros Heq|intros r Heq]; intros (H1,H2). + simpl in H1;rewrite Zplus_0_r in H1. + rewrite (gcd_mod0 _ _ Heq). + constructor;mauto. + apply Zdivide_intro with (fst (b/a)%P);trivial. + rewrite (gcd_mod _ _ _ Heq). + rewrite H1;apply Zis_gcd_sym. + rewrite Zmult_comm;apply Zis_gcd_for_euclid2;simpl in *. + apply Zis_gcd_sym;auto. +Qed. + +Lemma egcd_Zis_gcd : forall a b:positive, + let (uv,w) := egcd a b in + let (u,v) := uv in + u * a + v * b = w /\ (Zis_gcd b a w). +Proof with mauto. + intros a b; unfold egcd. + generalize (egcd_log2_ok (xO b) a b) (egcd_gcd_log2 (xO b) a b) + (egcd_log2_x0 a b) (gcd_Zis_gcd b a); unfold egcd, gcd. + case egcd_log2; try (intros ((u,v),w)); case gcd_log2; + try (intros; match goal with H: False |- _ => case H end); + try (intros _ _ H1; case H1; auto; fail). + intros; subst; split; try apply Zis_gcd_sym; auto. +Qed. + +Definition Zgcd a b := + match a, b with + | Z0, _ => b + | _, Z0 => a + | Zpos a, Zneg b => Zpos (gcd a b) + | Zneg a, Zpos b => Zpos (gcd a b) + | Zpos a, Zpos b => Zpos (gcd a b) + | Zneg a, Zneg b => Zpos (gcd a b) + end. + + +Lemma Zgcd_is_gcd : forall x y, Zis_gcd x y (Zgcd x y). +Proof. + destruct x;destruct y;simpl. + apply Zis_gcd_0. + apply Zis_gcd_sym;apply Zis_gcd_0. + apply Zis_gcd_sym;apply Zis_gcd_0. + apply Zis_gcd_0. + apply gcd_Zis_gcd. + apply Zis_gcd_sym;apply Zis_gcd_minus;simpl;apply gcd_Zis_gcd. + apply Zis_gcd_0. + apply Zis_gcd_minus;simpl;apply Zis_gcd_sym;apply gcd_Zis_gcd. + apply Zis_gcd_minus;apply Zis_gcd_minus;simpl;apply gcd_Zis_gcd. +Qed. + +Definition Zegcd a b := + match a, b with + | Z0, Z0 => (0,0,0) + | Zpos _, Z0 => (1,0,a) + | Zneg _, Z0 => (-1,0,-a) + | Z0, Zpos _ => (0,1,b) + | Z0, Zneg _ => (0,-1,-b) + | Zpos a, Zneg b => + match egcd a b with (u,v,w) => (u,-v, Zpos w) end + | Zneg a, Zpos b => + match egcd a b with (u,v,w) => (-u,v, Zpos w) end + | Zpos a, Zpos b => + match egcd a b with (u,v,w) => (u,v, Zpos w) end + | Zneg a, Zneg b => + match egcd a b with (u,v,w) => (-u,-v, Zpos w) end + end. + +Lemma Zegcd_is_egcd : forall x y, + match Zegcd x y with + (u,v,w) => u * x + v * y = w /\ Zis_gcd x y w /\ 0 <= w + end. +Proof. + assert (zx0: forall x, Zneg x = -x). + simpl; auto. + assert (zx1: forall x, -(-x) = x). + intro x; case x; simpl; auto. + destruct x;destruct y;simpl; try (split; [idtac|split]); + auto; try (red; simpl; intros; discriminate); + try (rewrite zx0; apply Zis_gcd_minus; try rewrite zx1; auto; + apply Zis_gcd_minus; try rewrite zx1; simpl; auto); + try apply Zis_gcd_0; try (apply Zis_gcd_sym;apply Zis_gcd_0); + generalize (egcd_Zis_gcd p p0); case egcd; intros (u,v,w) (H1, H2); + split; repeat rewrite zx0; try (rewrite <- H1; ring); auto; + (split; [idtac | red; intros; discriminate]). + apply Zis_gcd_sym; auto. + apply Zis_gcd_sym; apply Zis_gcd_minus; rw zx1; + apply Zis_gcd_sym; auto. + apply Zis_gcd_minus; rw zx1; auto. + apply Zis_gcd_minus; rw zx1; auto. + apply Zis_gcd_minus; rw zx1; auto. + apply Zis_gcd_sym; auto. +Qed. diff --git a/theories/Ints/Z/Ppow.v b/theories/Ints/Z/Ppow.v new file mode 100644 index 000000000..b4e4ca5ef --- /dev/null +++ b/theories/Ints/Z/Ppow.v @@ -0,0 +1,39 @@ +Require Import ZArith. +Require Import ZAux. + +Open Scope Z_scope. + +Fixpoint Ppow a z {struct z}:= + match z with + xH => a + | xO z1 => let v := Ppow a z1 in (Pmult v v) + | xI z1 => let v := Ppow a z1 in (Pmult a (Pmult v v)) + end. + +Theorem Ppow_correct: forall a z, + Zpos (Ppow a z) = (Zpos a) ^ (Zpos z). +intros a z; elim z; simpl Ppow; auto; + try (intros z1 Hrec; repeat rewrite Zpos_mult_morphism; rewrite Hrec). + rewrite Zpos_xI; rewrite Zpower_exp; auto with zarith. + rewrite Zpower_exp_1; rewrite (Zmult_comm 2); + try rewrite Zpower_mult; auto with zarith. + change 2 with (1 + 1); rewrite Zpower_exp; auto with zarith. + rewrite Zpower_exp_1; rewrite Zmult_comm; auto. + apply Zle_ge; auto with zarith. + rewrite Zpos_xO; rewrite (Zmult_comm 2); + rewrite Zpower_mult; auto with zarith. + change 2 with (1 + 1); rewrite Zpower_exp; auto with zarith. + rewrite Zpower_exp_1; auto. + rewrite Zpower_exp_1; auto. +Qed. + +Theorem Ppow_plus: forall a z1 z2, + Ppow a (z1 + z2) = ((Ppow a z1) * (Ppow a z2))%positive. +intros a z1 z2. + assert (tmp: forall x y, Zpos x = Zpos y -> x = y). + intros x y H; injection H; auto. + apply tmp. + rewrite Zpos_mult_morphism; repeat rewrite Ppow_correct. + rewrite Zpos_plus_distr; rewrite Zpower_exp; auto; red; simpl; + intros; discriminate. +Qed. diff --git a/theories/Ints/Z/ZAux.v b/theories/Ints/Z/ZAux.v new file mode 100644 index 000000000..73fdbd128 --- /dev/null +++ b/theories/Ints/Z/ZAux.v @@ -0,0 +1,1372 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + Aux.v + + Auxillary functions & Theorems + **********************************************************************) + +Require Import ArithRing. +Require Export ZArith. +Require Export Znumtheory. +Require Export Tactic. +(* Require Import MOmega. *) + + +Open Local Scope Z_scope. + +Hint Extern 2 (Zle _ _) => + (match goal with + |- Zpos _ <= Zpos _ => exact (refl_equal _) +| H: _ <= ?p |- _ <= ?p => apply Zle_trans with (2 := H) +| H: _ < ?p |- _ <= ?p => apply Zlt_le_weak; apply Zle_lt_trans with (2 := H) + end). + +Hint Extern 2 (Zlt _ _) => + (match goal with + |- Zpos _ < Zpos _ => exact (refl_equal _) +| H: _ <= ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H) +| H: _ < ?p |- _ <= ?p => apply Zle_lt_trans with (2 := H) + end). + +(************************************** + Properties of order and product + **************************************) + +Theorem Zmult_interval: forall p q, 0 < p * q -> 1 < p -> 0 < q < p * q. +intros p q H1 H2; assert (0 < q). +case (Zle_or_lt q 0); auto; intros H3; contradict H1; apply Zle_not_lt. +rewrite <- (Zmult_0_r p). +apply Zmult_le_compat_l; auto with zarith. +split; auto. +pattern q at 1; rewrite <- (Zmult_1_l q). +apply Zmult_lt_compat_r; auto with zarith. +Qed. + +Theorem Zmult_lt_compat: forall n m p q : Z, 0 < n <= p -> 0 < m < q -> n * m < p * q. +intros n m p q (H1, H2) (H3, H4). +apply Zle_lt_trans with (p * m). +apply Zmult_le_compat_r; auto with zarith. +apply Zmult_lt_compat_l; auto with zarith. +Qed. + +Theorem Zle_square_mult: forall a b, 0 <= a <= b -> a * a <= b * b. +intros a b (H1, H2); apply Zle_trans with (a * b); auto with zarith. +Qed. + +Theorem Zlt_square_mult: forall a b, 0 <= a < b -> a * a < b * b. +intros a b (H1, H2); apply Zle_lt_trans with (a * b); auto with zarith. +apply Zmult_lt_compat_r; auto with zarith. +Qed. + +Theorem Zlt_square_mult_inv: forall a b, 0 <= a -> 0 <= b -> a * a < b * b -> a < b. +intros a b H1 H2 H3; case (Zle_or_lt b a); auto; intros H4; apply Zmult_lt_reg_r with a; + contradict H3; apply Zle_not_lt; apply Zle_square_mult; auto. +Qed. + + +Theorem Zpower_2: forall x, x^2 = x * x. +intros; ring. +Qed. + + Theorem beta_lex: forall a b c d beta, + a * beta + b <= c * beta + d -> + 0 <= b < beta -> 0 <= d < beta -> + a <= c. +Proof. + intros a b c d beta H1 (H3, H4) (H5, H6). + assert (a - c < 1); auto with zarith. + apply Zmult_lt_reg_r with beta; auto with zarith. + apply Zle_lt_trans with (d - b); auto with zarith. + rewrite Zmult_minus_distr_r; auto with zarith. + Qed. + + Theorem beta_lex_inv: forall a b c d beta, + a < c -> 0 <= b < beta -> + 0 <= d < beta -> + a * beta + b < c * beta + d. + Proof. + intros a b c d beta H1 (H3, H4) (H5, H6). + case (Zle_or_lt (c * beta + d) (a * beta + b)); auto with zarith. + intros H7; contradict H1;apply Zle_not_lt;apply beta_lex with (1 := H7);auto. + Qed. + + Lemma beta_mult : forall h l beta, + 0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2. + Proof. + intros h l beta H1 H2;split. auto with zarith. + rewrite <- (Zplus_0_r (beta^2)); rewrite Zpower_2; + apply beta_lex_inv;auto with zarith. + Qed. + + Lemma Zmult_lt_b : + forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1. + Proof. + intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith. + apply Zle_trans with ((b-1)*(b-1)). + apply Zmult_le_compat;auto with zarith. + apply Zeq_le;ring. + Qed. + + Lemma sum_mul_carry : forall xh xl yh yl wc cc beta, + 1 < beta -> + 0 <= wc < beta -> + 0 <= xh < beta -> + 0 <= xl < beta -> + 0 <= yh < beta -> + 0 <= yl < beta -> + 0 <= cc < beta^2 -> + wc*beta^2 + cc = xh*yl + xl*yh -> + 0 <= wc <= 1. + Proof. + intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. + assert (H8 := Zmult_lt_b beta xh yl H2 H5). + assert (H9 := Zmult_lt_b beta xl yh H3 H4). + split;auto with zarith. + apply beta_lex with (cc) (beta^2 - 2) (beta^2); auto with zarith. + Qed. + + Theorem mult_add_ineq: forall x y cross beta, + 0 <= x < beta -> + 0 <= y < beta -> + 0 <= cross < beta -> + 0 <= x * y + cross < beta^2. + Proof. + intros x y cross beta HH HH1 HH2. + split; auto with zarith. + apply Zle_lt_trans with ((beta-1)*(beta-1)+(beta-1)); auto with zarith. + apply Zplus_le_compat; auto with zarith. + apply Zmult_le_compat; auto with zarith. + repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); + rewrite Zpower_2; auto with zarith. + Qed. + + Theorem mult_add_ineq2: forall x y c cross beta, + 0 <= x < beta -> + 0 <= y < beta -> + 0 <= c*beta + cross <= 2*beta - 2 -> + 0 <= x * y + (c*beta + cross) < beta^2. + Proof. + intros x y c cross beta HH HH1 HH2. + split; auto with zarith. + apply Zle_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith. + apply Zplus_le_compat; auto with zarith. + apply Zmult_le_compat; auto with zarith. + repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); + rewrite Zpower_2; auto with zarith. + Qed. + +Theorem mult_add_ineq3: forall x y c cross beta, + 0 <= x < beta -> + 0 <= y < beta -> + 0 <= cross <= beta - 2 -> + 0 <= c <= 1 -> + 0 <= x * y + (c*beta + cross) < beta^2. + Proof. + intros x y c cross beta HH HH1 HH2 HH3. + apply mult_add_ineq2;auto with zarith. + split;auto with zarith. + apply Zle_trans with (1*beta+cross);auto with zarith. + Qed. + + +(************************************** + Properties of Z_nat + **************************************) + +Theorem inj_eq_inv: forall (n m : nat), Z_of_nat n = Z_of_nat m -> n = m. +intros n m H1; case (le_or_lt n m); auto with arith. +intros H2; case (le_lt_or_eq _ _ H2); auto; intros H3. +contradict H1; auto with zarith. +intros H2; contradict H1; auto with zarith. +Qed. + +Theorem inj_le_inv: forall (n m : nat), Z_of_nat n <= Z_of_nat m-> (n <= m)%nat. +intros n m H1; case (le_or_lt n m); auto with arith. +intros H2; contradict H1; auto with zarith. +Qed. + +Theorem Z_of_nat_Zabs_nat: + forall (z : Z), 0 <= z -> Z_of_nat (Zabs_nat z) = z. +intros z; case z; simpl; auto with zarith. +intros; apply sym_equal; apply Zpos_eq_Z_of_nat_o_nat_of_P; auto. +intros p H1; contradict H1; simpl; auto with zarith. +Qed. + +(************************************** + Properties of Zabs +**************************************) + +Theorem Zabs_square: forall a, a * a = Zabs a * Zabs a. +intros a; rewrite <- Zabs_Zmult; apply sym_equal; apply Zabs_eq; + auto with zarith. +case (Zle_or_lt 0%Z a); auto with zarith. +intros Ha; replace (a * a) with (- a * - a); auto with zarith. +ring. +Qed. + +(************************************** + Properties of Zabs_nat +**************************************) + +Theorem Z_of_nat_abs_le: + forall x y, x <= y -> x + Z_of_nat (Zabs_nat (y - x)) = y. +intros x y Hx1. +rewrite Z_of_nat_Zabs_nat; auto with zarith. +Qed. + +Theorem Zabs_nat_Zsucc: + forall p, 0 <= p -> Zabs_nat (Zsucc p) = S (Zabs_nat p). +intros p Hp. +apply inj_eq_inv. +rewrite inj_S; (repeat rewrite Z_of_nat_Zabs_nat); auto with zarith. +Qed. + +Theorem Zabs_nat_Z_of_nat: forall n, Zabs_nat (Z_of_nat n) = n. +intros n1; apply inj_eq_inv; rewrite Z_of_nat_Zabs_nat; auto with zarith. +Qed. + + +(************************************** + Properties Zsqrt_plain +**************************************) + +Theorem Zsqrt_plain_is_pos: forall n, 0 <= n -> 0 <= Zsqrt_plain n. +intros n m; case (Zsqrt_interval n); auto with zarith. +intros H1 H2; case (Zle_or_lt 0 (Zsqrt_plain n)); auto. +intros H3; contradict H2; apply Zle_not_lt. +apply Zle_trans with ( 2 := H1 ). +replace ((Zsqrt_plain n + 1) * (Zsqrt_plain n + 1)) + with (Zsqrt_plain n * Zsqrt_plain n + (2 * Zsqrt_plain n + 1)); + auto with zarith. +ring. +Qed. + +Theorem Zsqrt_square_id: forall a, 0 <= a -> Zsqrt_plain (a * a) = a. +intros a H. +generalize (Zsqrt_plain_is_pos (a * a)); auto with zarith; intros Haa. +case (Zsqrt_interval (a * a)); auto with zarith. +intros H1 H2. +case (Zle_or_lt a (Zsqrt_plain (a * a))); intros H3; auto. +case Zle_lt_or_eq with ( 1 := H3 ); auto; clear H3; intros H3. +contradict H1; apply Zlt_not_le; auto with zarith. +apply Zle_lt_trans with (a * Zsqrt_plain (a * a)); auto with zarith. +apply Zmult_lt_compat_r; auto with zarith. +contradict H2; apply Zle_not_lt; auto with zarith. +apply Zmult_le_compat; auto with zarith. +Qed. + +Theorem Zsqrt_le: + forall p q, 0 <= p <= q -> Zsqrt_plain p <= Zsqrt_plain q. +intros p q [H1 H2]; case Zle_lt_or_eq with ( 1 := H2 ); clear H2; intros H2. +2:subst q; auto with zarith. +case (Zle_or_lt (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3. +assert (Hp: (0 <= Zsqrt_plain q)). +apply Zsqrt_plain_is_pos; auto with zarith. +absurd (q <= p); auto with zarith. +apply Zle_trans with ((Zsqrt_plain q + 1) * (Zsqrt_plain q + 1)). +case (Zsqrt_interval q); auto with zarith. +apply Zle_trans with (Zsqrt_plain p * Zsqrt_plain p); auto with zarith. +apply Zmult_le_compat; auto with zarith. +case (Zsqrt_interval p); auto with zarith. +Qed. + + +(************************************** + Properties Zpower +**************************************) + +Theorem Zpower_1: forall a, 0 <= a -> 1 ^ a = 1. +intros a Ha; pattern a; apply natlike_ind; auto with zarith. +intros x Hx Hx1; unfold Zsucc. +rewrite Zpower_exp; auto with zarith. +rewrite Hx1; simpl; auto. +Qed. + +Theorem Zpower_exp_0: forall a, a ^ 0 = 1. +simpl; unfold Zpower_pos; simpl; auto with zarith. +Qed. + +Theorem Zpower_exp_1: forall a, a ^ 1 = a. +simpl; unfold Zpower_pos; simpl; auto with zarith. +Qed. + +Theorem Zpower_Zabs: forall a b, Zabs (a ^ b) = (Zabs a) ^ b. +intros a b; case (Zle_or_lt 0 b). +intros Hb; pattern b; apply natlike_ind; auto with zarith. +intros x Hx Hx1; unfold Zsucc. +(repeat rewrite Zpower_exp); auto with zarith. +rewrite Zabs_Zmult; rewrite Hx1. +eq_tac; auto. +replace (a ^ 1) with a; auto. +simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto. +simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto. +case b; simpl; auto with zarith. +intros p Hp; discriminate. +Qed. + +Theorem Zpower_Zsucc: forall p n, 0 <= n -> p ^Zsucc n = p * p ^ n. +intros p n H. +unfold Zsucc; rewrite Zpower_exp; auto with zarith. +rewrite Zpower_exp_1; apply Zmult_comm. +Qed. + +Theorem Zpower_mult: forall p q r, 0 <= q -> 0 <= r -> p ^ (q * r) = (p ^ q) ^ r. +intros p q r H1 H2; generalize H2; pattern r; apply natlike_ind; auto. +intros H3; rewrite Zmult_0_r; repeat rewrite Zpower_exp_0; auto. +intros r1 H3 H4 H5. +unfold Zsucc; rewrite Zpower_exp; auto with zarith. +rewrite <- H4; try rewrite Zpower_exp_1; try rewrite <- Zpower_exp; try eq_tac; auto with zarith. +ring. +apply Zle_ge; replace 0 with (0 * r1); try apply Zmult_le_compat_r; auto. +Qed. + +Theorem Zpower_lt_0: forall a b: Z, 0 < a -> 0 <= b-> 0 < a ^b. +intros a b; case b; auto with zarith. +simpl; intros; auto with zarith. +2: intros p H H1; case H1; auto. +intros p H1 H; generalize H; pattern (Zpos p); apply natlike_ind; auto. +intros; case a; compute; auto. +intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith. +apply Zmult_lt_O_compat; auto with zarith. +generalize H1; case a; compute; intros; auto; discriminate. +Qed. + +Theorem Zpower_le_monotone: forall a b c: Z, 0 < a -> 0 <= b <= c -> a ^ b <= a ^ c. +intros a b c H (H1, H2). +rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith. +rewrite Zpower_exp; auto with zarith. +apply Zmult_le_compat_l; auto with zarith. +assert (0 < a ^ (c - b)); auto with zarith. +apply Zpower_lt_0; auto with zarith. +apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith. +Qed. + +Theorem Zpower_lt_monotone: forall a b c: Z, 1 < a -> 0 <= b < c -> a ^ b < a ^ c. +intros a b c H (H1, H2). +rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith. +rewrite Zpower_exp; auto with zarith. +apply Zmult_lt_compat_l; auto with zarith. +apply Zpower_lt_0; auto with zarith. +assert (0 < a ^ (c - b)); auto with zarith. +apply Zpower_lt_0; auto with zarith. +apply Zlt_le_trans with (a ^1); auto with zarith. +rewrite Zpower_exp_1; auto with zarith. +apply Zpower_le_monotone; auto with zarith. +Qed. + +Theorem Zpower_nat_Zpower: forall p q, 0 <= q -> p ^ q = Zpower_nat p (Zabs_nat q). +intros p1 q1; case q1; simpl. +intros _; exact (refl_equal _). +intros p2 _; apply Zpower_pos_nat. +intros p2 H1; case H1; auto. +Qed. + + +(************************************** + Properties Zmod +**************************************) + +Theorem Zmod_mult: + forall a b n, 0 < n -> (a * b) mod n = ((a mod n) * (b mod n)) mod n. +intros a b n H. +pattern a at 1; rewrite (Z_div_mod_eq a n); auto with zarith. +pattern b at 1; rewrite (Z_div_mod_eq b n); auto with zarith. +replace ((n * (a / n) + a mod n) * (n * (b / n) + b mod n)) + with + ((a mod n) * (b mod n) + + (((n * (a / n)) * (b / n) + (b mod n) * (a / n)) + (a mod n) * (b / n)) * + n); auto with zarith. +apply Z_mod_plus; auto with zarith. +ring. +Qed. + +Theorem Zmod_plus: + forall a b n, 0 < n -> (a + b) mod n = (a mod n + b mod n) mod n. +intros a b n H. +pattern a at 1; rewrite (Z_div_mod_eq a n); auto with zarith. +pattern b at 1; rewrite (Z_div_mod_eq b n); auto with zarith. +replace ((n * (a / n) + a mod n) + (n * (b / n) + b mod n)) + with ((a mod n + b mod n) + (a / n + b / n) * n); auto with zarith. +apply Z_mod_plus; auto with zarith. +ring. +Qed. + +Theorem Zmod_mod: forall a n, 0 < n -> (a mod n) mod n = a mod n. +intros a n H. +pattern a at 2; rewrite (Z_div_mod_eq a n); auto with zarith. +rewrite Zplus_comm; rewrite Zmult_comm. +apply sym_equal; apply Z_mod_plus; auto with zarith. +Qed. + +Theorem Zmod_def_small: forall a n, 0 <= a < n -> a mod n = a. +intros a n [H1 H2]; unfold Zmod. +generalize (Z_div_mod a n); case (Zdiv_eucl a n). +intros q r H3; case H3; clear H3; auto with zarith. +auto with zarith. +intros H4 [H5 H6]. +case (Zle_or_lt q (- 1)); intros H7. +contradict H1; apply Zlt_not_le. +subst a. +apply Zle_lt_trans with (n * - 1 + r); auto with zarith. +case (Zle_lt_or_eq 0 q); auto with zarith; intros H8. +contradict H2; apply Zle_not_lt. +apply Zle_trans with (n * 1 + r); auto with zarith. +rewrite H4; auto with zarith. +subst a; subst q; auto with zarith. +Qed. + +Theorem Zmod_minus: forall a b n, 0 < n -> (a - b) mod n = (a mod n - b mod n) mod n. +intros a b n H; replace (a - b) with (a + (-1) * b); auto with zarith. +replace (a mod n - b mod n) with (a mod n + (-1) * (b mod n)); auto with zarith. +rewrite Zmod_plus; auto with zarith. +rewrite Zmod_mult; auto with zarith. +rewrite (fun x y => Zmod_plus x ((-1) * y)); auto with zarith. +rewrite Zmod_mult; auto with zarith. +rewrite (fun x => Zmod_mult x (b mod n)); auto with zarith. +repeat rewrite Zmod_mod; auto. +Qed. + +Theorem Zmod_Zpower: forall p q n, 0 < n -> (p ^ q) mod n = ((p mod n) ^ q) mod n. +intros p q n Hn; case (Zle_or_lt 0 q); intros H1. +generalize H1; pattern q; apply natlike_ind; auto. +intros q1 Hq1 Rec _; unfold Zsucc; repeat rewrite Zpower_exp; repeat rewrite Zpower_exp_1; auto with zarith. +rewrite (fun x => (Zmod_mult x p)); try rewrite Rec; auto. +rewrite (fun x y => (Zmod_mult (x ^y))); try eq_tac; auto. +eq_tac; auto; apply sym_equal; apply Zmod_mod; auto with zarith. +generalize H1; case q; simpl; auto. +intros; discriminate. +Qed. + +Theorem Zmod_le: forall a n, 0 < n -> 0 <= a -> (Zmod a n) <= a. +intros a n H1 H2; case (Zle_or_lt n a); intros H3. +case (Z_mod_lt a n); auto with zarith. +rewrite Zmod_def_small; auto with zarith. +Qed. + +(** A better way to compute Zpower mod **) + +Fixpoint Zpow_mod_pos (a: Z) (m: positive) (n : Z) {struct m} : Z := + match m with + | xH => a mod n + | xO m' => + let z := Zpow_mod_pos a m' n in + match z with + | 0 => 0 + | _ => (z * z) mod n + end + | xI m' => + let z := Zpow_mod_pos a m' n in + match z with + | 0 => 0 + | _ => (z * z * a) mod n + end + end. + +Theorem Zpow_mod_pos_Zpower_pos_correct: forall a m n, 0 < n -> Zpow_mod_pos a m n = (Zpower_pos a m) mod n. +intros a m; elim m; simpl; auto. +intros p Rec n H1; rewrite xI_succ_xO; rewrite Pplus_one_succ_r; rewrite <- Pplus_diag; auto. +repeat rewrite Zpower_pos_is_exp; auto. +repeat rewrite Rec; auto. +replace (Zpower_pos a 1) with a; auto. +2: unfold Zpower_pos; simpl; auto with zarith. +repeat rewrite (fun x => (Zmod_mult x a)); auto. +rewrite (Zmod_mult (Zpower_pos a p)); auto. +case (Zpower_pos a p mod n); auto. +intros p Rec n H1; rewrite <- Pplus_diag; auto. +repeat rewrite Zpower_pos_is_exp; auto. +repeat rewrite Rec; auto. +rewrite (Zmod_mult (Zpower_pos a p)); auto. +case (Zpower_pos a p mod n); auto. +unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto with zarith. +Qed. + +Definition Zpow_mod a m n := match m with 0 => 1 | Zpos p1 => Zpow_mod_pos a p1 n | Zneg p1 => 0 end. + +Theorem Zpow_mod_Zpower_correct: forall a m n, 1 < n -> 0 <= m -> Zpow_mod a m n = (a ^ m) mod n. +intros a m n; case m; simpl. +intros; apply sym_equal; apply Zmod_def_small; auto with zarith. +intros; apply Zpow_mod_pos_Zpower_pos_correct; auto with zarith. +intros p H H1; case H1; auto. +Qed. + +(* A direct way to compute Zmod *) + +Fixpoint Zmod_POS (a : positive) (b : Z) {struct a} : Z := + match a with + | xI a' => + let r := Zmod_POS a' b in + let r' := (2 * r + 1) in + if Zgt_bool b r' then r' else (r' - b) + | xO a' => + let r := Zmod_POS a' b in + let r' := (2 * r) in + if Zgt_bool b r' then r' else (r' - b) + | xH => if Zge_bool b 2 then 1 else 0 + end. + +Theorem Zmod_POS_correct: forall a b, Zmod_POS a b = (snd (Zdiv_eucl_POS a b)). +intros a b; elim a; simpl; auto. +intros p Rec; rewrite Rec. +case (Zdiv_eucl_POS p b); intros z1 z2; simpl; auto. +match goal with |- context [Zgt_bool _ ?X] => case (Zgt_bool b X) end; auto. +intros p Rec; rewrite Rec. +case (Zdiv_eucl_POS p b); intros z1 z2; simpl; auto. +match goal with |- context [Zgt_bool _ ?X] => case (Zgt_bool b X) end; auto. +case (Zge_bool b 2); auto. +Qed. + +Definition Zmodd a b := +match a with +| Z0 => 0 +| Zpos a' => + match b with + | Z0 => 0 + | Zpos _ => Zmod_POS a' b + | Zneg b' => + let r := Zmod_POS a' (Zpos b') in + match r with Z0 => 0 | _ => b + r end + end +| Zneg a' => + match b with + | Z0 => 0 + | Zpos _ => + let r := Zmod_POS a' b in + match r with Z0 => 0 | _ => b - r end + | Zneg b' => - (Zmod_POS a' (Zpos b')) + end +end. + +Theorem Zmodd_correct: forall a b, Zmodd a b = Zmod a b. +intros a b; unfold Zmod; case a; simpl; auto. +intros p; case b; simpl; auto. +intros p1; refine (Zmod_POS_correct _ _); auto. +intros p1; rewrite Zmod_POS_correct; auto. +case (Zdiv_eucl_POS p (Zpos p1)); simpl; intros z1 z2; case z2; auto. +intros p; case b; simpl; auto. +intros p1; rewrite Zmod_POS_correct; auto. +case (Zdiv_eucl_POS p (Zpos p1)); simpl; intros z1 z2; case z2; auto. +intros p1; rewrite Zmod_POS_correct; simpl; auto. +case (Zdiv_eucl_POS p (Zpos p1)); auto. +Qed. + +(************************************** + Properties of Zdivide +**************************************) + +Theorem Zdivide_trans: forall a b c, (a | b) -> (b | c) -> (a | c). +intros a b c [d H1] [e H2]; exists (d * e)%Z; auto with zarith. +rewrite H2; rewrite H1; ring. +Qed. + +Theorem Zdivide_Zabs_l: forall a b, (Zabs a | b) -> (a | b). +intros a b [x H]; subst b. +pattern (Zabs a); apply Zabs_intro. +exists (- x); ring. +exists x; ring. +Qed. + +Theorem Zdivide_Zabs_inv_l: forall a b, (a | b) -> (Zabs a | b). +intros a b [x H]; subst b. +pattern (Zabs a); apply Zabs_intro. +exists (- x); ring. +exists x; ring. +Qed. + +Theorem Zdivide_le: forall a b, 0 <= a -> 0 < b -> (a | b) -> a <= b. +intros a b H1 H2 [q H3]; subst b. +case (Zle_lt_or_eq 0 a); auto with zarith; intros H3. +case (Zle_lt_or_eq 0 q); auto with zarith. +apply (Zmult_le_0_reg_r a); auto with zarith. +intros H4; apply Zle_trans with (1 * a); auto with zarith. +intros H4; subst q; contradict H2; auto with zarith. +Qed. + +Theorem Zdivide_Zdiv_eq: forall a b, 0 < a -> (a | b) -> b = a * (b / a). +intros a b Hb Hc. +pattern b at 1; rewrite (Z_div_mod_eq b a); auto with zarith. +rewrite (Zdivide_mod b a); auto with zarith. +Qed. + +Theorem Zdivide_Zdiv_lt_pos: + forall a b, 1 < a -> 0 < b -> (a | b) -> 0 < b / a < b . +intros a b H1 H2 H3; split. +apply Zmult_lt_reg_r with a; auto with zarith. +rewrite (Zmult_comm (Zdiv b a)); rewrite <- Zdivide_Zdiv_eq; auto with zarith. +apply Zmult_lt_reg_r with a; auto with zarith. +(repeat rewrite (fun x => Zmult_comm x a)); auto with zarith. +rewrite <- Zdivide_Zdiv_eq; auto with zarith. +pattern b at 1; replace b with (1 * b); auto with zarith. +apply Zmult_lt_compat_r; auto with zarith. +Qed. + +Theorem Zmod_divide_minus: forall a b c, 0 < b -> a mod b = c -> (b | a - c). +intros a b c H H1; apply Zmod_divide; auto with zarith. +rewrite Zmod_minus; auto. +rewrite H1; pattern c at 1; rewrite <- (Zmod_def_small c b); auto with zarith. +rewrite Zminus_diag; apply Zmod_def_small; auto with zarith. +subst; apply Z_mod_lt; auto with zarith. +Qed. + +Theorem Zdivide_mod_minus: forall a b c, 0 <= c < b -> (b | a -c) -> (a mod b) = c. +intros a b c (H1, H2) H3; assert (0 < b); try apply Zle_lt_trans with c; auto. +replace a with ((a - c) + c); auto with zarith. +rewrite Zmod_plus; auto with zarith. +rewrite (Zdivide_mod (a -c) b); try rewrite Zplus_0_l; auto with zarith. +rewrite Zmod_mod; try apply Zmod_def_small; auto with zarith. +Qed. + +Theorem Zmod_closeby_eq: forall a b n, 0 <= a -> 0 <= b < n -> a - b < n -> a mod n = b -> a = b. +intros a b n H H1 H2 H3. +case (Zle_or_lt 0 (a - b)); intros H4. +case Zle_lt_or_eq with (1 := H4); clear H4; intros H4; auto with zarith. +contradict H2; apply Zle_not_lt; apply Zdivide_le; auto with zarith. +apply Zmod_divide_minus; auto with zarith. +rewrite <- (Zmod_def_small a n); try split; auto with zarith. +Qed. + +Theorem Zpower_divide: forall p q, 0 < q -> (p | p ^ q). +intros p q H; exists (p ^(q - 1)). +pattern p at 3; rewrite <- (Zpower_exp_1 p); rewrite <- Zpower_exp; try eq_tac; auto with zarith. +Qed. + +(************************************** + Properties of Zis_gcd +**************************************) + +Theorem Zis_gcd_unique: + forall (a b c d : Z), Zis_gcd a b c -> Zis_gcd b a d -> c = d \/ c = (- d). +intros a b c d H1 H2. +inversion_clear H1 as [Hc1 Hc2 Hc3]. +inversion_clear H2 as [Hd1 Hd2 Hd3]. +assert (H3: Zdivide c d); auto. +assert (H4: Zdivide d c); auto. +apply Zdivide_antisym; auto. +Qed. + + +Theorem Zis_gcd_gcd: forall a b c, 0 <= c -> Zis_gcd a b c -> Zgcd a b = c. +intros a b c H1 H2. +case (Zis_gcd_uniqueness_apart_sign a b c (Zgcd a b)); auto. +apply Zgcd_is_gcd; auto. +case Zle_lt_or_eq with (1 := H1); clear H1; intros H1; subst; auto. +intros H3; subst; contradict H1. +apply Zle_not_lt; generalize (Zgcd_is_pos a b); auto with zarith. +case (Zgcd a b); simpl; auto; intros; discriminate. +Qed. + + +Theorem Zdivide_Zgcd: forall p q r, (p | q) -> (p | r) -> (p | Zgcd q r). +intros p q r H1 H2. +assert (H3: (Zis_gcd q r (Zgcd q r))). +apply Zgcd_is_gcd. +inversion_clear H3; auto. +Qed. + +(************************************** + Properties rel_prime +**************************************) + +Theorem rel_prime_sym: forall a b, rel_prime a b -> rel_prime b a. +intros a b H; auto with zarith. +red; apply Zis_gcd_sym; auto with zarith. +Qed. + +Theorem rel_prime_le_prime: + forall a p, prime p -> 1 <= a < p -> rel_prime a p. +intros a p Hp [H1 H2]. +apply rel_prime_sym; apply prime_rel_prime; auto. +intros [q Hq]; subst a. +case (Zle_or_lt q 0); intros Hl. +absurd (q * p <= 0 * p); auto with zarith. +absurd (1 * p <= q * p); auto with zarith. +Qed. + +Definition rel_prime_dec: + forall a b, ({ rel_prime a b }) + ({ ~ rel_prime a b }). +intros a b; case (Z_eq_dec (Zgcd a b) 1); intros H1. +left; red. +rewrite <- H1; apply Zgcd_is_gcd. +right; contradict H1. +case (Zis_gcd_unique a b (Zgcd a b) 1); auto. +apply Zgcd_is_gcd. +apply Zis_gcd_sym; auto. +intros H2; absurd (0 <= Zgcd a b); auto with zarith. +generalize (Zgcd_is_pos a b); auto with zarith. +Qed. + + +Theorem rel_prime_mod: forall p q, 0 < q -> rel_prime p q -> rel_prime (p mod q) q. +intros p q H H0. +assert (H1: Bezout p q 1). +apply rel_prime_bezout; auto. +inversion_clear H1 as [q1 r1 H2]. +apply bezout_rel_prime. +apply Bezout_intro with q1 (r1 + q1 * (p / q)). +rewrite <- H2. +pattern p at 3; rewrite (Z_div_mod_eq p q); try ring; auto with zarith. +Qed. + +Theorem rel_prime_mod_rev: forall p q, 0 < q -> rel_prime (p mod q) q -> rel_prime p q. +intros p q H H0. +rewrite (Z_div_mod_eq p q); auto with zarith. +red. +apply Zis_gcd_sym; apply Zis_gcd_for_euclid2; auto with zarith. +Qed. + +Theorem rel_prime_div: forall p q r, rel_prime p q -> (r | p) -> rel_prime r q. +intros p q r H (u, H1); subst. +inversion_clear H as [H1 H2 H3]. +red; apply Zis_gcd_intro; try apply Zone_divide. +intros x H4 H5; apply H3; auto. +apply Zdivide_mult_r; auto. +Qed. + +Theorem rel_prime_1: forall n, rel_prime 1 n. +intros n; red; apply Zis_gcd_intro; auto. +exists 1; auto with zarith. +exists n; auto with zarith. +Qed. + +Theorem not_rel_prime_0: forall n, 1 < n -> ~rel_prime 0 n. +intros n H H1; absurd (n = 1 \/ n = -1). +intros [H2 | H2]; subst; contradict H; auto with zarith. +case (Zis_gcd_unique 0 n n 1); auto. +apply Zis_gcd_intro; auto. +exists 0; auto with zarith. +exists 1; auto with zarith. +apply Zis_gcd_sym; auto. +Qed. + + +Theorem rel_prime_Zpower_r: forall i p q, 0 < i -> rel_prime p q -> rel_prime p (q^i). +intros i p q Hi Hpq; generalize Hi; pattern i; apply natlike_ind; auto with zarith; clear i Hi. +intros H; contradict H; auto with zarith. +intros i Hi Rec _; rewrite Zpower_Zsucc; auto. +apply rel_prime_mult; auto. +case Zle_lt_or_eq with (1 := Hi); intros Hi1; subst; auto. +rewrite Zpower_exp_0; apply rel_prime_sym; apply rel_prime_1. +Qed. + + +(************************************** + Properties prime +**************************************) + +Theorem not_prime_0: ~ prime 0. +intros H1; case (prime_divisors _ H1 2); auto with zarith. +Qed. + + +Theorem not_prime_1: ~ prime 1. +intros H1; absurd (1 < 1); auto with zarith. +inversion H1; auto. +Qed. + +Theorem prime2: prime 2. +apply prime_intro; auto with zarith. +intros n [H1 H2]; case Zle_lt_or_eq with ( 1 := H1 ); auto with zarith; + clear H1; intros H1. +contradict H2; auto with zarith. +subst n; red; auto with zarith. +apply Zis_gcd_intro; auto with zarith. +Qed. + +Theorem prime3: prime 3. +apply prime_intro; auto with zarith. +intros n [H1 H2]; case Zle_lt_or_eq with ( 1 := H1 ); auto with zarith; + clear H1; intros H1. +case (Zle_lt_or_eq 2 n); auto with zarith; clear H1; intros H1. +contradict H2; auto with zarith. +subst n; red; auto with zarith. +apply Zis_gcd_intro; auto with zarith. +intros x [q1 Hq1] [q2 Hq2]. +exists (q2 - q1). +apply trans_equal with (3 - 2); auto with zarith. +rewrite Hq1; rewrite Hq2; ring. +subst n; red; auto with zarith. +apply Zis_gcd_intro; auto with zarith. +Qed. + +Theorem prime_le_2: forall p, prime p -> 2 <= p. +intros p Hp; inversion Hp; auto with zarith. +Qed. + +Definition prime_dec_aux: + forall p m, + ({ forall n, 1 < n < m -> rel_prime n p }) + + ({ exists n , 1 < n < m /\ ~ rel_prime n p }). +intros p m. +case (Z_lt_dec 1 m); intros H1. +apply natlike_rec + with + ( P := + fun m => + ({ forall (n : Z), 1 < n < m -> rel_prime n p }) + + ({ exists n : Z , 1 < n < m /\ ~ rel_prime n p }) ); + auto with zarith. +left; intros n [HH1 HH2]; contradict HH2; auto with zarith. +intros x Hx Rec; case Rec. +intros P1; case (rel_prime_dec x p); intros P2. +left; intros n [HH1 HH2]. +case (Zgt_succ_gt_or_eq x n); auto with zarith. +intros HH3; subst x; auto. +case (Z_lt_dec 1 x); intros HH1. +right; exists x; split; auto with zarith. +left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith. +intros tmp; right; case tmp; intros n [HH1 HH2]; exists n; auto with zarith. +left; intros n [HH1 HH2]; contradict H1; auto with zarith. +Defined. + +Theorem not_prime_divide: + forall p, 1 < p -> ~ prime p -> exists n, 1 < n < p /\ (n | p) . +intros p Hp Hp1. +case (prime_dec_aux p p); intros H1. +case Hp1; apply prime_intro; auto. +intros n [Hn1 Hn2]. +case Zle_lt_or_eq with ( 1 := Hn1 ); auto with zarith. +intros H2; subst n; red; apply Zis_gcd_intro; auto with zarith. +case H1; intros n [Hn1 Hn2]. +generalize (Zgcd_is_pos n p); intros Hpos. +case (Zle_lt_or_eq 0 (Zgcd n p)); auto with zarith; intros H3. +case (Zle_lt_or_eq 1 (Zgcd n p)); auto with zarith; intros H4. +exists (Zgcd n p); split; auto. +split; auto. +apply Zle_lt_trans with n; auto with zarith. +generalize (Zgcd_is_gcd n p); intros tmp; inversion_clear tmp as [Hr1 Hr2 Hr3]. +case Hr1; intros q Hq. +case (Zle_or_lt q 0); auto with zarith; intros Ht. +absurd (n <= 0 * Zgcd n p) ; auto with zarith. +pattern n at 1; rewrite Hq; auto with zarith. +apply Zle_trans with (1 * Zgcd n p); auto with zarith. +pattern n at 2; rewrite Hq; auto with zarith. +generalize (Zgcd_is_gcd n p); intros Ht; inversion Ht; auto. +case Hn2; red. +rewrite H4; apply Zgcd_is_gcd. +generalize (Zgcd_is_gcd n p); rewrite <- H3; intros tmp; + inversion_clear tmp as [Hr1 Hr2 Hr3]. +absurd (n = 0); auto with zarith. +case Hr1; auto with zarith. +Defined. + +Definition prime_dec: forall p, ({ prime p }) + ({ ~ prime p }). +intros p; case (Z_lt_dec 1 p); intros H1. +case (prime_dec_aux p p); intros H2. +left; apply prime_intro; auto. +intros n [Hn1 Hn2]; case Zle_lt_or_eq with ( 1 := Hn1 ); auto. +intros HH; subst n. +red; apply Zis_gcd_intro; auto with zarith. +right; intros H3; inversion_clear H3 as [Hp1 Hp2]. +case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith. +right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto. +Defined. + + +Theorem prime_def: + forall p, 1 < p -> (forall n, 1 < n < p -> ~ (n | p)) -> prime p. +intros p H1 H2. +apply prime_intro; auto. +intros n H3. +red; apply Zis_gcd_intro; auto with zarith. +intros x H4 H5. +case (Zle_lt_or_eq 0 (Zabs x)); auto with zarith; intros H6. +case (Zle_lt_or_eq 1 (Zabs x)); auto with zarith; intros H7. +case (Zle_lt_or_eq (Zabs x) p); auto with zarith. +apply Zdivide_le; auto with zarith. +apply Zdivide_Zabs_inv_l; auto. +intros H8; case (H2 (Zabs x)); auto. +apply Zdivide_Zabs_inv_l; auto. +intros H8; subst p; absurd (Zabs x <= n); auto with zarith. +apply Zdivide_le; auto with zarith. +apply Zdivide_Zabs_inv_l; auto. +rewrite H7; pattern (Zabs x); apply Zabs_intro; auto with zarith. +absurd (0%Z = p); auto with zarith. +cut (Zdivide (Zabs x) p). +intros [q Hq]; subst p; rewrite <- H6; auto with zarith. +apply Zdivide_Zabs_inv_l; auto. +Qed. + +Theorem prime_inv_def: forall p n, prime p -> 1 < n < p -> ~ (n | p). +intros p n H1 H2 H3. +absurd (rel_prime n p); auto. +unfold rel_prime; intros H4. +case (Zis_gcd_unique n p n 1); auto with zarith. +apply Zis_gcd_intro; auto with zarith. +inversion H1; auto with zarith. +Qed. + +Theorem square_not_prime: forall a, ~ prime (a * a). +intros a; rewrite (Zabs_square a). +case (Zle_lt_or_eq 0 (Zabs a)); auto with zarith; intros Hza1. +case (Zle_lt_or_eq 1 (Zabs a)); auto with zarith; intros Hza2. +intros Ha; case (prime_inv_def (Zabs a * Zabs a) (Zabs a)); auto. +split; auto. +pattern (Zabs a) at 1; replace (Zabs a) with (1 * Zabs a); auto with zarith. +apply Zmult_lt_compat_r; auto with zarith. +exists (Zabs a); auto. +rewrite <- Hza2; simpl; apply not_prime_1. +rewrite <- Hza1; simpl; apply not_prime_0. +Qed. + +Theorem prime_divide_prime_eq: + forall p1 p2, prime p1 -> prime p2 -> Zdivide p1 p2 -> p1 = p2. +intros p1 p2 Hp1 Hp2 Hp3. +assert (Ha: 1 < p1). +inversion Hp1; auto. +assert (Ha1: 1 < p2). +inversion Hp2; auto. +case (Zle_lt_or_eq p1 p2); auto with zarith. +apply Zdivide_le; auto with zarith. +intros Hp4. +case (prime_inv_def p2 p1); auto with zarith. +Qed. + +Theorem Zdivide_div_prime_le_square: forall x, 1 < x -> ~prime x -> exists p, prime p /\ (p | x) /\ p * p <= x. +intros x Hx; generalize Hx; pattern x; apply Z_lt_induction; auto with zarith. +clear x Hx; intros x Rec H H1. +case (not_prime_divide x); auto. +intros x1 ((H2, H3), H4); case (prime_dec x1); intros H5. +case (Zle_or_lt (x1 * x1) x); intros H6. +exists x1; auto. +case H4; clear H4; intros x2 H4; subst. +assert (Hx2: x2 <= x1). +case (Zle_or_lt x2 x1); auto; intros H8; contradict H6; apply Zle_not_lt. +apply Zmult_le_compat_r; auto with zarith. +case (prime_dec x2); intros H7. +exists x2; repeat (split; auto with zarith). +apply Zmult_le_compat_l; auto with zarith. +apply Zle_trans with 2%Z; try apply prime_le_2; auto with zarith. +case (Zle_or_lt 0 x2); intros H8. +case Zle_lt_or_eq with (1 := H8); auto with zarith; clear H8; intros H8; subst; auto with zarith. +case (Zle_lt_or_eq 1 x2); auto with zarith; clear H8; intros H8; subst; auto with zarith. +case (Rec x2); try split; auto with zarith. +intros x3 (H9, (H10, H11)). +exists x3; repeat (split; auto with zarith). +contradict H; apply Zle_not_lt; auto with zarith. +apply Zle_trans with (0 * x1); auto with zarith. +case (Rec x1); try split; auto with zarith. +intros x3 (H9, (H10, H11)). +exists x3; repeat (split; auto with zarith). +apply Zdivide_trans with x1; auto with zarith. +Qed. + +Theorem prime_div_prime: forall p q, prime p -> prime q -> (p | q) -> p = q. +intros p q H H1 H2; +assert (Hp: 0 < p); try apply Zlt_le_trans with 2; try apply prime_le_2; auto with zarith. +assert (Hq: 0 < q); try apply Zlt_le_trans with 2; try apply prime_le_2; auto with zarith. +case prime_divisors with (2 := H2); auto. +intros H4; contradict Hp; subst; auto with zarith. +intros [H4| [H4 | H4]]; subst; auto. +contradict H; apply not_prime_1. +contradict Hp; auto with zarith. +Qed. + +Theorem prime_div_Zpower_prime: forall n p q, 0 <= n -> prime p -> prime q -> (p | q ^ n) -> p = q. +intros n p q Hp Hq; generalize p q Hq; pattern n; apply natlike_ind; auto; clear n p q Hp Hq. +intros p q Hp Hq; rewrite Zpower_exp_0. +intros (r, H); subst. +case (Zmult_interval p r); auto; try rewrite Zmult_comm. +rewrite <- H; auto with zarith. +apply Zlt_le_trans with 2; try apply prime_le_2; auto with zarith. +rewrite <- H; intros H1 H2; contradict H2; auto with zarith. +intros n1 H Rec p q Hp Hq; try rewrite Zpower_Zsucc; auto with zarith; intros H1. +case prime_mult with (2 := H1); auto. +intros H2; apply prime_div_prime; auto. +Qed. + +Theorem rel_prime_Zpower: forall i j p q, 0 <= i -> 0 <= j -> rel_prime p q -> rel_prime (p^i) (q^j). +intros i j p q Hi; generalize Hi j p q; pattern i; apply natlike_ind; auto with zarith; clear i Hi j p q. +intros _ j p q H H1; rewrite Zpower_exp_0; apply rel_prime_1. +intros n Hn Rec _ j p q Hj Hpq. +rewrite Zpower_Zsucc; auto. +case Zle_lt_or_eq with (1 := Hj); intros Hj1; subst. +apply rel_prime_sym; apply rel_prime_mult; auto. +apply rel_prime_sym; apply rel_prime_Zpower_r; auto with arith. +apply rel_prime_sym; apply Rec; auto. +rewrite Zpower_exp_0; apply rel_prime_sym; apply rel_prime_1. +Qed. + +Theorem prime_induction: forall (P: Z -> Prop), P 0 -> P 1 -> (forall p q, prime p -> P q -> P (p * q)) -> forall p, 0 <= p -> P p. +intros P H H1 H2 p Hp. +generalize Hp; pattern p; apply Z_lt_induction; auto; clear p Hp. +intros p Rec Hp. +case Zle_lt_or_eq with (1 := Hp); clear Hp; intros Hp; subst; auto. +case (Zle_lt_or_eq 1 p); auto with zarith; clear Hp; intros Hp; subst; auto. +case (prime_dec p); intros H3. +rewrite <- (Zmult_1_r p); apply H2; auto. + case (Zdivide_div_prime_le_square p); auto. +intros q (Hq1, ((q2, Hq2), Hq3)); subst. +case (Zmult_interval q q2). +rewrite Zmult_comm; apply Zlt_trans with 1; auto with zarith. +apply Zlt_le_trans with 2; auto with zarith; apply prime_le_2; auto. +intros H4 H5; rewrite Zmult_comm; apply H2; auto. +apply Rec; try split; auto with zarith. +rewrite Zmult_comm; auto. +Qed. + +Theorem div_power_max: forall p q, 1 < p -> 0 < q -> exists n, 0 <= n /\ (p ^n | q) /\ ~(p ^(1 + n) | q). +intros p q H1 H2; generalize H2; pattern q; apply Z_lt_induction; auto with zarith; clear q H2. +intros q Rec H2. +case (Zdivide_dec p q); intros H3. +case (Zdivide_Zdiv_lt_pos p q); auto with zarith; intros H4 H5. +case (Rec (Zdiv q p)); auto with zarith. +intros n (Ha1, (Ha2, Ha3)); exists (n + 1); split; auto with zarith; split. +case Ha2; intros q1 Hq; exists q1. +rewrite Zpower_exp; try rewrite Zpower_exp_1; auto with zarith. +rewrite Zmult_assoc; rewrite <- Hq. +rewrite Zmult_comm; apply Zdivide_Zdiv_eq; auto with zarith. +intros (q1, Hu); case Ha3; exists q1. +apply Zmult_reg_r with p; auto with zarith. +rewrite (Zmult_comm (q / p)); rewrite <- Zdivide_Zdiv_eq; auto with zarith. +apply trans_equal with (1 := Hu); repeat rewrite Zpower_exp; try rewrite Zpower_exp_1; auto with zarith. +ring. +exists 0; repeat split; try rewrite Zpower_exp_1; try rewrite Zpower_exp_0; auto with zarith. +Qed. + +Theorem prime_divide_Zpower_Zdiv: forall m a p i, 0 <= i -> prime p -> (m | a) -> ~(m | (a/p)) -> (p^i | a) -> (p^i | m). +intros m a p i Hi Hp (k, Hk) H (l, Hl); subst. +case (Zle_lt_or_eq 0 i); auto with arith; intros Hi1; subst. +assert (Hp0: 0 < p). +apply Zlt_le_trans with 2; auto with zarith; apply prime_le_2; auto. +case (Zdivide_dec p k); intros H1. +case H1; intros k' H2; subst. +case H; replace (k' * p * m) with ((k' * m) * p); try ring; rewrite Z_div_mult; auto with zarith. +apply Gauss with k. +exists l; rewrite Hl; ring. +apply rel_prime_sym; apply rel_prime_Zpower_r; auto. +apply rel_prime_sym; apply prime_rel_prime; auto. +rewrite Zpower_exp_0; apply Zone_divide. +Qed. + + +Theorem Zdivide_Zpower: forall n m, 0 < n -> (forall p i, prime p -> 0 < i -> (p^i | n) -> (p^i | m)) -> (n | m). +intros n m Hn; generalize m Hn; pattern n; apply prime_induction; auto with zarith; clear n m Hn. +intros m H1; contradict H1; auto with zarith. +intros p q H Rec m H1 H2. +assert (H3: (p | m)). +rewrite <- (Zpower_exp_1 p); apply H2; auto with zarith; rewrite Zpower_exp_1; apply Zdivide_factor_r. +case (Zmult_interval p q); auto. +apply Zlt_le_trans with 2; auto with zarith; apply prime_le_2; auto. +case H3; intros k Hk; subst. +intros Hq Hq1. +rewrite (Zmult_comm k); apply Zmult_divide_compat_l. +apply Rec; auto. +intros p1 i Hp1 Hp2 Hp3. +case (Z_eq_dec p p1); intros Hpp1; subst. +case (H2 p1 (Zsucc i)); auto with zarith. +rewrite Zpower_Zsucc; try apply Zmult_divide_compat_l; auto with zarith. +intros q2 Hq2; exists q2. +apply Zmult_reg_r with p1. +contradict H; subst; apply not_prime_0. +rewrite Hq2; rewrite Zpower_Zsucc; try ring; auto with zarith. +apply Gauss with p. +rewrite Zmult_comm; apply H2; auto. +apply Zdivide_trans with (1:= Hp3). +apply Zdivide_factor_l. +apply rel_prime_sym; apply rel_prime_Zpower_r; auto. +apply prime_rel_prime; auto. +contradict Hpp1; apply prime_divide_prime_eq; auto. +Qed. + +Theorem divide_prime_divide: + forall a n m, 0 < a -> (n | m) -> (a | m) -> + (forall p, prime p -> (p | a) -> ~(n | (m/p))) -> + (a | n). +intros a n m Ha Hnm Ham Hp. +apply Zdivide_Zpower; auto. +intros p i H1 H2 H3. +apply prime_divide_Zpower_Zdiv with m; auto with zarith. +apply Hp; auto; apply Zdivide_trans with (2 := H3); auto. +apply Zpower_divide; auto. +apply Zdivide_trans with (1 := H3); auto. +Qed. + +Theorem prime_div_induction: + forall (P: Z -> Prop) n, + 0 < n -> + (P 1) -> + (forall p i, prime p -> 0 <= i -> (p^i | n) -> P (p^i)) -> + (forall p q, rel_prime p q -> P p -> P q -> P (p * q)) -> + forall m, 0 <= m -> (m | n) -> P m. +intros P n P1 Hn H H1 m Hm. +generalize Hm; pattern m; apply Z_lt_induction; auto; clear m Hm. +intros m Rec Hm H2. +case (prime_dec m); intros Hm1. +rewrite <- Zpower_exp_1; apply H; auto with zarith. +rewrite Zpower_exp_1; auto. +case Zle_lt_or_eq with (1 := Hm); clear Hm; intros Hm; subst. +2: contradict P1; case H2; intros; subst; auto with zarith. +case (Zle_lt_or_eq 1 m); auto with zarith; clear Hm; intros Hm; subst; auto. +case Zdivide_div_prime_le_square with m; auto. +intros p (Hp1, (Hp2, Hp3)). +case (div_power_max p m); auto with zarith. +generalize (prime_le_2 p Hp1); auto with zarith. +intros i (Hi, (Hi1, Hi2)). +case Zle_lt_or_eq with (1 := Hi); clear Hi; intros Hi. +assert (Hpi: 0 < p ^ i). +apply Zpower_lt_0; auto with zarith. +apply Zlt_le_trans with 2; try apply prime_le_2; auto with zarith. +rewrite (Z_div_exact_2 m (p ^ i)); auto with zarith. +apply H1; auto with zarith. +apply rel_prime_sym; apply rel_prime_Zpower_r; auto. +apply rel_prime_sym. +apply prime_rel_prime; auto. +contradict Hi2. +case Hi1; intros; subst. +rewrite Z_div_mult in Hi2; auto with zarith. +case Hi2; intros q0 Hq0; subst. +exists q0; rewrite Zpower_exp; try rewrite Zpower_exp_1; auto with zarith. +apply H; auto with zarith. +apply Zdivide_trans with (1 := Hi1); auto. +apply Rec; auto with zarith. +split; auto with zarith. +apply Zge_le; apply Z_div_ge0; auto with zarith. +apply Z_div_lt; auto with zarith. +apply Zle_ge; apply Zle_trans with p. +apply prime_le_2; auto. +pattern p at 1; rewrite <- Zpower_exp_1; apply Zpower_le_monotone; auto with zarith. +apply Zlt_le_trans with 2; try apply prime_le_2; auto with zarith. +apply Zge_le; apply Z_div_ge0; auto with zarith. +apply Zdivide_trans with (2 := H2); auto. +exists (p ^ i); apply Z_div_exact_2; auto with zarith. +apply Zdivide_mod; auto with zarith. +apply Zdivide_mod; auto with zarith. +case Hi2; rewrite <- Hi; rewrite Zplus_0_r; rewrite Zpower_exp_1; auto. +Qed. + +(************************************** + A tail recursive way of compute a^n +**************************************) + +Fixpoint Zpower_tr_aux (z1 z2: Z) (n: nat) {struct n}: Z := + match n with O => z1 | (S n1) => Zpower_tr_aux (z2 * z1) z2 n1 end. + +Theorem Zpower_tr_aux_correct: +forall z1 z2 n p, z1 = Zpower_nat z2 p -> Zpower_tr_aux z1 z2 n = Zpower_nat z2 (p + n). +intros z1 z2 n; generalize z1; elim n; clear z1 n; simpl; auto. +intros z1 p; rewrite plus_0_r; auto. +intros n1 Rec z1 p H1. +rewrite Rec with (p:= S p). +rewrite <- plus_n_Sm; simpl; auto. +pattern z2 at 1; replace z2 with (Zpower_nat z2 1). +rewrite H1; rewrite <- Zpower_nat_is_exp; simpl; auto. +unfold Zpower_nat; simpl; rewrite Zmult_1_r; auto. +Qed. + +Definition Zpower_nat_tr := Zpower_tr_aux 1. + +Theorem Zpower_nat_tr_correct: +forall z n, Zpower_nat_tr z n = Zpower_nat z n. +intros z n; unfold Zpower_nat_tr. +rewrite Zpower_tr_aux_correct with (p := 0%nat); auto. +Qed. + +(************************************** + Definition of Zsquare +**************************************) + +Fixpoint Psquare (p: positive): positive := +match p with + xH => xH +| xO p => xO (xO (Psquare p)) +| xI p => xI (xO (Pplus (Psquare p) p)) +end. + +Theorem Psquare_correct: (forall p, Psquare p = p * p)%positive. +intros p; elim p; simpl; auto. +intros p1 Rec; rewrite Rec. +eq_tac. +apply trans_equal with (xO p1 + xO (p1 * p1) )%positive; auto. +rewrite (Pplus_comm (xO p1)); auto. +rewrite Pmult_xI_permute_r; rewrite Pplus_assoc. +eq_tac; auto. +apply sym_equal; apply Pplus_diag. +intros p1 Rec; rewrite Rec; simpl; auto. +eq_tac; auto. +apply sym_equal; apply Pmult_xO_permute_r. +Qed. + +Definition Zsquare p := +match p with Z0 => Z0 | Zpos p => Zpos (Psquare p) | Zneg p => Zpos (Psquare p) end. + +Theorem Zsquare_correct: forall p, Zsquare p = p * p. +intro p; case p; simpl; auto; intros p1; rewrite Psquare_correct; auto. +Qed. + +(************************************** + Some properties of Zpower +**************************************) + +Theorem prime_power_2: forall x n, 0 <= n -> prime x -> (x | 2 ^ n) -> x = 2. +intros x n H Hx; pattern n; apply natlike_ind; auto; clear n H. +rewrite Zpower_exp_0. +intros H1; absurd (x <= 1). +apply Zlt_not_le; apply Zlt_le_trans with 2%Z; auto with zarith. +apply prime_le_2; auto. +apply Zdivide_le; auto with zarith. +apply Zle_trans with 2%Z; try apply prime_le_2; auto with zarith. +intros n1 H H1. +unfold Zsucc; rewrite Zpower_exp; try rewrite Zpower_exp_1; auto with zarith. +intros H2; case prime_mult with (2 := H2); auto. +intros H3; case (Zle_lt_or_eq x 2); auto. +apply Zdivide_le; auto with zarith. +apply Zle_trans with 2%Z; try apply prime_le_2; auto with zarith. +intros H4; contradict H4; apply Zle_not_lt. +apply prime_le_2; auto with zarith. +Qed. + +Theorem Zdivide_power_2: forall x n, 0 <= n -> 0 <= x -> (x | 2 ^ n) -> exists q, x = 2 ^ q. +intros x n Hn H; generalize n H Hn; pattern x; apply Z_lt_induction; auto; clear x n H Hn. +intros x Rec n H Hn H1. +case Zle_lt_or_eq with (1 := H); auto; clear H; intros H; subst. +case (Zle_lt_or_eq 1 x); auto with zarith; clear H; intros H; subst. +case (prime_dec x); intros H2. +exists 1; simpl; apply prime_power_2 with n; auto. +case not_prime_divide with (2 := H2); auto. +intros p1 ((H3, H4), (q1, Hq1)); subst. +case (Rec p1) with n; auto with zarith. +apply Zdivide_trans with (2 := H1); exists q1; auto with zarith. +intros r1 Hr1. +case (Rec q1) with n; auto with zarith. +case (Zle_lt_or_eq 0 q1). +apply Zmult_le_0_reg_r with p1; auto with zarith. +split; auto with zarith. +pattern q1 at 1; replace q1 with (q1 * 1); auto with zarith. +apply Zmult_lt_compat_l; auto with zarith. +intros H5; subst; contradict H; auto with zarith. +apply Zmult_le_0_reg_r with p1; auto with zarith. +apply Zdivide_trans with (2 := H1); exists p1; auto with zarith. +intros r2 Hr2; exists (r2 + r1); subst. +apply sym_equal; apply Zpower_exp. +generalize H; case r2; simpl; auto with zarith. +intros; red; simpl; intros; discriminate. +generalize H; case r1; simpl; auto with zarith. +intros; red; simpl; intros; discriminate. +exists 0; simpl; auto. +case H1; intros q1; try rewrite Zmult_0_r; intros H2. +absurd (0 < 0); auto with zarith. +pattern 0 at 2; rewrite <- H2; auto with zarith. +apply Zpower_lt_0; auto with zarith. +Qed. + + +(************************************** + Some properties of Zodd and Zeven +**************************************) + +Theorem Zeven_ex: forall p, Zeven p -> exists q, p = 2 * q. +intros p; case p; simpl; auto. +intros _; exists 0; auto. +intros p1; case p1; try ((intros H; case H; fail) || intros z H; case H; fail). +intros p2 _; exists (Zpos p2); auto. +intros p1; case p1; try ((intros H; case H; fail) || intros z H; case H; fail). +intros p2 _; exists (Zneg p2); auto. +Qed. + +Theorem Zodd_ex: forall p, Zodd p -> exists q, p = 2 * q + 1. +intros p HH; case (Zle_or_lt 0 p); intros HH1. +exists (Zdiv2 p); apply Zodd_div2; auto with zarith. +exists ((Zdiv2 p) - 1); pattern p at 1; rewrite Zodd_div2_neg; auto with zarith. +Qed. + +Theorem Zeven_2p: forall p, Zeven (2 * p). +intros p; case p; simpl; auto. +Qed. + +Theorem Zodd_2p_plus_1: forall p, Zodd (2 * p + 1). +intros p; case p; simpl; auto. +intros p1; case p1; simpl; auto. +Qed. + +Theorem Zeven_plus_Zodd_Zodd: forall z1 z2, Zeven z1 -> Zodd z2 -> Zodd (z1 + z2). +intros z1 z2 HH1 HH2; case Zeven_ex with (1 := HH1); intros x HH3; try rewrite HH3; auto. +case Zodd_ex with (1 := HH2); intros y HH4; try rewrite HH4; auto. +replace (2 * x + (2 * y + 1)) with (2 * (x + y) + 1); try apply Zodd_2p_plus_1; auto with zarith. +Qed. + +Theorem Zeven_plus_Zeven_Zeven: forall z1 z2, Zeven z1 -> Zeven z2 -> Zeven (z1 + z2). +intros z1 z2 HH1 HH2; case Zeven_ex with (1 := HH1); intros x HH3; try rewrite HH3; auto. +case Zeven_ex with (1 := HH2); intros y HH4; try rewrite HH4; auto. +replace (2 * x + 2 * y) with (2 * (x + y)); try apply Zeven_2p; auto with zarith. +Qed. + +Theorem Zodd_plus_Zeven_Zodd: forall z1 z2, Zodd z1 -> Zeven z2 -> Zodd (z1 + z2). +intros z1 z2 HH1 HH2; rewrite Zplus_comm; apply Zeven_plus_Zodd_Zodd; auto. +Qed. + +Theorem Zodd_plus_Zodd_Zeven: forall z1 z2, Zodd z1 -> Zodd z2 -> Zeven (z1 + z2). +intros z1 z2 HH1 HH2; case Zodd_ex with (1 := HH1); intros x HH3; try rewrite HH3; auto. +case Zodd_ex with (1 := HH2); intros y HH4; try rewrite HH4; auto. +replace ((2 * x + 1) + (2 * y + 1)) with (2 * (x + y + 1)); try apply Zeven_2p; try ring. +Qed. + +Theorem Zeven_mult_Zeven_l: forall z1 z2, Zeven z1 -> Zeven (z1 * z2). +intros z1 z2 HH1; case Zeven_ex with (1 := HH1); intros x HH3; try rewrite HH3; auto. +replace (2 * x * z2) with (2 * (x * z2)); try apply Zeven_2p; auto with zarith. +Qed. + +Theorem Zeven_mult_Zeven_r: forall z1 z2, Zeven z2 -> Zeven (z1 * z2). +intros z1 z2 HH1; case Zeven_ex with (1 := HH1); intros x HH3; try rewrite HH3; auto. +replace (z1 * (2 * x)) with (2 * (x * z1)); try apply Zeven_2p; try ring. +Qed. + +Theorem Zodd_mult_Zodd_Zodd: forall z1 z2, Zodd z1 -> Zodd z2 -> Zodd (z1 * z2). +intros z1 z2 HH1 HH2; case Zodd_ex with (1 := HH1); intros x HH3; try rewrite HH3; auto. +case Zodd_ex with (1 := HH2); intros y HH4; try rewrite HH4; auto. +replace ((2 * x + 1) * (2 * y + 1)) with (2 * (2 * x * y + x + y) + 1); try apply Zodd_2p_plus_1; try ring. +Qed. + +Definition Zmult_lt_0_compat := Zmult_lt_O_compat. + +Hint Rewrite Zmult_1_r Zmult_0_r Zmult_1_l Zmult_0_l Zplus_0_l Zplus_0_r Zminus_0_r: rm10. +Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l Zmult_minus_distr_r Zmult_minus_distr_l: distr. + +Theorem Zmult_lt_compat_bis: + forall n m p q : Z, 0 <= n < p -> 0 <= m < q -> n * m < p * q. +intros n m p q (H1, H2) (H3,H4). +case Zle_lt_or_eq with (1 := H1); intros H5; auto with zarith. +case Zle_lt_or_eq with (1 := H3); intros H6; auto with zarith. +apply Zlt_trans with (n * q). +apply Zmult_lt_compat_l; auto. +apply Zmult_lt_compat_r; auto with zarith. +rewrite <- H6; autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith. +rewrite <- H5; autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith. +Qed. + + +Theorem nat_of_P_xO: + forall p, nat_of_P (xO p) = (2 * nat_of_P p)%nat. +intros p; unfold nat_of_P; simpl; rewrite Pmult_nat_2_mult_2_permute; auto with arith. +Qed. + +Theorem nat_of_P_xI: + forall p, nat_of_P (xI p) = (2 * nat_of_P p + 1)%nat. +intros p; unfold nat_of_P; simpl; rewrite Pmult_nat_2_mult_2_permute; auto with arith. +ring. +Qed. + +Theorem nat_of_P_xH: nat_of_P xH = 1%nat. +trivial. +Qed. + +Hint Rewrite + nat_of_P_xO nat_of_P_xI nat_of_P_xH + nat_of_P_succ_morphism + nat_of_P_plus_carry_morphism + nat_of_P_plus_morphism + nat_of_P_mult_morphism + nat_of_P_minus_morphism: pos_morph. + +Ltac pos_tac := + match goal with |- ?X = ?Y => + assert (tmp: Zpos X = Zpos Y); + [idtac; repeat rewrite Zpos_eq_Z_of_nat_o_nat_of_P; eq_tac | injection tmp; auto] + end; autorewrite with pos_morph. + + diff --git a/theories/Ints/Z/ZDivModAux.v b/theories/Ints/Z/ZDivModAux.v new file mode 100644 index 000000000..d07b92d80 --- /dev/null +++ b/theories/Ints/Z/ZDivModAux.v @@ -0,0 +1,452 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + ZDivModAux.v + + Auxillary functions & Theorems for Zdiv and Zmod + **********************************************************************) + +Require Export ZArith. +Require Export Znumtheory. +Require Export Tactic. +Require Import ZAux. +Require Import ZPowerAux. + +Open Local Scope Z_scope. + +Hint Extern 2 (Zle _ _) => + (match goal with + |- Zpos _ <= Zpos _ => exact (refl_equal _) + | H: _ <= ?p |- _ <= ?p => apply Zle_trans with (2 := H) + | H: _ < ?p |- _ <= ?p => + apply Zlt_le_weak; apply Zle_lt_trans with (2 := H) + end). + +Hint Extern 2 (Zlt _ _) => + (match goal with + |- Zpos _ < Zpos _ => exact (refl_equal _) +| H: _ <= ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H) +| H: _ < ?p |- _ <= ?p => apply Zle_lt_trans with (2 := H) + end). + +Hint Resolve Zlt_gt Zle_ge: zarith. + +(************************************** + Properties Zmod +**************************************) + + Theorem Zmod_mult: + forall a b n, 0 < n -> (a * b) mod n = ((a mod n) * (b mod n)) mod n. + Proof. + intros a b n H. + pattern a at 1; rewrite (Z_div_mod_eq a n); auto with zarith. + pattern b at 1; rewrite (Z_div_mod_eq b n); auto with zarith. + replace ((n * (a / n) + a mod n) * (n * (b / n) + b mod n)) with + ((a mod n) * (b mod n) + + (((n*(a/n)) * (b/n) + (b mod n)*(a / n)) + (a mod n) * (b / n)) * n); + auto with zarith. + apply Z_mod_plus; auto with zarith. + ring. + Qed. + + Theorem Zmod_plus: + forall a b n, 0 < n -> (a + b) mod n = (a mod n + b mod n) mod n. + Proof. + intros a b n H. + pattern a at 1; rewrite (Z_div_mod_eq a n); auto with zarith. + pattern b at 1; rewrite (Z_div_mod_eq b n); auto with zarith. + replace ((n * (a / n) + a mod n) + (n * (b / n) + b mod n)) + with ((a mod n + b mod n) + (a / n + b / n) * n); auto with zarith. + apply Z_mod_plus; auto with zarith. + ring. + Qed. + + Theorem Zmod_mod: forall a n, 0 < n -> (a mod n) mod n = a mod n. + Proof. + intros a n H. + pattern a at 2; rewrite (Z_div_mod_eq a n); auto with zarith. + rewrite Zplus_comm; rewrite Zmult_comm. + apply sym_equal; apply Z_mod_plus; auto with zarith. + Qed. + + Theorem Zmod_def_small: forall a n, 0 <= a < n -> a mod n = a. + Proof. + intros a n [H1 H2]; unfold Zmod. + generalize (Z_div_mod a n); case (Zdiv_eucl a n). + intros q r H3; case H3; clear H3; auto with zarith. + intros H4 [H5 H6]. + case (Zle_or_lt q (- 1)); intros H7. + contradict H1; apply Zlt_not_le. + subst a. + apply Zle_lt_trans with (n * - 1 + r); auto with zarith. + case (Zle_lt_or_eq 0 q); auto with zarith; intros H8. + contradict H2; apply Zle_not_lt. + apply Zle_trans with (n * 1 + r); auto with zarith. + rewrite H4; auto with zarith. + subst a; subst q; auto with zarith. + Qed. + + Theorem Zmod_minus: + forall a b n, 0 < n -> (a - b) mod n = (a mod n - b mod n) mod n. + Proof. + intros a b n H; replace (a - b) with (a + (-1) * b); auto with zarith. + replace (a mod n - b mod n) with (a mod n + (-1)*(b mod n));auto with zarith. + rewrite Zmod_plus; auto with zarith. + rewrite Zmod_mult; auto with zarith. + rewrite (fun x y => Zmod_plus x ((-1) * y)); auto with zarith. + rewrite Zmod_mult; auto with zarith. + rewrite (fun x => Zmod_mult x (b mod n)); auto with zarith. + repeat rewrite Zmod_mod; auto. + Qed. + + Theorem Zmod_le: forall a n, 0 < n -> 0 <= a -> (Zmod a n) <= a. + Proof. + intros a n H1 H2; case (Zle_or_lt n a); intros H3. + case (Z_mod_lt a n); auto with zarith. + rewrite Zmod_def_small; auto with zarith. + Qed. + + Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. + Proof. + intros a b H H1;case (Z_mod_lt a b);auto with zarith;intros H2 H3;split;auto. + case (Zle_or_lt b a); intros H4; auto with zarith. + rewrite Zmod_def_small; auto with zarith. + Qed. + + +(************************************** + Properties of Zdivide +**************************************) + + Theorem Zdiv_pos: forall a b, 0 < b -> 0 <= a -> 0 <= a / b. + Proof. + intros; apply Zge_le; apply Z_div_ge0; auto with zarith. + Qed. + Hint Resolve Zdiv_pos: zarith. + + Theorem Zdiv_mult_le: + forall a b c, 0 <= a -> 0 < b -> 0 <= c -> c * (a/b) <= (c * a)/ b. + Proof. + intros a b c H1 H2 H3. + case (Z_mod_lt a b); auto with zarith; intros Hu1 Hu2. + case (Z_mod_lt c b); auto with zarith; intros Hv1 Hv2. + apply Zmult_le_reg_r with b; auto with zarith. + rewrite <- Zmult_assoc. + replace (a / b * b) with (a - a mod b). + replace (c * a / b * b) with (c * a - (c * a) mod b). + rewrite Zmult_minus_distr_l. + unfold Zminus; apply Zplus_le_compat_l. + match goal with |- - ? X <= -?Y => assert (Y <= X); auto with zarith end. + apply Zle_trans with ((c mod b) * (a mod b)); auto with zarith. + rewrite Zmod_mult; case (Zmod_le_first ((c mod b) * (a mod b)) b); + auto with zarith. + apply Zmult_le_compat_r; auto with zarith. + case (Zmod_le_first c b); auto. + pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) b); try ring; + auto with zarith. + pattern a at 1; rewrite (Z_div_mod_eq a b); try ring; auto with zarith. + Qed. + + Theorem Zdiv_unique: + forall n d q r, 0 < d -> ( 0 <= r < d ) -> n = d * q + r -> q = n / d. + Proof. + intros n d q r H H0 H1. + assert (H2: n = d * (n / d) + n mod d). + apply Z_div_mod_eq; auto with zarith. + assert (H3: 0 <= n mod d < d ). + apply Z_mod_lt; auto with zarith. + case (Ztrichotomy q (n / d)); auto. + intros H4. + absurd (n < n); auto with zarith. + pattern n at 1; rewrite H1; rewrite H2. + apply Zlt_le_trans with (d * (q + 1)); auto with zarith. + rewrite Zmult_plus_distr_r; auto with zarith. + apply Zle_trans with (d * (n / d)); auto with zarith. + intros tmp; case tmp; auto; intros H4; clear tmp. + absurd (n < n); auto with zarith. + pattern n at 2; rewrite H1; rewrite H2. + apply Zlt_le_trans with (d * (n / d + 1)); auto with zarith. + rewrite Zmult_plus_distr_r; auto with zarith. + apply Zle_trans with (d * q); auto with zarith. + Qed. + + Theorem Zmod_unique: + forall n d q r, 0 < d -> ( 0 <= r < d ) -> n = d * q + r -> r = n mod d. + Proof. + intros n d q r H H0 H1. + assert (H2: n = d * (n / d) + n mod d). + apply Z_div_mod_eq; auto with zarith. + rewrite (Zdiv_unique n d q r) in H1; auto. + apply (Zplus_reg_l (d * (n / d))); auto with zarith. + Qed. + + Theorem Zmod_Zmult_compat_l: forall a b c, + 0 < b -> 0 < c -> c * a mod (c * b) = c * (a mod b). + Proof. + intros a b c H2 H3. + pattern a at 1; rewrite (Z_div_mod_eq a b); auto with zarith. + rewrite Zplus_comm; rewrite Zmult_plus_distr_r. + rewrite Zmult_assoc; rewrite (Zmult_comm (c * b)). + rewrite Z_mod_plus; auto with zarith. + apply Zmod_def_small; split; auto with zarith. + apply Zmult_le_0_compat; auto with zarith. + destruct (Z_mod_lt a b);auto with zarith. + apply Zmult_lt_compat_l; auto with zarith. + destruct (Z_mod_lt a b);auto with zarith. + Qed. + + Theorem Zdiv_Zmult_compat_l: + forall a b c, 0 <= a -> 0 < b -> 0 < c -> c * a / (c * b) = a / b. + Proof. + intros a b c H1 H2 H3; case (Z_mod_lt a b); auto with zarith; intros H4 H5. + apply Zdiv_unique with (a mod b); auto with zarith. + apply Zmult_reg_l with c; auto with zarith. + rewrite Zmult_plus_distr_r; rewrite <- Zmod_Zmult_compat_l; auto with zarith. + rewrite Zmult_assoc; apply Z_div_mod_eq; auto with zarith. + Qed. + + Theorem Zdiv_0: forall a, 0 < a -> 0 / a = 0. + Proof. + intros a H;apply sym_equal;apply Zdiv_unique with (r := 0); auto with zarith. + Qed. + + Theorem Zdiv_le_upper_bound: + forall a b q, 0 <= a -> 0 < b -> a <= q * b -> a / b <= q. + Proof. + intros a b q H1 H2 H3. + apply Zmult_le_reg_r with b; auto with zarith. + apply Zle_trans with (2 := H3). + pattern a at 2; rewrite (Z_div_mod_eq a b); auto with zarith. + rewrite (Zmult_comm b); case (Z_mod_lt a b); auto with zarith. + Qed. + + Theorem Zdiv_lt_upper_bound: + forall a b q, 0 <= a -> 0 < b -> a < q * b -> a / b < q. + Proof. + intros a b q H1 H2 H3. + apply Zmult_lt_reg_r with b; auto with zarith. + apply Zle_lt_trans with (2 := H3). + pattern a at 2; rewrite (Z_div_mod_eq a b); auto with zarith. + rewrite (Zmult_comm b); case (Z_mod_lt a b); auto with zarith. + Qed. + + Theorem Zdiv_le_lower_bound: + forall a b q, 0 <= a -> 0 < b -> q * b <= a -> q <= a / b. + Proof. + intros a b q H1 H2 H3. + assert (q < a / b + 1); auto with zarith. + apply Zmult_lt_reg_r with b; auto with zarith. + apply Zle_lt_trans with (1 := H3). + pattern a at 1; rewrite (Z_div_mod_eq a b); auto with zarith. + rewrite Zmult_plus_distr_l; rewrite (Zmult_comm b); case (Z_mod_lt a b); + auto with zarith. + Qed. + + Theorem Zmult_mod_distr_l: + forall a b c, 0 < a -> 0 < c -> (a * b) mod (a * c) = a * (b mod c). + Proof. + intros a b c H Hc. + apply sym_equal; apply Zmod_unique with (b / c); auto with zarith. + apply Zmult_lt_0_compat; auto. + case (Z_mod_lt b c); auto with zarith; intros; split; auto with zarith. + apply Zmult_lt_compat_l; auto. + rewrite <- Zmult_assoc; rewrite <- Zmult_plus_distr_r. + rewrite <- Z_div_mod_eq; auto with zarith. + Qed. + + + Theorem Zmod_distr: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> + (2 ^a * r + t) mod (2 ^ b) = (2 ^a * r) mod (2 ^ b) + t. + Proof. + intros a b r t (H1, H2) H3 (H4, H5). + assert (t < 2 ^ b). + apply Zlt_le_trans with (1:= H5); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + rewrite Zmod_plus; auto with zarith. + rewrite Zmod_def_small with (a := t); auto with zarith. + apply Zmod_def_small; auto with zarith. + split; auto with zarith. + assert (0 <= 2 ^a * r); auto with zarith. + apply Zplus_le_0_compat; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + pattern (2 ^ b) at 2; replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); + try ring. + apply Zplus_le_lt_compat; auto with zarith. + replace b with ((b - a) + a); try ring. + rewrite Zpower_exp; auto with zarith. + pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); + try rewrite <- Zmult_minus_distr_r. + rewrite (Zmult_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; + auto with zarith. + rewrite (Zmult_comm (2 ^a)); apply Zmult_le_compat_r; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + Qed. + + Theorem Zmult_mod_distr_r: + forall a b c : Z, 0 < a -> 0 < c -> (b * a) mod (c * a) = (b mod c) * a. + Proof. + intros; repeat rewrite (fun x => (Zmult_comm x a)). + apply Zmult_mod_distr_l; auto. + Qed. + + Theorem Z_div_plus_l: forall a b c : Z, 0 < b -> (a * b + c) / b = a + c / b. + Proof. + intros a b c H; rewrite Zplus_comm; rewrite Z_div_plus; + try apply Zplus_comm; auto with zarith. + Qed. + + Theorem Zmod_shift_r: + forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> + (r * 2 ^a + t) mod (2 ^ b) = (r * 2 ^a) mod (2 ^ b) + t. + Proof. + intros a b r t (H1, H2) H3 (H4, H5). + assert (t < 2 ^ b). + apply Zlt_le_trans with (1:= H5); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + rewrite Zmod_plus; auto with zarith. + rewrite Zmod_def_small with (a := t); auto with zarith. + apply Zmod_def_small; auto with zarith. + split; auto with zarith. + assert (0 <= 2 ^a * r); auto with zarith. + apply Zplus_le_0_compat; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring. + apply Zplus_le_lt_compat; auto with zarith. + replace b with ((b - a) + a); try ring. + rewrite Zpower_exp; auto with zarith. + pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); + try rewrite <- Zmult_minus_distr_r. + repeat rewrite (fun x => Zmult_comm x (2 ^ a)); rewrite Zmult_mod_distr_l; + auto with zarith. + apply Zmult_le_compat_l; auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + Qed. + + Theorem Zdiv_lt_0: forall a b, 0 <= a < b -> a / b = 0. + intros a b H; apply sym_equal; apply Zdiv_unique with a; auto with zarith. + Qed. + + Theorem Zmod_mult_0: forall a b, 0 < b -> (a * b) mod b = 0. + Proof. + intros a b H; rewrite <- (Zplus_0_l (a * b)); rewrite Z_mod_plus; + auto with zarith. + Qed. + + Theorem Zdiv_shift_r: + forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> + (r * 2 ^a + t) / (2 ^ b) = (r * 2 ^a) / (2 ^ b). + Proof. + intros a b r t (H1, H2) H3 (H4, H5). + assert (Eq: t < 2 ^ b); auto with zarith. + apply Zlt_le_trans with (1 := H5); auto with zarith. + apply Zpower_le_monotone; auto with zarith. + pattern (r * 2 ^ a) at 1; rewrite Z_div_mod_eq with (b := 2 ^ b); + auto with zarith. + rewrite <- Zplus_assoc. + rewrite <- Zmod_shift_r; auto with zarith. + rewrite (Zmult_comm (2 ^ b)); rewrite Z_div_plus_l; auto with zarith. + rewrite (fun x y => @Zdiv_lt_0 (x mod y)); auto with zarith. + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + auto with zarith. + Qed. + + + Theorem Zpos_minus: + forall a b, Zpos a < Zpos b -> Zpos (b- a) = Zpos b - Zpos a. + Proof. + intros a b H. + repeat rewrite Zpos_eq_Z_of_nat_o_nat_of_P; autorewrite with pos_morph; + auto with zarith. + rewrite inj_minus1; auto with zarith. + match goal with |- (?X <= ?Y)%nat => + case (le_or_lt X Y); auto; intro tmp; absurd (Z_of_nat X < Z_of_nat Y); + try apply Zle_not_lt; auto with zarith + end. + repeat rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto with zarith. + generalize (Zlt_gt _ _ H); auto. + Qed. + + Theorem Zdiv_Zmult_compat_r: + forall a b c : Z, 0 <= a -> 0 < b -> 0 < c -> a * c / (b * c) = a / b. + Proof. + intros a b c H H1 H2; repeat rewrite (fun x => Zmult_comm x c); + apply Zdiv_Zmult_compat_l; auto. + Qed. + + + Lemma shift_unshift_mod : forall n p a, + 0 <= a < 2^n -> + 0 < p < n -> + a * 2^p = a / 2^(n - p) * 2^n + (a*2^p) mod 2^n. + Proof. + intros n p a H1 H2. + pattern (a*2^p) at 1;replace (a*2^p) with + (a*2^p/2^n * 2^n + a*2^p mod 2^n). + 2:symmetry;rewrite (Zmult_comm (a*2^p/2^n));apply Z_div_mod_eq. + replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial. + replace (2^n) with (2^(n-p)*2^p). + symmetry;apply Zdiv_Zmult_compat_r. + destruct H1;trivial. + apply Zpower_lt_0;auto with zarith. + apply Zpower_lt_0;auto with zarith. + rewrite <- Zpower_exp. + replace (n-p+p) with n;trivial. ring. + omega. omega. + apply Zlt_gt. apply Zpower_lt_0;auto with zarith. + Qed. + + Lemma Zdiv_Zdiv : forall a b c, 0 < b -> 0 < c -> (a/b)/c = a / (b*c). + Proof. + intros a b c H H0. + pattern a at 2;rewrite (Z_div_mod_eq a b);auto with zarith. + pattern (a/b) at 2;rewrite (Z_div_mod_eq (a/b) c);auto with zarith. + replace (b * (c * (a / b / c) + (a / b) mod c) + a mod b) with + ((a / b / c)*(b * c) + (b * ((a / b) mod c) + a mod b));try ring. + rewrite Z_div_plus_l;auto with zarith. + rewrite (Zdiv_lt_0 (b * ((a / b) mod c) + a mod b)). + ring. + split. + apply Zplus_le_0_compat;auto with zarith. + apply Zmult_le_0_compat;auto with zarith. + destruct (Z_mod_lt (a/b) c);auto with zarith. + destruct (Z_mod_lt a b);auto with zarith. + apply Zle_lt_trans with (b * ((a / b) mod c) + (b-1)). + destruct (Z_mod_lt a b);auto with zarith. + apply Zle_lt_trans with (b * (c-1) + (b - 1)). + apply Zplus_le_compat;auto with zarith. + destruct (Z_mod_lt (a/b) c);auto with zarith. + replace (b * (c - 1) + (b - 1)) with (b*c-1);try ring;auto with zarith. + apply Zmult_lt_0_compat;auto with zarith. + Qed. + + Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. + Proof. + intros p x Hle;destruct (Z_le_gt_dec 0 p). + apply Zdiv_le_lower_bound;auto with zarith. + replace (2^p) with 0. + destruct x;compute;intro;discriminate. + destruct p;trivial;discriminate z. + Qed. + + Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. + Proof. + intros p x y H;destruct (Z_le_gt_dec 0 p). + apply Zdiv_lt_upper_bound;auto with zarith. + apply Zlt_le_trans with y;auto with zarith. + rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. + assert (0 < 2^p);auto with zarith. + replace (2^p) with 0. + destruct x;change (0<y);auto with zarith. + destruct p;trivial;discriminate z. + Qed. + diff --git a/theories/Ints/Z/ZPowerAux.v b/theories/Ints/Z/ZPowerAux.v new file mode 100644 index 000000000..b56b52d49 --- /dev/null +++ b/theories/Ints/Z/ZPowerAux.v @@ -0,0 +1,183 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(********************************************************************** + + + ZPowerAux.v Auxillary functions & Theorems for Zpower + **********************************************************************) + +Require Export ZArith. +Require Export Znumtheory. +Require Export Tactic. + +Open Local Scope Z_scope. + +Hint Extern 2 (Zle _ _) => + (match goal with + |- Zpos _ <= Zpos _ => exact (refl_equal _) +| H: _ <= ?p |- _ <= ?p => apply Zle_trans with (2 := H) +| H: _ < ?p |- _ <= ?p => apply Zlt_le_weak; apply Zle_lt_trans with (2 := H) + end). + +Hint Extern 2 (Zlt _ _) => + (match goal with + |- Zpos _ < Zpos _ => exact (refl_equal _) +| H: _ <= ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H) +| H: _ < ?p |- _ <= ?p => apply Zle_lt_trans with (2 := H) + end). + +Hint Resolve Zlt_gt Zle_ge: zarith. + +(************************************** + Properties Zpower +**************************************) + +Theorem Zpower_1: forall a, 0 <= a -> 1 ^ a = 1. +intros a Ha; pattern a; apply natlike_ind; auto with zarith. +intros x Hx Hx1; unfold Zsucc. +rewrite Zpower_exp; auto with zarith. +rewrite Hx1; simpl; auto. +Qed. + +Theorem Zpower_exp_0: forall a, a ^ 0 = 1. +simpl; unfold Zpower_pos; simpl; auto with zarith. +Qed. + +Theorem Zpower_exp_1: forall a, a ^ 1 = a. +simpl; unfold Zpower_pos; simpl; auto with zarith. +Qed. + +Theorem Zpower_Zabs: forall a b, Zabs (a ^ b) = (Zabs a) ^ b. +intros a b; case (Zle_or_lt 0 b). +intros Hb; pattern b; apply natlike_ind; auto with zarith. +intros x Hx Hx1; unfold Zsucc. +(repeat rewrite Zpower_exp); auto with zarith. +rewrite Zabs_Zmult; rewrite Hx1. +eq_tac; auto. +replace (a ^ 1) with a; auto. +simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto. +simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto. +case b; simpl; auto with zarith. +intros p Hp; discriminate. +Qed. + +Theorem Zpower_Zsucc: forall p n, 0 <= n -> p ^Zsucc n = p * p ^ n. +intros p n H. +unfold Zsucc; rewrite Zpower_exp; auto with zarith. +rewrite Zpower_exp_1; apply Zmult_comm. +Qed. + +Theorem Zpower_mult: forall p q r, 0 <= q -> 0 <= r -> p ^ (q * r) = (p ^ q) ^ + r. +intros p q r H1 H2; generalize H2; pattern r; apply natlike_ind; auto. +intros H3; rewrite Zmult_0_r; repeat rewrite Zpower_exp_0; auto. +intros r1 H3 H4 H5. +unfold Zsucc; rewrite Zpower_exp; auto with zarith. +rewrite <- H4; try rewrite Zpower_exp_1; try rewrite <- Zpower_exp; try eq_tac; +auto with zarith. +ring. +Qed. + +Theorem Zpower_lt_0: forall a b: Z, 0 < a -> 0 <= b-> 0 < a ^b. +intros a b; case b; auto with zarith. +simpl; intros; auto with zarith. +2: intros p H H1; case H1; auto. +intros p H1 H; generalize H; pattern (Zpos p); apply natlike_ind; auto. +intros; case a; compute; auto. +intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith. +apply Zmult_lt_O_compat; auto with zarith. +generalize H1; case a; compute; intros; auto; discriminate. +Qed. + +Theorem Zpower_le_monotone: forall a b c: Z, 0 < a -> 0 <= b <= c -> a ^ b <= a ^ c. +intros a b c H (H1, H2). +rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith. +rewrite Zpower_exp; auto with zarith. +apply Zmult_le_compat_l; auto with zarith. +assert (0 < a ^ (c - b)); auto with zarith. +apply Zpower_lt_0; auto with zarith. +apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith. +Qed. + + +Theorem Zpower_le_0: forall a b: Z, 0 <= a -> 0 <= a ^b. +intros a b; case b; auto with zarith. +simpl; auto with zarith. +intros p H1; assert (H: 0 <= Zpos p); auto with zarith. +generalize H; pattern (Zpos p); apply natlike_ind; auto. +intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith. +apply Zmult_le_0_compat; auto with zarith. +generalize H1; case a; compute; intros; auto; discriminate. +Qed. + +Hint Resolve Zpower_le_0 Zpower_lt_0: zarith. + +Theorem Zpower_prod: forall p q r, 0 <= q -> 0 <= r -> (p * q) ^ r = p ^ r * q ^ r. +intros p q r H1 H2; generalize H2; pattern r; apply natlike_ind; auto. +intros r1 H3 H4 H5. +unfold Zsucc; rewrite Zpower_exp; auto with zarith. +rewrite H4; repeat (rewrite Zpower_exp_1 || rewrite Zpower_exp); auto with zarith; ring. +Qed. + +Theorem Zpower_le_monotone_exp: forall a b c: Z, 0 <= c -> 0 <= a <= b -> a ^ c <= b ^ c. +intros a b c H (H1, H2). +generalize H; pattern c; apply natlike_ind; auto. +intros x HH HH1 _; unfold Zsucc; repeat rewrite Zpower_exp; auto with zarith. +repeat rewrite Zpower_exp_1. +apply Zle_trans with (a ^x * b); auto with zarith. +Qed. + +Theorem Zpower_lt_monotone: forall a b c: Z, 1 < a -> 0 <= b < c -> a ^ b < a ^ + c. +intros a b c H (H1, H2). +rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith. +rewrite Zpower_exp; auto with zarith. +apply Zmult_lt_compat_l; auto with zarith. +assert (0 < a ^ (c - b)); auto with zarith. +apply Zlt_le_trans with (a ^1); auto with zarith. +rewrite Zpower_exp_1; auto with zarith. +apply Zpower_le_monotone; auto with zarith. +Qed. + +Lemma Zpower_le_monotone_inv : + forall a b c, 1 < a -> 0 < b -> a^b <= a^c -> b <= c. +Proof. + intros a b c H H0 H1. + destruct (Z_le_gt_dec b c);trivial. + assert (2 <= a^b). + apply Zle_trans with (2^b). + pattern 2 at 1;replace 2 with (2^1);trivial. + apply Zpower_le_monotone;auto with zarith. + apply Zpower_le_monotone_exp;auto with zarith. + assert (c > 0). + destruct (Z_le_gt_dec 0 c);trivial. + destruct (Zle_lt_or_eq _ _ z0);auto with zarith. + rewrite <- H3 in H1;simpl in H1; elimtype False;omega. + destruct c;try discriminate z0. simpl in H1. elimtype False;omega. + assert (H4 := Zpower_lt_monotone a c b H). elimtype False;omega. +Qed. + + +Theorem Zpower_le_monotone2: + forall a b c: Z, 0 < a -> b <= c -> a ^ b <= a ^ c. +intros a b c H H2. +destruct (Z_le_gt_dec 0 b). +rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith. +rewrite Zpower_exp; auto with zarith. +apply Zmult_le_compat_l; auto with zarith. +assert (0 < a ^ (c - b)); auto with zarith. +replace (a^b) with 0. +destruct (Z_le_gt_dec 0 c). +destruct (Zle_lt_or_eq _ _ z0). +apply Zlt_le_weak;apply Zpower_lt_0;trivial. +rewrite <- H0;simpl;auto with zarith. +replace (a^c) with 0. auto with zarith. +destruct c;trivial;unfold Zgt in z0;discriminate z0. +destruct b;trivial;unfold Zgt in z;discriminate z. +Qed. diff --git a/theories/Ints/Z/ZSum.v b/theories/Ints/Z/ZSum.v new file mode 100644 index 000000000..bcde7386c --- /dev/null +++ b/theories/Ints/Z/ZSum.v @@ -0,0 +1,321 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +(*********************************************************************** + Summation.v from Z to Z + *********************************************************************) +Require Import Arith. +Require Import ArithRing. +Require Import ListAux. +Require Import ZArith. +Require Import ZAux. +Require Import Iterator. +Require Import ZProgression. + + +Open Scope Z_scope. +(* Iterated Sum *) + +Definition Zsum := + fun n m f => + if Zle_bool n m + then iter 0 f Zplus (progression Zsucc n (Zabs_nat ((1 + m) - n))) + else iter 0 f Zplus (progression Zpred n (Zabs_nat ((1 + n) - m))). +Hint Unfold Zsum . + +Lemma Zsum_nn: forall n f, Zsum n n f = f n. +intros n f; unfold Zsum; rewrite Zle_bool_refl. +replace ((1 + n) - n) with 1; auto with zarith. +simpl; ring. +Qed. + +Theorem permutation_rev: forall (A:Set) (l : list A), permutation (rev l) l. +intros a l; elim l; simpl; auto. +intros a1 l1 Hl1. +apply permutation_trans with (cons a1 (rev l1)); auto. +change (permutation (rev l1 ++ (a1 :: nil)) (app (cons a1 nil) (rev l1))); auto. +Qed. + +Lemma Zsum_swap: forall (n m : Z) (f : Z -> Z), Zsum n m f = Zsum m n f. +intros n m f; unfold Zsum. +generalize (Zle_cases n m) (Zle_cases m n); case (Zle_bool n m); + case (Zle_bool m n); auto with arith. +intros; replace n with m; auto with zarith. +3:intros H1 H2; contradict H2; auto with zarith. +intros H1 H2; apply iter_permutation; auto with zarith. +apply permutation_trans + with (rev (progression Zsucc n (Zabs_nat ((1 + m) - n)))). +apply permutation_sym; apply permutation_rev. +rewrite Zprogression_opp; auto with zarith. +replace (n + Z_of_nat (pred (Zabs_nat ((1 + m) - n)))) with m; auto. +replace (Zabs_nat ((1 + m) - n)) with (S (Zabs_nat (m - n))); auto with zarith. +simpl. +rewrite Z_of_nat_Zabs_nat; auto with zarith. +replace ((1 + m) - n) with (1 + (m - n)); auto with zarith. +cut (0 <= m - n); auto with zarith; unfold Zabs_nat. +case (m - n); auto with zarith. +intros p; case p; simpl; auto with zarith. +intros p1 Hp1; rewrite nat_of_P_xO; rewrite nat_of_P_xI; + rewrite nat_of_P_succ_morphism. +simpl; repeat rewrite plus_0_r. +repeat rewrite <- plus_n_Sm; simpl; auto. +intros p H3; contradict H3; auto with zarith. +intros H1 H2; apply iter_permutation; auto with zarith. +apply permutation_trans + with (rev (progression Zsucc m (Zabs_nat ((1 + n) - m)))). +rewrite Zprogression_opp; auto with zarith. +replace (m + Z_of_nat (pred (Zabs_nat ((1 + n) - m)))) with n; auto. +replace (Zabs_nat ((1 + n) - m)) with (S (Zabs_nat (n - m))); auto with zarith. +simpl. +rewrite Z_of_nat_Zabs_nat; auto with zarith. +replace ((1 + n) - m) with (1 + (n - m)); auto with zarith. +cut (0 <= n - m); auto with zarith; unfold Zabs_nat. +case (n - m); auto with zarith. +intros p; case p; simpl; auto with zarith. +intros p1 Hp1; rewrite nat_of_P_xO; rewrite nat_of_P_xI; + rewrite nat_of_P_succ_morphism. +simpl; repeat rewrite plus_0_r. +repeat rewrite <- plus_n_Sm; simpl; auto. +intros p H3; contradict H3; auto with zarith. +apply permutation_rev. +Qed. + +Lemma Zsum_split_up: + forall (n m p : Z) (f : Z -> Z), + ( n <= m < p ) -> Zsum n p f = Zsum n m f + Zsum (m + 1) p f. +intros n m p f [H H0]. +case (Zle_lt_or_eq _ _ H); clear H; intros H. +unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith. +assert (H1: n < p). +apply Zlt_trans with ( 1 := H ); auto with zarith. +assert (H2: m < 1 + p). +apply Zlt_trans with ( 1 := H0 ); auto with zarith. +assert (H3: n < 1 + m). +apply Zlt_trans with ( 1 := H ); auto with zarith. +assert (H4: n < 1 + p). +apply Zlt_trans with ( 1 := H1 ); auto with zarith. +replace (Zabs_nat ((1 + p) - (m + 1))) + with (minus (Zabs_nat ((1 + p) - n)) (Zabs_nat ((1 + m) - n))). +apply iter_progression_app; auto with zarith. +apply inj_le_inv. +(repeat rewrite Z_of_nat_Zabs_nat); auto with zarith. +rewrite next_n_Z; auto with zarith. +rewrite Z_of_nat_Zabs_nat; auto with zarith. +apply inj_eq_inv; auto with zarith. +rewrite inj_minus1; auto with zarith. +(repeat rewrite Z_of_nat_Zabs_nat); auto with zarith. +apply inj_le_inv. +(repeat rewrite Z_of_nat_Zabs_nat); auto with zarith. +subst m. +rewrite Zsum_nn; auto with zarith. +unfold Zsum; generalize (Zle_cases n p); generalize (Zle_cases (n + 1) p); + case (Zle_bool n p); case (Zle_bool (n + 1) p); auto with zarith. +intros H1 H2. +replace (Zabs_nat ((1 + p) - n)) with (S (Zabs_nat (p - n))); auto with zarith. +replace (n + 1) with (Zsucc n); auto with zarith. +replace ((1 + p) - Zsucc n) with (p - n); auto with zarith. +apply inj_eq_inv; auto with zarith. +rewrite inj_S; (repeat rewrite Z_of_nat_Zabs_nat); auto with zarith. +Qed. + +Lemma Zsum_S_left: + forall (n m : Z) (f : Z -> Z), n < m -> Zsum n m f = f n + Zsum (n + 1) m f. +intros n m f H; rewrite (Zsum_split_up n n m f); auto with zarith. +rewrite Zsum_nn; auto with zarith. +Qed. + +Lemma Zsum_S_right: + forall (n m : Z) (f : Z -> Z), + n <= m -> Zsum n (m + 1) f = Zsum n m f + f (m + 1). +intros n m f H; rewrite (Zsum_split_up n m (m + 1) f); auto with zarith. +rewrite Zsum_nn; auto with zarith. +Qed. + +Lemma Zsum_split_down: + forall (n m p : Z) (f : Z -> Z), + ( p < m <= n ) -> Zsum n p f = Zsum n m f + Zsum (m - 1) p f. +intros n m p f [H H0]. +case (Zle_lt_or_eq p (m - 1)); auto with zarith; intros H1. +pattern m at 1; replace m with ((m - 1) + 1); auto with zarith. +repeat rewrite (Zsum_swap n). +rewrite (Zsum_swap (m - 1)). +rewrite Zplus_comm. +apply Zsum_split_up; auto with zarith. +subst p. +repeat rewrite (Zsum_swap n). +rewrite Zsum_nn. +unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith. +replace (Zabs_nat ((1 + n) - (m - 1))) with (S (Zabs_nat (n - (m - 1)))). +rewrite Zplus_comm. +replace (Zabs_nat ((1 + n) - m)) with (Zabs_nat (n - (m - 1))); auto with zarith. +pattern m at 4; replace m with (Zsucc (m - 1)); auto with zarith. +apply f_equal with ( f := Zabs_nat ); auto with zarith. +apply inj_eq_inv; auto with zarith. +rewrite inj_S. +(repeat rewrite Z_of_nat_Zabs_nat); auto with zarith. +Qed. + + +Lemma Zsum_ext: + forall (n m : Z) (f g : Z -> Z), + n <= m -> + (forall (x : Z), ( n <= x <= m ) -> f x = g x) -> Zsum n m f = Zsum n m g. +intros n m f g HH H. +unfold Zsum; auto. +unfold Zsum; (repeat rewrite Zle_imp_le_bool); auto with zarith. +apply iter_ext; auto with zarith. +intros a H1; apply H; auto; split. +apply Zprogression_le_init with ( 1 := H1 ). +cut (a < Zsucc m); auto with zarith. +replace (Zsucc m) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith. +apply Zprogression_le_end; auto with zarith. +rewrite Z_of_nat_Zabs_nat; auto with zarith. +Qed. + +Lemma Zsum_add: + forall (n m : Z) (f g : Z -> Z), + Zsum n m f + Zsum n m g = Zsum n m (fun (i : Z) => f i + g i). +intros n m f g; unfold Zsum; case (Zle_bool n m); apply iter_comp; + auto with zarith. +Qed. + +Lemma Zsum_times: + forall n m x f, x * Zsum n m f = Zsum n m (fun i=> x * f i). +intros n m x f. +unfold Zsum. case (Zle_bool n m); intros; apply iter_comp_const with (k := (fun y : Z => x * y)); auto with zarith. +Qed. + +Lemma inv_Zsum: + forall (P : Z -> Prop) (n m : Z) (f : Z -> Z), + n <= m -> + P 0 -> + (forall (a b : Z), P a -> P b -> P (a + b)) -> + (forall (x : Z), ( n <= x <= m ) -> P (f x)) -> P (Zsum n m f). +intros P n m f HH H H0 H1. +unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith; apply iter_inv; auto. +intros x H3; apply H1; auto; split. +apply Zprogression_le_init with ( 1 := H3 ). +cut (x < Zsucc m); auto with zarith. +replace (Zsucc m) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith. +apply Zprogression_le_end; auto with zarith. +rewrite Z_of_nat_Zabs_nat; auto with zarith. +Qed. + + +Lemma Zsum_pred: + forall (n m : Z) (f : Z -> Z), + Zsum n m f = Zsum (n + 1) (m + 1) (fun (i : Z) => f (Zpred i)). +intros n m f. +unfold Zsum. +generalize (Zle_cases n m); generalize (Zle_cases (n + 1) (m + 1)); + case (Zle_bool n m); case (Zle_bool (n + 1) (m + 1)); auto with zarith. +replace ((1 + (m + 1)) - (n + 1)) with ((1 + m) - n); auto with zarith. +intros H1 H2; cut (exists c , c = Zabs_nat ((1 + m) - n) ). +intros [c H3]; rewrite <- H3. +generalize n; elim c; auto with zarith; clear H1 H2 H3 c n. +intros c H n; simpl; eq_tac; auto with zarith. +eq_tac; unfold Zpred; auto with zarith. +replace (Zsucc (n + 1)) with (Zsucc n + 1); auto with zarith. +exists (Zabs_nat ((1 + m) - n)); auto. +replace ((1 + (n + 1)) - (m + 1)) with ((1 + n) - m); auto with zarith. +intros H1 H2; cut (exists c , c = Zabs_nat ((1 + n) - m) ). +intros [c H3]; rewrite <- H3. +generalize n; elim c; auto with zarith; clear H1 H2 H3 c n. +intros c H n; simpl; (eq_tac; auto with zarith). +eq_tac; unfold Zpred; auto with zarith. +replace (Zpred (n + 1)) with (Zpred n + 1); auto with zarith. +unfold Zpred; auto with zarith. +exists (Zabs_nat ((1 + n) - m)); auto. +Qed. + +Theorem Zsum_c: + forall (c p q : Z), p <= q -> Zsum p q (fun x => c) = ((1 + q) - p) * c. +intros c p q Hq; unfold Zsum. +rewrite Zle_imp_le_bool; auto with zarith. +pattern ((1 + q) - p) at 2; rewrite <- Z_of_nat_Zabs_nat; auto with zarith. +cut (exists r , r = Zabs_nat ((1 + q) - p) ); + [intros [r H1]; rewrite <- H1 | exists (Zabs_nat ((1 + q) - p))]; auto. +generalize p; elim r; auto with zarith. +intros n H p0; replace (Z_of_nat (S n)) with (Z_of_nat n + 1); auto with zarith. +simpl; rewrite H; ring. +rewrite inj_S; auto with zarith. +Qed. + +Theorem Zsum_Zsum_f: + forall (i j k l : Z) (f : Z -> Z -> Z), + i <= j -> + k < l -> + Zsum i j (fun x => Zsum k (l + 1) (fun y => f x y)) = + Zsum i j (fun x => Zsum k l (fun y => f x y) + f x (l + 1)). +intros; apply Zsum_ext; intros; auto with zarith. +rewrite Zsum_S_right; auto with zarith. +Qed. + +Theorem Zsum_com: + forall (i j k l : Z) (f : Z -> Z -> Z), + Zsum i j (fun x => Zsum k l (fun y => f x y)) = + Zsum k l (fun y => Zsum i j (fun x => f x y)). +intros; unfold Zsum; case (Zle_bool i j); case (Zle_bool k l); apply iter_com; + auto with zarith. +Qed. + +Theorem Zsum_le: + forall (n m : Z) (f g : Z -> Z), + n <= m -> + (forall (x : Z), ( n <= x <= m ) -> (f x <= g x )) -> + (Zsum n m f <= Zsum n m g ). +intros n m f g Hl H. +unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith. +unfold Zsum; + cut + (forall x, + In x (progression Zsucc n (Zabs_nat ((1 + m) - n))) -> ( f x <= g x )). +elim (progression Zsucc n (Zabs_nat ((1 + m) - n))); simpl; auto with zarith. +intros x H1; apply H; split. +apply Zprogression_le_init with ( 1 := H1 ); auto. +cut (x < m + 1); auto with zarith. +replace (m + 1) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith. +apply Zprogression_le_end; auto with zarith. +rewrite Z_of_nat_Zabs_nat; auto with zarith. +Qed. + +Theorem iter_le: +forall (f g: Z -> Z) l, (forall a, In a l -> f a <= g a) -> + iter 0 f Zplus l <= iter 0 g Zplus l. +intros f g l; elim l; simpl; auto with zarith. +Qed. + +Theorem Zsum_lt: + forall n m f g, + (forall x, n <= x -> x <= m -> f x <= g x) -> + (exists x, n <= x /\ x <= m /\ f x < g x) -> + Zsum n m f < Zsum n m g. +intros n m f g H (d, (Hd1, (Hd2, Hd3))); unfold Zsum; rewrite Zle_imp_le_bool; auto with zarith. +cut (In d (progression Zsucc n (Zabs_nat (1 + m - n)))). +cut (forall x, In x (progression Zsucc n (Zabs_nat (1 + m - n)))-> f x <= g x). +elim (progression Zsucc n (Zabs_nat (1 + m - n))); simpl; auto with zarith. +intros a l Rec H0 [H1 | H1]; subst; auto. +apply Zle_lt_trans with (f d + iter 0 g Zplus l); auto with zarith. +apply Zplus_le_compat_l. +apply iter_le; auto. +apply Zlt_le_trans with (f a + iter 0 g Zplus l); auto with zarith. +intros x H1; apply H. +apply Zprogression_le_init with ( 1 := H1 ); auto. +cut (x < m + 1); auto with zarith. +replace (m + 1) with (n + Z_of_nat (Zabs_nat ((1 + m) - n))); auto with zarith. +apply Zprogression_le_end with ( 1 := H1 ); auto with arith. +rewrite Z_of_nat_Zabs_nat; auto with zarith. +apply in_Zprogression. +rewrite Z_of_nat_Zabs_nat; auto with zarith. +Qed. + +Theorem Zsum_minus: + forall n m f g, Zsum n m f - Zsum n m g = Zsum n m (fun x => f x - g x). +intros n m f g; apply trans_equal with (Zsum n m f + (-1) * Zsum n m g); auto with zarith. +rewrite Zsum_times; rewrite Zsum_add; auto with zarith. +Qed. diff --git a/theories/Ints/Z/Zmod.v b/theories/Ints/Z/Zmod.v new file mode 100644 index 000000000..dffa79532 --- /dev/null +++ b/theories/Ints/Z/Zmod.v @@ -0,0 +1,94 @@ +Require Import ZArith. +Require Import ZAux. + +Set Implicit Arguments. + +Open Scope Z_scope. + +Lemma rel_prime_mod: forall a b, 1 < b -> + rel_prime a b -> a mod b <> 0. +Proof. +intros a b H H1 H2. +case (not_rel_prime_0 _ H). +rewrite <- H2. +apply rel_prime_mod; auto with zarith. +Qed. + +Lemma Zmodpl: forall a b n, 0 < n -> + (a mod n + b) mod n = (a + b) mod n. +Proof. +intros a b n H. +rewrite Zmod_plus; auto. +rewrite Zmod_mod; auto. +apply sym_equal; apply Zmod_plus; auto. +Qed. + +Lemma Zmodpr: forall a b n, 0 < n -> + (b + a mod n) mod n = (b + a) mod n. +Proof. +intros a b n H; repeat rewrite (Zplus_comm b). +apply Zmodpl; auto. +Qed. + +Lemma Zmodml: forall a b n, 0 < n -> + (a mod n * b) mod n = (a * b) mod n. +Proof. +intros a b n H. +rewrite Zmod_mult; auto. +rewrite Zmod_mod; auto. +apply sym_equal; apply Zmod_mult; auto. +Qed. + +Lemma Zmodmr: forall a b n, 0 < n -> + (b * (a mod n)) mod n = (b * a) mod n. +Proof. +intros a b n H; repeat rewrite (Zmult_comm b). +apply Zmodml; auto. +Qed. + + +Ltac is_ok t := + match t with + | (?x mod _ + ?y mod _) mod _ => constr:false + | (?x mod _ * (?y mod _)) mod _ => constr:false + | ?x mod _ => x + end. + +Ltac rmod t := + match t with + (?x + ?y) mod _ => + match (is_ok x) with + | false => rmod x + | ?x1 => match (is_ok y) with + |false => rmod y + | ?y1 => + rewrite <- (Zmod_plus x1 y1) + |false => rmod y + end + end + | (?x * ?y) mod _ => + match (is_ok x) with + | false => rmod x + | ?x1 => match (is_ok y) with + |false => rmod y + | ?y1 => rewrite <- (Zmod_mult x1 y1) + end + | false => rmod x + end + end. + + +Lemma Zmod_div_mod: forall n m a, 0 < n -> 0 < m -> + (n | m) -> a mod n = (a mod m) mod n. +Proof. +intros n m a H1 H2 H3. +pattern a at 1; rewrite (Z_div_mod_eq a m); auto with zarith. +case H3; intros q Hq; pattern m at 1; rewrite Hq. +rewrite (Zmult_comm q). +rewrite Zmod_plus; auto. +rewrite <- Zmult_assoc; rewrite Zmod_mult; auto. +rewrite Z_mod_same; try rewrite Zmult_0_l; auto with zarith. +rewrite (Zmod_def_small 0); auto with zarith. +rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith. +Qed. + diff --git a/theories/Ints/num/Basic_type.v b/theories/Ints/num/Basic_type.v new file mode 100644 index 000000000..f481f3942 --- /dev/null +++ b/theories/Ints/num/Basic_type.v @@ -0,0 +1,64 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZDivModAux. +Require Import ZPowerAux. + +Open Local Scope Z_scope. + +Section Carry. + + Variable A : Set. + + Inductive carry : Set := + | C0 : A -> carry + | C1 : A -> carry. + +End Carry. + +Section Zn2Z. + + Variable znz : Set. + + Inductive zn2z : Set := + | W0 : zn2z + | WW : znz -> znz -> zn2z. + + Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) := + match x with + | W0 => 0 + | WW xh xl => w_to_Z xh * wB + w_to_Z xl + end. + + Definition base digits := Zpower 2 (Zpos digits). + + Definition interp_carry sign B (interp:znz -> Z) c := + match c with + | C0 x => interp x + | C1 x => sign*B + interp x + end. + +End Zn2Z. + +Implicit Arguments W0 [znz]. + +Fixpoint word_tr (w:Set) (n:nat) {struct n} : Set := + match n with + | O => w + | S n => word_tr (zn2z w) n + end. + +Fixpoint word (w:Set) (n:nat) {struct n} : Set := + match n with + | O => w + | S n => zn2z (word w n) + end. + diff --git a/theories/Ints/num/GenAdd.v b/theories/Ints/num/GenAdd.v new file mode 100644 index 000000000..9d4c57902 --- /dev/null +++ b/theories/Ints/num/GenAdd.v @@ -0,0 +1,315 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZAux. +Require Import ZDivModAux. +Require Import Basic_type. +Require Import GenBase. + +Open Local Scope Z_scope. + +Section GenAdd. + Variable w : Set. + Variable w_0 : w. + Variable w_1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_W0 : w -> zn2z w. + Variable ww_1 : zn2z w. + Variable w_succ_c : w -> carry w. + Variable w_add_c : w -> w -> carry w. + Variable w_add_carry_c : w -> w -> carry w. + Variable w_succ : w -> w. + Variable w_add : w -> w -> w. + Variable w_add_carry : w -> w -> w. + + Definition ww_succ_c x := + match x with + | W0 => C0 ww_1 + | WW xh xl => + match w_succ_c xl with + | C0 l => C0 (WW xh l) + | C1 l => + match w_succ_c xh with + | C0 h => C0 (WW h w_0) + | C1 h => C1 W0 + end + end + end. + + Definition ww_succ x := + match x with + | W0 => ww_1 + | WW xh xl => + match w_succ_c xl with + | C0 l => WW xh l + | C1 l => w_W0 (w_succ xh) + end + end. + + Definition ww_add_c x y := + match x, y with + | W0, _ => C0 y + | _, W0 => C0 x + | WW xh xl, WW yh yl => + match w_add_c xl yl with + | C0 l => + match w_add_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (w_WW h l) + end + | C1 l => + match w_add_carry_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (w_WW h l) + end + end + end. + + Variable R : Set. + Variable f0 f1 : zn2z w -> R. + + Definition ww_add_c_cont x y := + match x, y with + | W0, _ => f0 y + | _, W0 => f0 x + | WW xh xl, WW yh yl => + match w_add_c xl yl with + | C0 l => + match w_add_c xh yh with + | C0 h => f0 (WW h l) + | C1 h => f1 (w_WW h l) + end + | C1 l => + match w_add_carry_c xh yh with + | C0 h => f0 (WW h l) + | C1 h => f1 (w_WW h l) + end + end + end. + + (* ww_add et ww_add_carry conserve la forme normale s'il n'y a pas + de debordement *) + Definition ww_add x y := + match x, y with + | W0, _ => y + | _, W0 => x + | WW xh xl, WW yh yl => + match w_add_c xl yl with + | C0 l => WW (w_add xh yh) l + | C1 l => WW (w_add_carry xh yh) l + end + end. + + Definition ww_add_carry_c x y := + match x, y with + | W0, W0 => C0 ww_1 + | W0, WW yh yl => ww_succ_c (WW yh yl) + | WW xh xl, W0 => ww_succ_c (WW xh xl) + | WW xh xl, WW yh yl => + match w_add_carry_c xl yl with + | C0 l => + match w_add_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (WW h l) + end + | C1 l => + match w_add_carry_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (w_WW h l) + end + end + end. + + Definition ww_add_carry x y := + match x, y with + | W0, W0 => ww_1 + | W0, WW yh yl => ww_succ (WW yh yl) + | WW xh xl, W0 => ww_succ (WW xh xl) + | WW xh xl, WW yh yl => + match w_add_carry_c xl yl with + | C0 l => WW (w_add xh yh) l + | C1 l => WW (w_add_carry xh yh) l + end + end. + + (*Section GenProof.*) + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). + Notation "[-| c |]" := + (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_1 : [|w_1|] = 1. + Variable spec_ww_1 : [[ww_1]] = 1. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. + Variable spec_w_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1. + Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. + Variable spec_w_add_carry_c : + forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. + Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. + Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. + Variable spec_w_add_carry : + forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. + + Lemma spec_ww_succ_c : forall x, [+[ww_succ_c x]] = [[x]] + 1. + Proof. + destruct x as [ |xh xl];simpl. apply spec_ww_1. + generalize (spec_w_succ_c xl);destruct (w_succ_c xl) as [l|l]; + intro H;unfold interp_carry in H. simpl;rewrite H;ring. + rewrite <- Zplus_assoc;rewrite <- H;rewrite Zmult_1_l. + assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega. + rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h]; + intro H1;unfold interp_carry in H1. + simpl;rewrite H1;rewrite spec_w_0;ring. + unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB. + assert ([|xh|] = wB - 1). generalize (spec_to_Z xh)(spec_to_Z h);omega. + rewrite H2;ring. + Qed. + + Lemma spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. + Proof. + destruct x as [ |xh xl];simpl;trivial. + destruct y as [ |yh yl];simpl. rewrite Zplus_0_r;trivial. + replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) + with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. + generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; + intros H;unfold interp_carry in H;rewrite <- H. + generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; + intros H1;unfold interp_carry in *;rewrite <- H1. trivial. + repeat rewrite Zmult_1_l;rewrite spec_w_WW;rewrite wwB_wBwB; ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) + as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1. + simpl;ring. + repeat rewrite Zmult_1_l;rewrite wwB_wBwB;rewrite spec_w_WW;ring. + Qed. + + Section Cont. + Variable P : zn2z w -> zn2z w -> R -> Prop. + Variable x y : zn2z w. + Variable spec_f0 : forall r, [[r]] = [[x]] + [[y]] -> P x y (f0 r). + Variable spec_f1 : forall r, wwB + [[r]] = [[x]] + [[y]] -> P x y (f1 r). + + Lemma spec_ww_add_c_cont : P x y (ww_add_c_cont x y). + Proof. + destruct x as [ |xh xl];simpl;trivial. + apply spec_f0;trivial. + destruct y as [ |yh yl];simpl. + apply spec_f0;simpl;rewrite Zplus_0_r;trivial. + generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; + intros H;unfold interp_carry in H. + generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; + intros H1;unfold interp_carry in *. + apply spec_f0. simpl;rewrite H;rewrite H1;ring. + apply spec_f1. simpl;rewrite spec_w_WW;rewrite H. + rewrite Zplus_assoc;rewrite wwB_wBwB. rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. + rewrite Zmult_1_l in H1;rewrite H1;ring. + generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) + as [h|h]; intros H1;unfold interp_carry in *. + apply spec_f0;simpl;rewrite H1. rewrite Zmult_plus_distr_l. + rewrite <- Zplus_assoc;rewrite H;ring. + apply spec_f1. simpl;rewrite spec_w_WW;rewrite wwB_wBwB. + rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. + rewrite Zmult_1_l in H1;rewrite H1. rewrite Zmult_plus_distr_l. + rewrite <- Zplus_assoc;rewrite H;ring. + Qed. + + End Cont. + + Lemma spec_ww_add_carry_c : + forall x y, [+[ww_add_carry_c x y]] = [[x]] + [[y]] + 1. + Proof. + destruct x as [ |xh xl];intro y;simpl. + exact (spec_ww_succ_c y). + destruct y as [ |yh yl];simpl. + rewrite Zplus_0_r;exact (spec_ww_succ_c (WW xh xl)). + replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) + with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. + generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) + as [l|l];intros H;unfold interp_carry in H;rewrite <- H. + generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; + intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. + unfold interp_carry;repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) + as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. + unfold interp_carry;rewrite spec_w_WW; + repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_succ : forall x, [[ww_succ x]] = ([[x]] + 1) mod wwB. + Proof. + destruct x as [ |xh xl];simpl. + rewrite spec_ww_1;rewrite Zmod_def_small;trivial. + split;[intro;discriminate|apply wwB_pos]. + rewrite <- Zplus_assoc;generalize (spec_w_succ_c xl); + destruct (w_succ_c xl) as[l|l];intro H;unfold interp_carry in H;rewrite <-H. + rewrite Zmod_def_small;trivial. + rewrite wwB_wBwB;apply beta_mult;apply spec_to_Z. + assert ([|l|] = 0). clear spec_ww_1 spec_w_1 spec_w_0. + assert (H1:= spec_to_Z l); assert (H2:= spec_to_Z xl); omega. + rewrite H0;rewrite Zplus_0_r;rewrite <- Zmult_plus_distr_l;rewrite wwB_wBwB. + rewrite Zpower_2; rewrite Zmult_mod_distr_r;try apply lt_0_wB. + rewrite spec_w_W0;rewrite spec_w_succ;trivial. + Qed. + + Lemma spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. + Proof. + destruct x as [ |xh xl];intros y;simpl. + rewrite Zmod_def_small;trivial. apply spec_ww_to_Z;trivial. + destruct y as [ |yh yl]. + change [[W0]] with 0;rewrite Zplus_0_r. + rewrite Zmod_def_small;trivial. + exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)). + simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) + with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. + generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; + unfold interp_carry;intros H;simpl;rewrite <- H. + rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. + Qed. + + Lemma spec_ww_add_carry : + forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. + Proof. + destruct x as [ |xh xl];intros y;simpl. + exact (spec_ww_succ y). + destruct y as [ |yh yl]. + change [[W0]] with 0;rewrite Zplus_0_r. exact (spec_ww_succ (WW xh xl)). + simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) + with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. + generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) + as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z. + rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. + Qed. + +(* End GenProof. *) +End GenAdd. diff --git a/theories/Ints/num/GenBase.v b/theories/Ints/num/GenBase.v new file mode 100644 index 000000000..b953566ed --- /dev/null +++ b/theories/Ints/num/GenBase.v @@ -0,0 +1,377 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZAux. +Require Import ZDivModAux. +Require Import ZPowerAux. +Require Import Basic_type. +Require Import JMeq. + +Open Local Scope Z_scope. + +Section GenBase. + Variable w : Set. + Variable w_0 : w. + Variable w_1 : w. + Variable w_Bm1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + Variable w_compare : w -> w -> comparison. + + Definition ww_digits := xO w_digits. + + Definition ww_to_Z := zn2z_to_Z (base w_digits) w_to_Z. + + Definition ww_1 := WW w_0 w_1. + + Definition ww_Bm1 := WW w_Bm1 w_Bm1. + + Definition ww_WW xh xl : zn2z (zn2z w) := + match xh, xl with + | W0, W0 => W0 + | _, _ => WW xh xl + end. + + Definition ww_W0 h : zn2z (zn2z w) := + match h with + | W0 => W0 + | _ => WW h W0 + end. + + Definition ww_0W l : zn2z (zn2z w) := + match l with + | W0 => W0 + | _ => WW W0 l + end. + + Definition gen_WW (n:nat) := + match n return word w n -> word w n -> word w (S n) with + | O => w_WW + | S n => + fun (h l : zn2z (word w n)) => + match h, l with + | W0, W0 => W0 + | _, _ => WW h l + end + end. + + Fixpoint gen_digits (n:nat) : positive := + match n with + | O => w_digits + | S n => xO (gen_digits n) + end. + + Definition gen_wB n := base (gen_digits n). + + Fixpoint gen_to_Z (n:nat) : word w n -> Z := + match n return word w n -> Z with + | O => w_to_Z + | S n => zn2z_to_Z (gen_wB n) (gen_to_Z n) + end. + + Fixpoint extend_aux (n:nat) (x:zn2z w) {struct n}: word w (S n) := + match n return word w (S n) with + | O => x + | S n1 => WW W0 (extend_aux n1 x) + end. + + Definition extend (n:nat) (x:w) : word w (S n) := + let r := w_0W x in + match r with + | W0 => W0 + | _ => extend_aux n r + end. + + Definition gen_0 n : word w n := + match n return word w n with + | O => w_0 + | S _ => W0 + end. + + Definition gen_split (n:nat) (x:zn2z (word w n)) := + match x with + | W0 => + match n return word w n * word w n with + | O => (w_0,w_0) + | S _ => (W0, W0) + end + | WW h l => (h,l) + end. + + Definition ww_compare x y := + match x, y with + | W0, W0 => Eq + | W0, WW yh yl => + match w_compare w_0 yh with + | Eq => w_compare w_0 yl + | _ => Lt + end + | WW xh xl, W0 => + match w_compare xh w_0 with + | Eq => w_compare xl w_0 + | _ => Gt + end + | WW xh xl, WW yh yl => + match w_compare xh yh with + | Eq => w_compare xl yl + | Lt => Lt + | Gt => Gt + end + end. + + Section GenProof. + Notation wB := (base w_digits). + Notation wwB := (base ww_digits). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[[ x ]]" := (ww_to_Z x) (at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB ww_to_Z c) (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB ww_to_Z c) (at level 0, x at level 99). + Notation "[! n | x !]" := (gen_to_Z n x) (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_1 : [|w_1|] = 1. + Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_w_compare : forall x y, + match w_compare x y with + | Eq => [|x|] = [|y|] + | Lt => [|x|] < [|y|] + | Gt => [|x|] > [|y|] + end. + + Lemma wwB_wBwB : wwB = wB^2. + Proof. + unfold base, ww_digits;rewrite Zpower_2; rewrite (Zpos_xO w_digits). + replace (2 * Zpos w_digits) with (Zpos w_digits + Zpos w_digits). + apply Zpower_exp; unfold Zge;simpl;intros;discriminate. + ring. + Qed. + + Lemma spec_ww_1 : [[ww_1]] = 1. + Proof. simpl;rewrite spec_w_0;rewrite spec_w_1;ring. Qed. + + Lemma spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. + Proof. simpl;rewrite spec_w_Bm1;rewrite wwB_wBwB;ring. Qed. + + Lemma lt_0_wB : 0 < wB. + Proof. + unfold base;apply Zpower_lt_0. unfold Zlt;reflexivity. + unfold Zle;intros H;discriminate H. + Qed. + + Lemma lt_0_wwB : 0 < wwB. + Proof. rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_lt_0_compat;apply lt_0_wB. Qed. + + Lemma wB_pos: 1 < wB. + Proof. + unfold base;apply Zlt_le_trans with (2^1). unfold Zlt;reflexivity. + apply Zpower_le_monotone. unfold Zlt;reflexivity. + split;unfold Zle;intros H. discriminate H. + clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW. + destruct w_digits; discriminate H. + Qed. + + Lemma wwB_pos: 1 < wwB. + Proof. + assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Zmult_1_r 1). + rewrite Zpower_2. + apply Zmult_lt_compat;(split;[unfold Zlt;reflexivity|trivial]). + apply Zlt_le_weak;trivial. + Qed. + + Theorem wB_div_2: 2 * (wB / 2) = wB. + Proof. + clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W + spec_to_Z;unfold base. + assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))). + pattern 2 at 2; rewrite <- Zpower_exp_1. + rewrite <- Zpower_exp; auto with zarith. + eq_tac; auto with zarith. + case w_digits; compute; intros; discriminate. + rewrite H; eq_tac; auto with zarith. + rewrite Zmult_comm; apply Z_div_mult; auto with zarith. + Qed. + + Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB. + Proof. + clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W + spec_to_Z. + rewrite wwB_wBwB; rewrite Zpower_2. + pattern wB at 1; rewrite <- wB_div_2; auto. + rewrite <- Zmult_assoc. + repeat (rewrite (Zmult_comm 2); rewrite Z_div_mult); auto with zarith. + Qed. + + Lemma mod_wwB : forall z x, + (z*wB + [|x|]) mod wwB = (z mod wB)*wB + [|x|]. + Proof. + intros z x. + rewrite Zmod_plus. 2:apply lt_0_wwB. + pattern wwB at 1;rewrite wwB_wBwB; rewrite Zpower_2. + rewrite Zmult_mod_distr_r;try apply lt_0_wB. + rewrite (Zmod_def_small [|x|]). + apply Zmod_def_small;rewrite wwB_wBwB;apply beta_mult;try apply spec_to_Z. + apply Z_mod_lt;apply Zlt_gt;apply lt_0_wB. + destruct (spec_to_Z x);split;trivial. + change [|x|] with (0*wB+[|x|]). rewrite wwB_wBwB. + rewrite Zpower_2;rewrite <- (Zplus_0_r (wB*wB));apply beta_lex_inv. + apply lt_0_wB. apply spec_to_Z. split;[apply Zle_refl | apply lt_0_wB]. + Qed. + + Lemma wB_div : forall x y, ([|x|] * wB + [|y|]) / wB = [|x|]. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + intros x y;unfold base;rewrite Zdiv_shift_r;auto with zarith. + rewrite Z_div_mult;auto with zarith. + destruct (spec_to_Z x);trivial. + Qed. + + Lemma wB_div_plus : forall x y p, + 0 <= p -> + ([|x|]*wB + [|y|]) / 2^(Zpos w_digits + p) = [|x|] / 2^p. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + intros x y p Hp;rewrite Zpower_exp;auto with zarith. + rewrite <- Zdiv_Zdiv;auto with zarith. + rewrite wB_div;trivial. + Qed. + + Lemma lt_wB_wwB : wB < wwB. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + unfold base;apply Zpower_lt_monotone;auto with zarith. + assert (0 < Zpos w_digits). compute;reflexivity. + unfold ww_digits;rewrite Zpos_xO;auto with zarith. + Qed. + + Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB. + Proof. + intros x H;apply Zlt_trans with wB;trivial;apply lt_wB_wwB. + Qed. + + Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + destruct x as [ |h l];simpl. + split;[apply Zle_refl|apply lt_0_wwB]. + assert (H:=spec_to_Z h);assert (L:=spec_to_Z l);split. + apply Zplus_le_0_compat;auto with zarith. + rewrite <- (Zplus_0_r wwB);rewrite wwB_wBwB; rewrite Zpower_2; + apply beta_lex_inv;auto with zarith. + Qed. + + Lemma gen_wB_wwB : forall n, gen_wB n * gen_wB n = gen_wB (S n). + Proof. + intros n;unfold gen_wB;simpl. + unfold base;rewrite (Zpos_xO (gen_digits n)). + replace (2 * Zpos (gen_digits n)) with + (Zpos (gen_digits n) + Zpos (gen_digits n)). + symmetry; apply Zpower_exp;intro;discriminate. + ring. + Qed. + + Lemma spec_gen_to_Z : + forall n (x:word w n), 0 <= gen_to_Z n x < gen_wB n. + Proof. + clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. + induction n;intros. exact (spec_to_Z x). + unfold gen_to_Z;fold gen_to_Z. + destruct x;unfold zn2z_to_Z. + unfold gen_wB,base;split;auto with zarith. + assert (U0:= IHn w0);assert (U1:= IHn w1). + split;auto with zarith. + apply Zlt_le_trans with ((gen_wB n - 1) * gen_wB n + gen_wB n). + assert (gen_to_Z n w0*gen_wB n <= (gen_wB n - 1)*gen_wB n). + apply Zmult_le_compat_r;auto with zarith. + auto with zarith. + rewrite <- gen_wB_wwB. + replace ((gen_wB n - 1) * gen_wB n + gen_wB n) with (gen_wB n * gen_wB n); + [auto with zarith | ring]. + Qed. + + Lemma spec_gen_WW : forall n (h l : word w n), + [!S n|gen_WW n h l!] = [!n|h!] * gen_wB n + [!n|l!]. + Proof. + induction n;simpl;intros;trivial. + destruct h;auto. + destruct l;auto. + Qed. + + Lemma spec_extend_aux : forall n x, [!S n|extend_aux n x!] = [[x]]. + Proof. induction n;simpl;trivial. Qed. + + Lemma spec_extend : forall n x, [!S n|extend n x!] = [|x|]. + Proof. + intros n x;assert (H:= spec_w_0W x);unfold extend. + destruct (w_0W x);simpl;trivial. + rewrite <- H;exact (spec_extend_aux n (WW w0 w1)). + Qed. + + Lemma spec_gen_0 : forall n, [!n|gen_0 n!] = 0. + Proof. destruct n;trivial. Qed. + + Lemma spec_gen_split : forall n x, + let (h,l) := gen_split n x in + [!S n|x!] = [!n|h!] * gen_wB n + [!n|l!]. + Proof. + destruct x;simpl;auto. + destruct n;simpl;trivial. + rewrite spec_w_0;trivial. + Qed. + + Lemma wB_lex_inv: forall a b c d, + a < c -> + a * wB + [|b|] < c * wB + [|d|]. + Proof. + intros a b c d H1; apply beta_lex_inv with (1 := H1); auto. + Qed. + + Lemma spec_ww_compare : forall x y, + match ww_compare x y with + | Eq => [[x]] = [[y]] + | Lt => [[x]] < [[y]] + | Gt => [[x]] > [[y]] + end. + Proof. + destruct x as [ |xh xl];destruct y as [ |yh yl];simpl;trivial. + generalize (spec_w_compare w_0 yh);destruct (w_compare w_0 yh); + intros H;rewrite spec_w_0 in H. + rewrite <- H;simpl;rewrite <- spec_w_0;apply spec_w_compare. + change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. + apply wB_lex_inv;trivial. + absurd (0 <= [|yh|]). apply Zgt_not_le;trivial. + destruct (spec_to_Z yh);trivial. + generalize (spec_w_compare xh w_0);destruct (w_compare xh w_0); + intros H;rewrite spec_w_0 in H. + rewrite H;simpl;rewrite <- spec_w_0;apply spec_w_compare. + absurd (0 <= [|xh|]). apply Zgt_not_le;apply Zlt_gt;trivial. + destruct (spec_to_Z xh);trivial. + apply Zlt_gt;change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. + apply wB_lex_inv;apply Zgt_lt;trivial. + + generalize (spec_w_compare xh yh);destruct (w_compare xh yh);intros H. + rewrite H;generalize (spec_w_compare xl yl);destruct (w_compare xl yl); + intros H1;[rewrite H1|apply Zplus_lt_compat_l|apply Zplus_gt_compat_l]; + trivial. + apply wB_lex_inv;trivial. + apply Zlt_gt;apply wB_lex_inv;apply Zgt_lt;trivial. + Qed. + + End GenProof. + +End GenBase. + diff --git a/theories/Ints/num/GenDiv.v b/theories/Ints/num/GenDiv.v new file mode 100644 index 000000000..4bcea709d --- /dev/null +++ b/theories/Ints/num/GenDiv.v @@ -0,0 +1,1438 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZAux. +Require Import ZDivModAux. +Require Import ZPowerAux. +Require Import Basic_type. +Require Import GenBase. +Require Import GenDivn1. +Require Import GenAdd. +Require Import GenSub. + +Open Local Scope Z_scope. + +Ltac zarith := auto with zarith. + + +Section POS_MOD. + + Variable w:Set. + Variable w_0 : w. + Variable w_digits : positive. + Variable w_WW : w -> w -> zn2z w. + Variable w_pos_mod : positive -> w -> w. + + Definition ww_pos_mod p x := + match x with + | W0 => W0 + | WW xh xl => + match Pcompare p w_digits Eq with + | Eq => w_WW w_0 xl + | Lt => w_WW w_0 (w_pos_mod p xl) + | Gt => + let n := Pminus p w_digits in + w_WW (w_pos_mod n xh) xl + end + end. + + + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + + + Variable spec_w_0 : [|w_0|] = 0. + + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + + Variable spec_pos_mod : forall w p, + [|w_pos_mod p w|] = [|w|] mod (2 ^ Zpos p). + + Hint Rewrite spec_w_0 spec_w_WW : w_rewrite. + + Lemma spec_ww_pos_mod : forall w p, + [[ww_pos_mod p w]] = [[w]] mod (2 ^ Zpos p). + assert (HHHHH:= lt_0_wB w_digits). + assert (F0: forall x y, x - y + y = x); auto with zarith. + intros w1 p; unfold ww_pos_mod; case w1. + autorewrite with w_rewrite; rewrite Zmod_def_small; auto with zarith. + match goal with |- context [(?X ?= ?Y)%positive Eq] => + case_eq (Pcompare X Y Eq) end; intros H1. + assert (E1: Zpos p = Zpos w_digits); auto. + rewrite Pcompare_Eq_eq with (1:= H1); auto with zarith. + rewrite E1. + intros xh xl; simpl ww_to_Z;autorewrite with w_rewrite rm10. + match goal with |- context id [2 ^Zpos w_digits] => + let v := context id [wB] in change v + end. + rewrite Zmod_plus; auto with zarith. + rewrite Zmod_mult_0; auto with zarith. + autorewrite with rm10. + rewrite Zmod_mod; auto with zarith. + rewrite Zmod_def_small; auto with zarith. + assert (Eq1: Zpos p < Zpos w_digits); auto. + intros xh xl; autorewrite with w_rewrite rm10. + rewrite spec_pos_mod; auto with zarith. + assert (Eq2: Zpos p+(Zpos w_digits -Zpos p) = Zpos w_digits);auto with zarith. + simpl ww_to_Z;unfold base; rewrite <- Eq2. + rewrite Zpower_exp; auto with zarith. + rewrite (fun x => (Zmult_comm (2 ^ x))); rewrite Zmult_assoc. + rewrite Zmod_plus; auto with zarith. + rewrite Zmod_mult_0; auto with zarith. + autorewrite with rm10. + rewrite Zmod_mod; auto with zarith. + assert (Eq1: Zpos p > Zpos w_digits); auto. + intros xh xl; autorewrite with w_rewrite rm10. + rewrite spec_pos_mod; auto with zarith. + simpl ww_to_Z. + pattern [|xh|] at 2; rewrite Z_div_mod_eq with (b := 2 ^ Zpos (p - w_digits)); + auto with zarith. + rewrite (fun x => (Zmult_comm (2 ^ x))); rewrite Zmult_plus_distr_l. + unfold base; rewrite <- Zmult_assoc; rewrite <- Zpower_exp; + auto with zarith. + rewrite Zpos_minus; auto with zarith. + rewrite F0; auto with zarith. + rewrite <- Zplus_assoc; rewrite Zmod_plus; auto with zarith. + rewrite Zmod_mult_0; auto with zarith. + autorewrite with rm10. + rewrite Zmod_mod; auto with zarith. + apply sym_equal; apply Zmod_def_small; auto with zarith. + case (spec_to_Z xh); intros U1 U2. + case (spec_to_Z xl); intros U3 U4. + split; auto with zarith. + apply Zplus_le_0_compat; auto with zarith. + apply Zmult_le_0_compat; auto with zarith. + match goal with |- 0 <= ?X mod ?Y => + case (Z_mod_lt X Y); auto with zarith + end. + match goal with |- ?X mod ?Y * ?U + ?Z < ?T => + apply Zle_lt_trans with ((Y - 1) * U + Z ); + [case (Z_mod_lt X Y); auto with zarith | idtac] + end. + match goal with |- ?X * ?U + ?Y < ?Z => + apply Zle_lt_trans with (X * U + (U - 1)) + end. + apply Zplus_le_compat_l; auto with zarith. + case (spec_to_Z xl); unfold base; auto with zarith. + rewrite Zmult_minus_distr_r; rewrite <- Zpower_exp; auto with zarith. + rewrite F0; auto with zarith. + Qed. + +End POS_MOD. + +Section GenDiv32. + + Variable w : Set. + Variable w_0 : w. + Variable w_Bm1 : w. + Variable w_Bm2 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_compare : w -> w -> comparison. + Variable w_add_c : w -> w -> carry w. + Variable w_add_carry_c : w -> w -> carry w. + Variable w_add : w -> w -> w. + Variable w_add_carry : w -> w -> w. + Variable w_pred : w -> w. + Variable w_sub : w -> w -> w. + Variable w_mul_c : w -> w -> zn2z w. + Variable w_div21 : w -> w -> w -> w*w. + Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). + + Definition w_div32 a1 a2 a3 b1 b2 := + Eval lazy beta iota delta [ww_add_c_cont ww_add] in + match w_compare a1 b1 with + | Lt => + let (q,r) := w_div21 a1 a2 b1 in + match ww_sub_c (w_WW r a3) (w_mul_c q b2) with + | C0 r1 => (q,r1) + | C1 r1 => + let q := w_pred q in + ww_add_c_cont w_WW w_add_c w_add_carry_c + (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) + (fun r2 => (q,r2)) + r1 (WW b1 b2) + end + | Eq => + ww_add_c_cont w_WW w_add_c w_add_carry_c + (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) + (fun r => (w_Bm1,r)) + (WW (w_sub a2 b2) a3) (WW b1 b2) + | Gt => (w_0, W0) (* cas absurde *) + end. + + (* Proof *) + + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). + Notation "[-| c |]" := + (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. + Variable spec_w_Bm2 : [|w_Bm2|] = wB - 2. + + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_compare : + forall x y, + match w_compare x y with + | Eq => [|x|] = [|y|] + | Lt => [|x|] < [|y|] + | Gt => [|x|] > [|y|] + end. + Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. + Variable spec_w_add_carry_c : + forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. + + Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. + Variable spec_w_add_carry : + forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. + + Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. + Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + + Variable spec_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. + Variable spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + + Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. + + Ltac Spec_w_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_to_Z x). + Ltac Spec_ww_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). + + Theorem wB_div2: forall x, wB/2 <= x -> wB <= 2 * x. + intros x H; rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith. + Qed. + + Lemma Zmult_lt_0_reg_r_2 : forall n m : Z, 0 <= n -> 0 < m * n -> 0 < m. + Proof. + intros n m H1 H2;apply Zmult_lt_0_reg_r with n;trivial. + destruct (Zle_lt_or_eq _ _ H1);trivial. + subst;rewrite Zmult_0_r in H2;discriminate H2. + Qed. + + Theorem spec_w_div32 : forall a1 a2 a3 b1 b2, + wB/2 <= [|b1|] -> + [[WW a1 a2]] < [[WW b1 b2]] -> + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + 0 <= [[r]] < [|b1|] * wB + [|b2|]. + Proof. + intros a1 a2 a3 b1 b2 Hle Hlt. + assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits). + Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2. + rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_assoc;rewrite <- Zmult_plus_distr_l. + change (w_div32 a1 a2 a3 b1 b2) with + match w_compare a1 b1 with + | Lt => + let (q,r) := w_div21 a1 a2 b1 in + match ww_sub_c (w_WW r a3) (w_mul_c q b2) with + | C0 r1 => (q,r1) + | C1 r1 => + let q := w_pred q in + ww_add_c_cont w_WW w_add_c w_add_carry_c + (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) + (fun r2 => (q,r2)) + r1 (WW b1 b2) + end + | Eq => + ww_add_c_cont w_WW w_add_c w_add_carry_c + (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) + (fun r => (w_Bm1,r)) + (WW (w_sub a2 b2) a3) (WW b1 b2) + | Gt => (w_0, W0) (* cas absurde *) + end. + assert (Hcmp:=spec_compare a1 b1);destruct (w_compare a1 b1). + simpl in Hlt. + rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega. + assert ([[WW (w_sub a2 b2) a3]] = ([|a2|]-[|b2|])*wB + [|a3|] + wwB). + simpl;rewrite spec_sub. + assert ([|a2|] - [|b2|] = wB*(-1) + ([|a2|] - [|b2|] + wB)). ring. + assert (0 <= [|a2|] - [|b2|] + wB < wB). omega. + rewrite <-(Zmod_unique ([|a2|]-[|b2|]) wB (-1) ([|a2|]-[|b2|]+wB) U H1 H0). + rewrite wwB_wBwB;ring. + assert (U2 := wB_pos w_digits). + eapply spec_ww_add_c_cont with (P := + fun (x y:zn2z w) (res:w*zn2z w) => + let (q, r) := res in + ([|a1|] * wB + [|a2|]) * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + 0 <= [[r]] < [|b1|] * wB + [|b2|]);eauto. + rewrite H0;intros r. + repeat + (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2); + simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. + assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]). + Spec_ww_to_Z r;split;zarith. + rewrite H1. + assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). + rewrite wwB_wBwB; rewrite Zpower_2; zarith. + assert (-wwB < ([|a2|] - [|b2|]) * wB + [|a3|] < 0). + split. apply Zlt_le_trans with (([|a2|] - [|b2|]) * wB);zarith. + rewrite wwB_wBwB;replace (-(wB^2)) with (-wB*wB);[zarith | ring]. + apply Zmult_lt_compat_r;zarith. + apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. + replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with + (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith | ring]. + assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. + replace 0 with (0*wB);zarith. + replace (([|a2|] - [|b2|]) * wB + [|a3|] + wwB + ([|b1|] * wB + [|b2|]) + + ([|b1|] * wB + [|b2|]) - wwB) with + (([|a2|] - [|b2|]) * wB + [|a3|] + 2*[|b1|] * wB + 2*[|b2|]); + [zarith | ring]. + rewrite <- (Zmod_unique ([[r]] + ([|b1|] * wB + [|b2|])) wwB + 1 ([[r]] + ([|b1|] * wB + [|b2|]) - wwB));zarith;try (ring;fail). + split. rewrite H1;rewrite Hcmp;ring. trivial. + Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith. + rewrite H0;intros r;repeat + (rewrite spec_w_Bm1 || rewrite spec_w_Bm2); + simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. + assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith. + split. rewrite H2;rewrite Hcmp;ring. + split. Spec_ww_to_Z r;zarith. + rewrite H2. + assert (([|a2|] - [|b2|]) * wB + [|a3|] < 0);zarith. + apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. + replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with + (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith|ring]. + assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. + replace 0 with (0*wB);zarith. + (* Cas Lt *) + assert (Hdiv21 := spec_div21 a2 Hle Hcmp); + destruct (w_div21 a1 a2 b1) as (q, r);destruct Hdiv21. + rewrite H. + assert (Hq := spec_to_Z q). + generalize + (spec_ww_sub_c (w_WW r a3) (w_mul_c q b2)); + destruct (ww_sub_c (w_WW r a3) (w_mul_c q b2)) + as [r1|r1];repeat (rewrite spec_w_WW || rewrite spec_mul_c); + unfold interp_carry;intros H1. + rewrite H1. + split. ring. split. + rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial. + apply Zle_lt_trans with ([|r|] * wB + [|a3|]). + assert ( 0 <= [|q|] * [|b2|]);zarith. + apply beta_lex_inv;zarith. + assert ([[r1]] = [|r|] * wB + [|a3|] - [|q|] * [|b2|] + wwB). + rewrite <- H1;ring. + Spec_ww_to_Z r1; assert (0 <= [|r|]*wB). zarith. + assert (0 < [|q|] * [|b2|]). zarith. + assert (0 < [|q|]). + apply Zmult_lt_0_reg_r_2 with [|b2|];zarith. + eapply spec_ww_add_c_cont with (P := + fun (x y:zn2z w) (res:w*zn2z w) => + let (q0, r0) := res in + ([|q|] * [|b1|] + [|r|]) * wB + [|a3|] = + [|q0|] * ([|b1|] * wB + [|b2|]) + [[r0]] /\ + 0 <= [[r0]] < [|b1|] * wB + [|b2|]);eauto. + intros r2;repeat (rewrite spec_pred || rewrite spec_ww_add;eauto); + simpl ww_to_Z;intros H7. + assert (0 < [|q|] - 1). + assert (1 <= [|q|]). zarith. + destruct (Zle_lt_or_eq _ _ H6);zarith. + rewrite <- H8 in H2;rewrite H2 in H7. + assert (0 < [|b1|]*wB). apply Zmult_lt_0_compat;zarith. + Spec_ww_to_Z r2. zarith. + rewrite (Zmod_def_small ([|q|] -1));zarith. + rewrite (Zmod_def_small ([|q|] -1 -1));zarith. + assert ([[r2]] + ([|b1|] * wB + [|b2|]) = + wwB * 1 + + ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2 * ([|b1|] * wB + [|b2|]))). + rewrite H7;rewrite H2;ring. + assert + ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) + < [|b1|]*wB + [|b2|]). + Spec_ww_to_Z r2;omega. + Spec_ww_to_Z (WW b1 b2). simpl in HH5. + assert + (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) + < wwB). split;try omega. + replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring. + assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). + rewrite wwB_wBwB; rewrite Zpower_2; zarith. omega. + rewrite <- (Zmod_unique + ([[r2]] + ([|b1|] * wB + [|b2|])) + wwB + 1 + ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2*([|b1|] * wB + [|b2|])) + U1 + H10 H8). + split. ring. zarith. + intros r2;repeat (rewrite spec_pred);simpl ww_to_Z;intros H7. + rewrite (Zmod_def_small ([|q|] -1));zarith. + split. + replace [[r2]] with ([[r1]] + ([|b1|] * wB + [|b2|]) -wwB). + rewrite H2; ring. rewrite <- H7; ring. + Spec_ww_to_Z r2;Spec_ww_to_Z r1. omega. + simpl in Hlt. + assert ([|a1|] * wB + [|a2|] <= [|b1|] * wB + [|b2|]). zarith. + assert (H1 := beta_lex _ _ _ _ _ H HH0 HH3). rewrite spec_w_0;simpl;zarith. + Qed. + + +End GenDiv32. + +Section GenDiv21. + Variable w : Set. + Variable w_0 : w. + + Variable w_0W : w -> zn2z w. + Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. + + Variable ww_1 : zn2z w. + Variable ww_compare : zn2z w -> zn2z w -> comparison. + Variable ww_sub : zn2z w -> zn2z w -> zn2z w. + + + Definition ww_div21 a1 a2 b := + match a1 with + | W0 => + match ww_compare a2 b with + | Gt => (ww_1, ww_sub a2 b) + | Eq => (ww_1, W0) + | Lt => (W0, a2) + end + | WW a1h a1l => + match a2 with + | W0 => + match b with + | W0 => (W0,W0) (* cas absurde *) + | WW b1 b2 => + let (q1, r) := w_div32 a1h a1l w_0 b1 b2 in + match r with + | W0 => (WW q1 w_0, W0) + | WW r1 r2 => + let (q2, s) := w_div32 r1 r2 w_0 b1 b2 in + (WW q1 q2, s) + end + end + | WW a2h a2l => + match b with + | W0 => (W0,W0) (* cas absurde *) + | WW b1 b2 => + let (q1, r) := w_div32 a1h a1l a2h b1 b2 in + match r with + | W0 => (WW q1 w_0, w_0W a2l) + | WW r1 r2 => + let (q2, s) := w_div32 r1 r2 a2l b1 b2 in + (WW q1 q2, s) + end + end + end + end. + + (* Proof *) + + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. + Variable spec_w_div32 : forall a1 a2 a3 b1 b2, + wB/2 <= [|b1|] -> + [[WW a1 a2]] < [[WW b1 b2]] -> + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + 0 <= [[r]] < [|b1|] * wB + [|b2|]. + Variable spec_ww_1 : [[ww_1]] = 1. + Variable spec_ww_compare : forall x y, + match ww_compare x y with + | Eq => [[x]] = [[y]] + | Lt => [[x]] < [[y]] + | Gt => [[x]] > [[y]] + end. + Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. + + Theorem wwB_div: wwB = 2 * (wwB / 2). + Proof. + rewrite wwB_div_2; rewrite Zmult_assoc; rewrite wB_div_2; auto. + rewrite <- Zpower_2; apply wwB_wBwB. + Qed. + + Ltac Spec_w_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_to_Z x). + Ltac Spec_ww_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). + + Theorem spec_ww_div21 : forall a1 a2 b, + wwB/2 <= [[b]] -> + [[a1]] < [[b]] -> + let (q,r) := ww_div21 a1 a2 b in + [[a1]] *wwB+[[a2]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]. + Proof. + assert (U:= lt_0_wB w_digits). + assert (U1:= lt_0_wwB w_digits). + intros a1 a2 b H Hlt; unfold ww_div21. + Spec_ww_to_Z b; assert (Eq: 0 < [[b]]). Spec_ww_to_Z a1;omega. + generalize Hlt H ;clear Hlt H;case a1. + intros H1 H2;simpl in H1;Spec_ww_to_Z a2; + match goal with |-context [ww_compare ?Y ?Z] => + generalize (spec_ww_compare Y Z); case (ww_compare Y Z) + end; simpl;try rewrite spec_ww_1;autorewrite with rm10; intros;zarith. + rewrite spec_ww_sub;simpl. rewrite Zmod_def_small;zarith. + split. ring. + assert (wwB <= 2*[[b]]);zarith. + rewrite wwB_div;zarith. + intros a1h a1l. Spec_w_to_Z a1h;Spec_w_to_Z a1l. Spec_ww_to_Z a2. + destruct a2 as [ |a3 a4]; + (destruct b as [ |b1 b2];[unfold Zle in Eq;discriminate Eq|idtac]); + try (Spec_w_to_Z a3; Spec_w_to_Z a4); Spec_w_to_Z b1; Spec_w_to_Z b2; + intros Hlt H; match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => + generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); + intros q1 r H0 + end; (assert (Eq1: wB / 2 <= [|b1|]);[ + apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith; + autorewrite with rm10;repeat rewrite (Zmult_comm wB); + rewrite <- wwB_div_2; trivial + | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl; + try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Zplus_0_r; + intros (H1,H2) ]). + split;[rewrite wwB_wBwB; rewrite Zpower_2 | trivial]. + rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc; + rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H1;ring. + destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => + generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); + intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. + split;[rewrite wwB_wBwB | trivial]. + rewrite Zpower_2. + rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc; + rewrite <- Zpower_2. + rewrite <- wwB_wBwB;rewrite H1. + rewrite spec_w_0 in H4;rewrite Zplus_0_r in H4. + repeat rewrite Zmult_plus_distr_l. rewrite <- (Zmult_assoc [|r1|]). + rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. + split;[rewrite wwB_wBwB | split;zarith]. + replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) + with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). + rewrite H1;ring. rewrite wwB_wBwB;ring. + change [|a4|] with (0*wB+[|a4|]);apply beta_lex_inv;zarith. + assert (1 <= wB/2);zarith. + assert (H_:= wB_pos w_digits);apply Zdiv_le_lower_bound;zarith. + destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => + generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); + intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. + split;trivial. + replace (([|a1h|] * wB + [|a1l|]) * wwB + ([|a3|] * wB + [|a4|])) with + (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); + [rewrite H1 | rewrite wwB_wBwB;ring]. + replace (([|q1|]*([|b1|]*wB+[|b2|])+([|r1|]*wB+[|r2|]))*wB+[|a4|]) with + (([|q1|]*([|b1|]*wB+[|b2|]))*wB+([|r1|]*wwB+[|r2|]*wB+[|a4|])); + [rewrite H4;simpl|rewrite wwB_wBwB];ring. + Qed. + +End GenDiv21. + +Section GenDivGt. + Variable w : Set. + Variable w_digits : positive. + Variable w_0 : w. + + Variable w_WW : w -> w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_compare : w -> w -> comparison. + Variable w_eq0 : w -> bool. + Variable w_opp_c : w -> carry w. + Variable w_opp w_opp_carry : w -> w. + Variable w_sub_c : w -> w -> carry w. + Variable w_sub w_sub_carry : w -> w -> w. + + Variable w_div_gt : w -> w -> w*w. + Variable w_mod_gt : w -> w -> w. + Variable w_gcd_gt : w -> w -> w. + Variable w_add_mul_div : positive -> w -> w -> w. + Variable w_head0 : w -> N. + Variable w_div21 : w -> w -> w -> w * w. + Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. + + + Variable _ww_digits : positive. + Variable ww_1 : zn2z w. + Variable ww_add_mul_div : positive -> zn2z w -> zn2z w -> zn2z w. + + Definition ww_div_gt_aux ah al bh bl := + Eval lazy beta iota delta [ww_sub ww_opp] in + let nb0 := w_head0 bh in + match nb0 with + | N0 => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c + w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) + | Npos p => + let b1 := w_add_mul_div p bh bl in + let b2 := w_add_mul_div p bl w_0 in + let a1 := w_add_mul_div p w_0 ah in + let a2 := w_add_mul_div p ah al in + let a3 := w_add_mul_div p al w_0 in + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + (WW w_0 q, ww_add_mul_div (Pminus _ww_digits p) W0 r) + end. + + Definition ww_div_gt a b := + Eval lazy beta iota delta [ww_div_gt_aux gen_divn1 + gen_divn1_p gen_divn1_p_aux gen_divn1_0 gen_divn1_0_aux + gen_split gen_0 gen_WW] in + match a, b with + | W0, _ => (W0,W0) + | _, W0 => (W0,W0) + | WW ah al, WW bh bl => + if w_eq0 ah then + let (q,r) := w_div_gt al bl in + (WW w_0 q, w_0W r) + else + match w_compare w_0 bh with + | Eq => + let(q,r):= + gen_divn1 w_digits w_0 w_WW w_head0 w_add_mul_div w_div21 1 a bl in + (q, w_0W r) + | Lt => ww_div_gt_aux ah al bh bl + | Gt => (W0,W0) (* cas absurde *) + end + end. + + Definition ww_mod_gt_aux ah al bh bl := + Eval lazy beta iota delta [ww_sub ww_opp] in + let nb0 := w_head0 bh in + match nb0 with + | N0 => + ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c + w_opp w_sub w_sub_carry (WW ah al) (WW bh bl) + | Npos p => + let b1 := w_add_mul_div p bh bl in + let b2 := w_add_mul_div p bl w_0 in + let a1 := w_add_mul_div p w_0 ah in + let a2 := w_add_mul_div p ah al in + let a3 := w_add_mul_div p al w_0 in + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + ww_add_mul_div (Pminus _ww_digits p) W0 r + end. + + Definition ww_mod_gt a b := + Eval lazy beta iota delta [ww_mod_gt_aux gen_modn1 + gen_modn1_p gen_modn1_p_aux gen_modn1_0 gen_modn1_0_aux + gen_split gen_0 gen_WW snd] in + match a, b with + | W0, _ => W0 + | _, W0 => W0 + | WW ah al, WW bh bl => + if w_eq0 ah then w_0W (w_mod_gt al bl) + else + match w_compare w_0 bh with + | Eq => + w_0W (gen_modn1 w_digits w_0 w_head0 w_add_mul_div w_div21 1 a bl) + | Lt => ww_mod_gt_aux ah al bh bl + | Gt => W0 (* cas absurde *) + end + end. + + Definition ww_gcd_gt_body (cont: w->w->w->w->zn2z w) (ah al bh bl: w) := + Eval lazy beta iota delta [ww_mod_gt_aux gen_modn1 + gen_modn1_p gen_modn1_p_aux gen_modn1_0 gen_modn1_0_aux + gen_split gen_0 gen_WW snd] in + match w_compare w_0 bh with + | Eq => + match w_compare w_0 bl with + | Eq => WW ah al (* normalement n'arrive pas si forme normale *) + | Lt => + let m := gen_modn1 w_digits w_0 w_head0 w_add_mul_div w_div21 1 + (WW ah al) bl in + WW w_0 (w_gcd_gt bl m) + | Gt => W0 (* absurde *) + end + | Lt => + let m := ww_mod_gt_aux ah al bh bl in + match m with + | W0 => WW bh bl + | WW mh ml => + match w_compare w_0 mh with + | Eq => + match w_compare w_0 ml with + | Eq => WW bh bl + | _ => + let r := gen_modn1 w_digits w_0 w_head0 w_add_mul_div w_div21 1 + (WW bh bl) ml in + WW w_0 (w_gcd_gt ml r) + end + | Lt => + let r := ww_mod_gt_aux bh bl mh ml in + match r with + | W0 => m + | WW rh rl => cont mh ml rh rl + end + | Gt => W0 (* absurde *) + end + end + | Gt => W0 (* absurde *) + end. + + Fixpoint ww_gcd_gt_aux + (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) + {struct p} : zn2z w := + ww_gcd_gt_body + (fun mh ml rh rl => match p with + | xH => cont mh ml rh rl + | xO p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl + | xI p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl + end) ah al bh bl. + + + (* Proof *) + + Variable w_to_Z : w -> Z. + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[-| c |]" := + (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. + Variable spec_compare : + forall x y, + match w_compare x y with + | Eq => [|x|] = [|y|] + | Lt => [|x|] < [|y|] + | Gt => [|x|] > [|y|] + end. + Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. + + Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. + Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. + Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. + + Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. + Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + Variable spec_sub_carry : + forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. + + Variable spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + let (q,r) := w_div_gt a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Variable spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + [|w_mod_gt a b|] = [|a|] mod [|b|]. + Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> + Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. + + Variable spec_add_mul_div : forall x y p, + Zpos p < Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (Zpower 2 (Zpos p)) + + [|y|] / (Zpower 2 ((Zpos w_digits) - (Zpos p)))) mod wB. + Variable spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ (Z_of_N (w_head0 x)) * [|x|] < wB. + + Variable spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + + Variable spec_w_div32 : forall a1 a2 a3 b1 b2, + wB/2 <= [|b1|] -> + [[WW a1 a2]] < [[WW b1 b2]] -> + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + 0 <= [[r]] < [|b1|] * wB + [|b2|]. + + Variable spec_ww_digits_ : _ww_digits = xO w_digits. + Variable spec_ww_1 : [[ww_1]] = 1. + Variable spec_ww_add_mul_div : forall x y p, + Zpos p < Zpos (xO w_digits) -> + [[ ww_add_mul_div p x y ]] = + ([[x]] * (2^Zpos p) + + [[y]] / (2^(Zpos (xO w_digits) - Zpos p))) mod wwB. + + Ltac Spec_w_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_to_Z x). + + Ltac Spec_ww_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). + + Lemma to_Z_div_minus_p : forall x p, + 0 < Zpos p < Zpos w_digits -> + 0 <= [|x|] / 2 ^ (Zpos w_digits - Zpos p) < 2 ^ Zpos p. + Proof. + intros x p H;Spec_w_to_Z x. + split. apply Zdiv_le_lower_bound;zarith. + apply Zdiv_lt_upper_bound;zarith. + rewrite <- Zpower_exp;zarith. + ring_simplify (Zpos p + (Zpos w_digits - Zpos p)); unfold base in HH;zarith. + Qed. + Hint Resolve to_Z_div_minus_p : zarith. + + Lemma spec_ww_div_gt_aux : forall ah al bh bl, + [[WW ah al]] > [[WW bh bl]] -> + 0 < [|bh|] -> + let (q,r) := ww_div_gt_aux ah al bh bl in + [[WW ah al]] = [[q]] * [[WW bh bl]] + [[r]] /\ + 0 <= [[r]] < [[WW bh bl]]. + Proof. + intros ah al bh bl Hgt Hpos;unfold ww_div_gt_aux. + change + (let (q, r) := match w_head0 bh with + | N0 => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c + w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) + | Npos p => + let b1 := w_add_mul_div p bh bl in + let b2 := w_add_mul_div p bl w_0 in + let a1 := w_add_mul_div p w_0 ah in + let a2 := w_add_mul_div p ah al in + let a3 := w_add_mul_div p al w_0 in + let (q,r) := w_div32 a1 a2 a3 b1 b2 in + (WW w_0 q, ww_add_mul_div (Pminus _ww_digits p) W0 r) + end in [[WW ah al]]=[[q]]*[[WW bh bl]]+[[r]] /\ 0 <=[[r]]< [[WW bh bl]]). + assert (Hh := spec_head0 Hpos);destruct (w_head0 bh). + simpl Zpower in Hh;rewrite Zmult_1_l in Hh;destruct Hh. + assert (wwB <= 2*[[WW bh bl]]). + apply Zle_trans with (2*[|bh|]*wB). + rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat_r; zarith. + rewrite <- wB_div_2; apply Zmult_le_compat_l; zarith. + simpl ww_to_Z;rewrite Zmult_plus_distr_r;rewrite Zmult_assoc. + Spec_w_to_Z bl;zarith. + Spec_ww_to_Z (WW ah al). + rewrite spec_ww_sub;eauto. + simpl;rewrite spec_ww_1;rewrite Zmult_1_l;simpl. + simpl ww_to_Z in Hgt, H1, HH;rewrite Zmod_def_small;split;zarith. + unfold Z_of_N in Hh. + assert (Zpos p < Zpos w_digits). + destruct (Z_lt_ge_dec (Zpos p) (Zpos w_digits));trivial. + elimtype False. + assert (2 ^ Zpos p * [|bh|] >= wB);auto with zarith. + apply Zle_ge; replace wB with (wB * 1);try ring. + Spec_w_to_Z bh;apply Zmult_le_compat;zarith. + unfold base;apply Zpower_le_monotone;zarith. + assert (HHHH : 0 < Zpos p < Zpos w_digits). + split;trivial. unfold Zlt;reflexivity. + generalize (spec_add_mul_div w_0 ah H) + (spec_add_mul_div ah al H) + (spec_add_mul_div al w_0 H) + (spec_add_mul_div bh bl H) + (spec_add_mul_div bl w_0 H); + rewrite spec_w_0; repeat rewrite Zmult_0_l;repeat rewrite Zplus_0_l; + rewrite Zdiv_0;repeat rewrite Zplus_0_r. + Spec_w_to_Z ah;Spec_w_to_Z bh. 2:apply Zpower_lt_0;zarith. + unfold base;repeat rewrite Zmod_shift_r;zarith. + assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH); + assert (H5:=to_Z_div_minus_p bl HHHH). + rewrite Zmult_comm in Hh. + assert (2^Zpos p < wB). unfold base;apply Zpower_lt_monotone;zarith. + unfold base in H0;rewrite Zmod_def_small;zarith. + fold wB; rewrite (Zmod_def_small ([|bh|] * 2 ^ Zpos p));zarith. + intros U1 U2 U3 V1 V2. + generalize (@spec_w_div32 (w_add_mul_div p w_0 ah) + (w_add_mul_div p ah al) + (w_add_mul_div p al w_0) + (w_add_mul_div p bh bl) + (w_add_mul_div p bl w_0)). + destruct (w_div32 (w_add_mul_div p w_0 ah) + (w_add_mul_div p ah al) + (w_add_mul_div p al w_0) + (w_add_mul_div p bh bl) + (w_add_mul_div p bl w_0)) as (q,r). + rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l. + rewrite <- (Zplus_assoc ([|bh|] * 2 ^ Zpos p * wB)). + unfold base;rewrite <- shift_unshift_mod;zarith. fold wB. + replace ([|bh|] * 2 ^ Zpos p * wB + [|bl|] * 2 ^ Zpos p) with + ([[WW bh bl]] * 2^Zpos p). 2:simpl;ring. + fold wwB. rewrite wwB_wBwB. rewrite Zpower_2. rewrite U1;rewrite U2;rewrite U3. + rewrite Zmult_assoc. rewrite Zmult_plus_distr_l. + rewrite (Zplus_assoc ([|ah|] / 2^(Zpos(w_digits) - Zpos p)*wB * wB)). + rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. + unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB. + replace ([|ah|] * 2 ^ Zpos p * wB + [|al|] * 2 ^ Zpos p) with + ([[WW ah al]] * 2^Zpos p). 2:simpl;ring. + intros Hd;destruct Hd;zarith. + simpl. apply beta_lex_inv;zarith. rewrite U1;rewrite V1. + assert ([|ah|] / 2 ^ (Zpos (w_digits) - Zpos p) < wB/2);zarith. + apply Zdiv_lt_upper_bound;zarith. + unfold base. + replace (2^Zpos (w_digits)) with (2^(Zpos (w_digits) - 1)*2). + rewrite Z_div_mult;zarith. rewrite <- Zpower_exp;zarith. + apply Zlt_le_trans with wB;zarith. + unfold base;apply Zpower_le_monotone;zarith. + pattern 2 at 2;replace 2 with (2^1);trivial. + rewrite <- Zpower_exp;zarith. ring_simplify (Zpos (w_digits) - 1 + 1);trivial. + change [[WW w_0 q]] with ([|w_0|]*wB+[|q|]);rewrite spec_w_0;rewrite + Zmult_0_l;rewrite Zplus_0_l;rewrite spec_ww_digits_. + replace [[ww_add_mul_div (xO (w_digits) - p) W0 r]] with ([[r]]/2^Zpos p). + assert (0 < 2^Zpos p). apply Zpower_lt_0;zarith. + split. + rewrite <- (Z_div_mult [[WW ah al]] (2^Zpos p));zarith. + rewrite H1;rewrite Zmult_assoc;apply Z_div_plus_l;trivial. + split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. + rewrite spec_ww_add_mul_div;rewrite Zpos_minus. + change (Zpos (xO (w_digits))) with (2*Zpos (w_digits));zarith. + simpl ww_to_Z;rewrite Zmult_0_l;rewrite Zplus_0_l. + ring_simplify (2*Zpos (w_digits)-(2*Zpos (w_digits) - Zpos p));trivial. + rewrite Zmod_def_small;zarith. + split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. + Spec_ww_to_Z r. + apply Zlt_le_trans with wwB;zarith. + rewrite <- (Zmult_1_r wwB);apply Zmult_le_compat;zarith. + rewrite Zpos_xO;zarith. rewrite Zpos_xO;zarith. rewrite Zpos_xO;zarith. + Qed. + + Lemma spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> + let (q,r) := ww_div_gt a b in + [[a]] = [[q]] * [[b]] + [[r]] /\ + 0 <= [[r]] < [[b]]. + Proof. + intros a b Hgt Hpos;unfold ww_div_gt. + change (let (q,r) := match a, b with + | W0, _ => (W0,W0) + | _, W0 => (W0,W0) + | WW ah al, WW bh bl => + if w_eq0 ah then let (q,r) := w_div_gt al bl in (WW w_0 q, w_0W r) + else + match w_compare w_0 bh with + | Eq => + let(q,r):= + gen_divn1 w_digits w_0 w_WW w_head0 w_add_mul_div w_div21 1 a bl in + (q, w_0W r) + | Lt => ww_div_gt_aux ah al bh bl + | Gt => (W0,W0) (* cas absurde *) + end + end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). + destruct a as [ |ah al]. simpl in Hgt;omega. + destruct b as [ |bh bl]. simpl in Hpos;omega. + Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. + assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). + simpl ww_to_Z;rewrite H;trivial. simpl in Hgt;rewrite H in Hgt;trivial. + assert ([|bh|] <= 0). + apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. + assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;rewrite H1;simpl in Hgt. + simpl. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. + assert (H2:=spec_div_gt Hgt Hpos);destruct (w_div_gt al bl). + repeat rewrite spec_w_0W;simpl;rewrite spec_w_0;simpl;trivial. + clear H. + assert (Hcmp := spec_compare w_0 bh); destruct (w_compare w_0 bh). + rewrite spec_w_0 in Hcmp. change [[WW bh bl]] with ([|bh|]*wB+[|bl|]). + rewrite <- Hcmp;rewrite Zmult_0_l;rewrite Zplus_0_l. + simpl in Hpos;rewrite <- Hcmp in Hpos;simpl in Hpos. + assert (H2:= @spec_gen_divn1 w w_digits w_0 w_WW w_head0 w_add_mul_div + w_div21 w_to_Z spec_to_Z spec_w_0 spec_w_WW spec_head0 + spec_add_mul_div spec_div21 1 (WW ah al) bl Hpos). + unfold gen_to_Z,gen_wB,gen_digits in H2. + destruct (gen_divn1 w_digits w_0 w_WW w_head0 w_add_mul_div w_div21 1 + (WW ah al) bl). + rewrite spec_w_0W;unfold ww_to_Z;trivial. + apply spec_ww_div_gt_aux;trivial. rewrite spec_w_0 in Hcmp;trivial. + rewrite spec_w_0 in Hcmp;elimtype False;omega. + Qed. + + Lemma spec_ww_mod_gt_aux_eq : forall ah al bh bl, + ww_mod_gt_aux ah al bh bl = snd (ww_div_gt_aux ah al bh bl). + Proof. + intros ah al bh bl. unfold ww_mod_gt_aux, ww_div_gt_aux. + destruct (w_head0 bh). trivial. + destruct (w_div32 (w_add_mul_div p w_0 ah) (w_add_mul_div p ah al) + (w_add_mul_div p al w_0) (w_add_mul_div p bh bl) + (w_add_mul_div p bl w_0));trivial. + Qed. + + Lemma spec_ww_mod_gt_aux : forall ah al bh bl, + [[WW ah al]] > [[WW bh bl]] -> + 0 < [|bh|] -> + [[ww_mod_gt_aux ah al bh bl]] = [[WW ah al]] mod [[WW bh bl]]. + Proof. + intros. rewrite spec_ww_mod_gt_aux_eq;trivial. + assert (H3 := spec_ww_div_gt_aux ah al bl H H0). + destruct (ww_div_gt_aux ah al bh bl) as (q,r);simpl. simpl in H,H3. + destruct H3;apply Zmod_unique with [[q]];zarith. + rewrite H1;ring. + Qed. + + Lemma spec_w_mod_gt_eq : forall a b, [|a|] > [|b|] -> 0 <[|b|] -> + [|w_mod_gt a b|] = [|snd (w_div_gt a b)|]. + Proof. + intros a b Hgt Hpos. + rewrite spec_mod_gt;trivial. + assert (H:=spec_div_gt Hgt Hpos). + destruct (w_div_gt a b) as (q,r);simpl. + rewrite Zmult_comm in H;destruct H. + symmetry;apply Zmod_unique with [|q|];trivial. + Qed. + + Lemma spec_ww_mod_gt_eq : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> + [[ww_mod_gt a b]] = [[snd (ww_div_gt a b)]]. + Proof. + intros a b Hgt Hpos. + change (ww_mod_gt a b) with + (match a, b with + | W0, _ => W0 + | _, W0 => W0 + | WW ah al, WW bh bl => + if w_eq0 ah then w_0W (w_mod_gt al bl) + else + match w_compare w_0 bh with + | Eq => + w_0W (gen_modn1 w_digits w_0 w_head0 w_add_mul_div w_div21 1 a bl) + | Lt => ww_mod_gt_aux ah al bh bl + | Gt => W0 (* cas absurde *) + end + end). + change (ww_div_gt a b) with + (match a, b with + | W0, _ => (W0,W0) + | _, W0 => (W0,W0) + | WW ah al, WW bh bl => + if w_eq0 ah then let (q,r) := w_div_gt al bl in (WW w_0 q, w_0W r) + else + match w_compare w_0 bh with + | Eq => + let(q,r):= + gen_divn1 w_digits w_0 w_WW w_head0 w_add_mul_div w_div21 1 a bl in + (q, w_0W r) + | Lt => ww_div_gt_aux ah al bh bl + | Gt => (W0,W0) (* cas absurde *) + end + end). + destruct a as [ |ah al];trivial. + destruct b as [ |bh bl];trivial. + Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. + assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). + simpl in Hgt;rewrite H in Hgt;trivial. + assert ([|bh|] <= 0). + apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. + assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. + simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. + rewrite spec_w_0W;rewrite spec_w_mod_gt_eq;trivial. + destruct (w_div_gt al bl);simpl;rewrite spec_w_0W;trivial. + clear H. + assert (H2 := spec_compare w_0 bh);destruct (w_compare w_0 bh). + rewrite (@spec_gen_modn1_aux w w_digits w_0 w_WW w_head0 w_add_mul_div + w_div21 1 (WW ah al) bl). + destruct (gen_divn1 w_digits w_0 w_WW w_head0 w_add_mul_div w_div21 1 + (WW ah al) bl);simpl;trivial. + rewrite spec_ww_mod_gt_aux_eq;trivial;symmetry;trivial. + trivial. + Qed. + + Lemma spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> + [[ww_mod_gt a b]] = [[a]] mod [[b]]. + Proof. + intros a b Hgt Hpos. + assert (H:= spec_ww_div_gt a b Hgt Hpos). + rewrite (spec_ww_mod_gt_eq a b Hgt Hpos). + destruct (ww_div_gt a b)as(q,r);destruct H. + apply Zmod_unique with[[q]];simpl;trivial. + rewrite Zmult_comm;trivial. + Qed. + + Lemma Zis_gcd_mod : forall a b d, + 0 < b -> Zis_gcd b (a mod b) d -> Zis_gcd a b d. + Proof. + intros a b d H H1; apply Zis_gcd_for_euclid with (a/b). + pattern a at 1;rewrite (Z_div_mod_eq a b). + ring_simplify (b * (a / b) + a mod b - a / b * b);trivial. zarith. + Qed. + + Lemma spec_ww_gcd_gt_aux_body : + forall ah al bh bl n cont, + [[WW bh bl]] <= 2^n -> + [[WW ah al]] > [[WW bh bl]] -> + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> + Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_body cont ah al bh bl]]. + Proof. + intros ah al bh bl n cont Hlog Hgt Hcont. + change (ww_gcd_gt_body cont ah al bh bl) with (match w_compare w_0 bh with + | Eq => + match w_compare w_0 bl with + | Eq => WW ah al (* normalement n'arrive pas si forme normale *) + | Lt => + let m := gen_modn1 w_digits w_0 w_head0 w_add_mul_div w_div21 1 + (WW ah al) bl in + WW w_0 (w_gcd_gt bl m) + | Gt => W0 (* absurde *) + end + | Lt => + let m := ww_mod_gt_aux ah al bh bl in + match m with + | W0 => WW bh bl + | WW mh ml => + match w_compare w_0 mh with + | Eq => + match w_compare w_0 ml with + | Eq => WW bh bl + | _ => + let r := gen_modn1 w_digits w_0 w_head0 w_add_mul_div w_div21 1 + (WW bh bl) ml in + WW w_0 (w_gcd_gt ml r) + end + | Lt => + let r := ww_mod_gt_aux bh bl mh ml in + match r with + | W0 => m + | WW rh rl => cont mh ml rh rl + end + | Gt => W0 (* absurde *) + end + end + | Gt => W0 (* absurde *) + end). + assert (Hbh := spec_compare w_0 bh);destruct (w_compare w_0 bh). + simpl ww_to_Z in *. rewrite spec_w_0 in Hbh;rewrite <- Hbh; + rewrite Zmult_0_l;rewrite Zplus_0_l. + assert (Hbl := spec_compare w_0 bl); destruct (w_compare w_0 bl). + rewrite spec_w_0 in Hbl;rewrite <- Hbl;apply Zis_gcd_0. + simpl;rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l. + rewrite spec_w_0 in Hbl. + apply Zis_gcd_mod;zarith. + change ([|ah|] * wB + [|al|]) with (gen_to_Z w_digits w_to_Z 1 (WW ah al)). + rewrite <- (@spec_gen_modn1 w w_digits w_0 w_WW w_head0 w_add_mul_div + w_div21 w_to_Z spec_to_Z spec_w_0 spec_w_WW spec_head0 spec_add_mul_div + spec_div21 1 (WW ah al) bl Hbl). + apply spec_gcd_gt. rewrite spec_gen_modn1 with (w_WW := w_WW);trivial. + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + destruct (Z_mod_lt x y);zarith end. + rewrite spec_w_0 in Hbl;Spec_w_to_Z bl;elimtype False;omega. + rewrite spec_w_0 in Hbh;assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh). + assert (H2 : 0 < [[WW bh bl]]). + simpl;Spec_w_to_Z bl. apply Zlt_le_trans with ([|bh|]*wB);zarith. + apply Zmult_lt_0_compat;zarith. + apply Zis_gcd_mod;trivial. rewrite <- H. + simpl in *;destruct (ww_mod_gt_aux ah al bh bl) as [ |mh ml]. + simpl;apply Zis_gcd_0;zarith. + assert (Hmh := spec_compare w_0 mh);destruct (w_compare w_0 mh). + simpl;rewrite spec_w_0 in Hmh; rewrite <- Hmh;simpl. + assert (Hml := spec_compare w_0 ml);destruct (w_compare w_0 ml). + rewrite <- Hml;rewrite spec_w_0;simpl;apply Zis_gcd_0. + simpl;rewrite spec_w_0;simpl. + rewrite spec_w_0 in Hml. apply Zis_gcd_mod;zarith. + change ([|bh|] * wB + [|bl|]) with (gen_to_Z w_digits w_to_Z 1 (WW bh bl)). + rewrite <- (@spec_gen_modn1 w w_digits w_0 w_WW w_head0 w_add_mul_div + w_div21 w_to_Z spec_to_Z spec_w_0 spec_w_WW spec_head0 spec_add_mul_div + spec_div21 1 (WW bh bl) ml Hml). + apply spec_gcd_gt. rewrite spec_gen_modn1 with (w_WW := w_WW);trivial. + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + destruct (Z_mod_lt x y);zarith end. + rewrite spec_w_0 in Hml;Spec_w_to_Z ml;elimtype False;omega. + rewrite spec_w_0 in Hmh. assert ([[WW bh bl]] > [[WW mh ml]]). + rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + destruct (Z_mod_lt x y);zarith end. + assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh). + assert (H3 : 0 < [[WW mh ml]]). + simpl;Spec_w_to_Z ml. apply Zlt_le_trans with ([|mh|]*wB);zarith. + apply Zmult_lt_0_compat;zarith. + apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1. + destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0. + simpl;apply Hcont. simpl in H1;rewrite H1. + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + destruct (Z_mod_lt x y);zarith end. + apply Zle_trans with (2^n/2). + apply Zdiv_le_lower_bound;zarith. + apply Zle_trans with ([|bh|] * wB + [|bl|]);zarith. + assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Zlt_gt _ _ H3)). + assert (H4' : 0 <= [[WW bh bl]]/[[WW mh ml]]). + apply Zge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1. + pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'. + destruct (Zle_lt_or_eq _ _ H4'). + assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = + [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). + simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'. + assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). + simpl;pattern ([|mh|]*wB+[|ml|]) at 1;rewrite <- Zmult_1_r;zarith. + simpl in *;assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in H8; + zarith. + assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in *;zarith. + rewrite <- H4 in H3';rewrite Zmult_0_r in H3';simpl in H3';zarith. + pattern n at 1;replace n with (n-1+1);try ring. + rewrite Zpower_exp;zarith. change (2^1) with 2. + rewrite Z_div_mult;zarith. + assert (2^1 <= 2^n). change (2^1) with 2;zarith. + assert (H7 := @Zpower_le_monotone_inv 2 1 n);zarith. + rewrite spec_w_0 in Hmh;Spec_w_to_Z mh;elimtype False;zarith. + rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;elimtype False;zarith. + Qed. + + Lemma spec_ww_gcd_gt_aux : + forall p cont n, + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> + [[WW yh yl]] <= 2^n -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> + forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> + [[WW bh bl]] <= 2^(Zpos p + n) -> + Zis_gcd [[WW ah al]] [[WW bh bl]] + [[ww_gcd_gt_aux p cont ah al bh bl]]. + Proof. + induction p;intros cont n Hcont ah al bh bl Hgt Hs;simpl ww_gcd_gt_aux. + assert (0 < Zpos p). unfold Zlt;reflexivity. + apply spec_ww_gcd_gt_aux_body with (n := Zpos (xI p) + n); + trivial;rewrite Zpos_xI. + intros. apply IHp with (n := Zpos p + n);zarith. + intros. apply IHp with (n := n );zarith. + apply Zle_trans with (2 ^ (2* Zpos p + 1+ n -1));zarith. + apply Zpower_le_monotone2;zarith. + assert (0 < Zpos p). unfold Zlt;reflexivity. + apply spec_ww_gcd_gt_aux_body with (n := Zpos (xO p) + n );trivial. + rewrite (Zpos_xO p). + intros. apply IHp with (n := Zpos p + n - 1);zarith. + intros. apply IHp with (n := n -1 );zarith. + intros;apply Hcont;zarith. + apply Zle_trans with (2^(n-1));zarith. + apply Zpower_le_monotone2;zarith. + apply Zle_trans with (2 ^ (Zpos p + n -1));zarith. + apply Zpower_le_monotone2;zarith. + apply Zle_trans with (2 ^ (2*Zpos p + n -1));zarith. + apply Zpower_le_monotone2;zarith. + apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial. + rewrite Zplus_comm;trivial. + ring_simplify (n + 1 - 1);trivial. + Qed. + +End GenDivGt. + +Section GenDiv. + + Variable w : Set. + Variable w_digits : positive. + Variable ww_1 : zn2z w. + Variable ww_compare : zn2z w -> zn2z w -> comparison. + + Variable ww_div_gt : zn2z w -> zn2z w -> zn2z w * zn2z w. + Variable ww_mod_gt : zn2z w -> zn2z w -> zn2z w. + + Definition ww_div a b := + match ww_compare a b with + | Gt => ww_div_gt a b + | Eq => (ww_1, W0) + | Lt => (W0, a) + end. + + Definition ww_mod a b := + match ww_compare a b with + | Gt => ww_mod_gt a b + | Eq => W0 + | Lt => a + end. + + Variable w_to_Z : w -> Z. + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_ww_1 : [[ww_1]] = 1. + Variable spec_ww_compare : forall x y, + match ww_compare x y with + | Eq => [[x]] = [[y]] + | Lt => [[x]] < [[y]] + | Gt => [[x]] > [[y]] + end. + Variable spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> + let (q,r) := ww_div_gt a b in + [[a]] = [[q]] * [[b]] + [[r]] /\ + 0 <= [[r]] < [[b]]. + Variable spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> + [[ww_mod_gt a b]] = [[a]] mod [[b]]. + + Ltac Spec_w_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_to_Z x). + + Ltac Spec_ww_to_Z x := + let H:= fresh "HH" in + assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). + + Lemma spec_ww_div : forall a b, 0 < [[b]] -> + let (q,r) := ww_div a b in + [[a]] = [[q]] * [[b]] + [[r]] /\ + 0 <= [[r]] < [[b]]. + Proof. + intros a b Hpos;unfold ww_div. + assert (H:=spec_ww_compare a b);destruct (ww_compare a b). + simpl;rewrite spec_ww_1;split;zarith. + simpl;split;[ring|Spec_ww_to_Z a;zarith]. + apply spec_ww_div_gt;trivial. + Qed. + + Lemma spec_ww_mod : forall a b, 0 < [[b]] -> + [[ww_mod a b]] = [[a]] mod [[b]]. + Proof. + intros a b Hpos;unfold ww_mod. + assert (H := spec_ww_compare a b);destruct (ww_compare a b). + simpl;apply Zmod_unique with 1;try rewrite H;zarith. + Spec_ww_to_Z a;symmetry;apply Zmod_def_small;zarith. + apply spec_ww_mod_gt;trivial. + Qed. + + + Variable w_0 : w. + Variable w_1 : w. + Variable w_compare : w -> w -> comparison. + Variable w_eq0 : w -> bool. + Variable w_gcd_gt : w -> w -> w. + Variable _ww_digits : positive. + Variable spec_ww_digits_ : _ww_digits = xO w_digits. + Variable ww_gcd_gt_fix : + positive -> (w -> w -> w -> w -> zn2z w) -> + w -> w -> w -> w -> zn2z w. + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_1 : [|w_1|] = 1. + Variable spec_compare : + forall x y, + match w_compare x y with + | Eq => [|x|] = [|y|] + | Lt => [|x|] < [|y|] + | Gt => [|x|] > [|y|] + end. + Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. + Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> + Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. + Variable spec_gcd_gt_fix : + forall p cont n, + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> + [[WW yh yl]] <= 2^n -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> + forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> + [[WW bh bl]] <= 2^(Zpos p + n) -> + Zis_gcd [[WW ah al]] [[WW bh bl]] + [[ww_gcd_gt_fix p cont ah al bh bl]]. + + Definition gcd_cont (xh xl yh yl:w) := + match w_compare w_1 yl with + | Eq => ww_1 + | _ => WW xh xl + end. + + Lemma spec_gcd_cont : forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> + [[WW yh yl]] <= 1 -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[gcd_cont xh xl yh yl]]. + Proof. + intros xh xl yh yl Hgt' Hle. simpl in Hle. + assert ([|yh|] = 0). + change 1 with (0*wB+1) in Hle. + assert (0 <= 1 < wB). split;zarith. apply wB_pos. + assert (H1:= beta_lex _ _ _ _ _ Hle (spec_to_Z yl) H). + Spec_w_to_Z yh;zarith. + unfold gcd_cont;assert (Hcmpy:=spec_compare w_1 yl); + rewrite spec_w_1 in Hcmpy. + simpl;rewrite H;simpl;destruct (w_compare w_1 yl). + rewrite spec_ww_1;rewrite <- Hcmpy;apply Zis_gcd_mod;zarith. + rewrite <- (Zmod_unique ([|xh|]*wB+[|xl|]) 1 ([|xh|]*wB+[|xl|]) 0);zarith. + rewrite H in Hle; elimtype False;zarith. + assert ([|yl|] = 0). Spec_w_to_Z yl;zarith. + rewrite H0;simpl;apply Zis_gcd_0;trivial. + Qed. + + + Variable cont : w -> w -> w -> w -> zn2z w. + Variable spec_cont : forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> + [[WW yh yl]] <= 1 -> + Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]. + + Definition ww_gcd_gt a b := + match a, b with + | W0, _ => b + | _, W0 => a + | WW ah al, WW bh bl => + if w_eq0 ah then (WW w_0 (w_gcd_gt al bl)) + else ww_gcd_gt_fix _ww_digits cont ah al bh bl + end. + + Definition ww_gcd a b := + Eval lazy beta delta [ww_gcd_gt] in + match ww_compare a b with + | Gt => ww_gcd_gt a b + | Eq => a + | Lt => ww_gcd_gt b a + end. + + Lemma spec_ww_gcd_gt : forall a b, [[a]] > [[b]] -> + Zis_gcd [[a]] [[b]] [[ww_gcd_gt a b]]. + Proof. + intros a b Hgt;unfold ww_gcd_gt. + destruct a as [ |ah al]. simpl;apply Zis_gcd_sym;apply Zis_gcd_0. + destruct b as [ |bh bl]. simpl;apply Zis_gcd_0. + simpl in Hgt. generalize (@spec_eq0 ah);destruct (w_eq0 ah);intros. + simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl. + assert ([|bh|] <= 0). + apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. + Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. + rewrite H1;simpl;auto. clear H. + apply spec_gcd_gt_fix with (n:= 0);trivial. + rewrite Zplus_0_r;rewrite spec_ww_digits_. + change (2 ^ Zpos (xO w_digits)) with wwB. Spec_ww_to_Z (WW bh bl);zarith. + Qed. + + Lemma spec_ww_gcd : forall a b, Zis_gcd [[a]] [[b]] [[ww_gcd a b]]. + Proof. + intros a b. + change (ww_gcd a b) with + (match ww_compare a b with + | Gt => ww_gcd_gt a b + | Eq => a + | Lt => ww_gcd_gt b a + end). + assert (Hcmp := spec_ww_compare a b);destruct (ww_compare a b). + Spec_ww_to_Z b;rewrite Hcmp. + apply Zis_gcd_for_euclid with 1;zarith. + ring_simplify ([[b]] - 1 * [[b]]). apply Zis_gcd_0;zarith. + apply Zis_gcd_sym;apply spec_ww_gcd_gt;zarith. + apply spec_ww_gcd_gt;zarith. + Qed. + +End GenDiv. + diff --git a/theories/Ints/num/GenDivn1.v b/theories/Ints/num/GenDivn1.v new file mode 100644 index 000000000..4b54d825d --- /dev/null +++ b/theories/Ints/num/GenDivn1.v @@ -0,0 +1,489 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZDivModAux. +Require Import ZPowerAux. +Require Import Basic_type. +Require Import GenBase. + +Open Local Scope Z_scope. + +Section GENDIVN1. + + Variable w : Set. + Variable w_digits : positive. + Variable w_0 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_head0 : w -> N. + Variable w_add_mul_div : positive -> w -> w -> w. + Variable w_div21 : w -> w -> w -> w * w. + + (* ** For proofs ** *) + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[! n | x !]" := (gen_to_Z w_digits w_to_Z n x) + (at level 0, x at level 99). + Notation "[[ x ]]" := (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). + + Variable spec_to_Z : forall x, 0 <= [| x |] < wB. + Variable spec_0 : [|w_0|] = 0. + Variable spec_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ (Z_of_N (w_head0 x)) * [|x|] < wB. + Variable spec_add_mul_div : forall x y p, + Zpos p < Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (Zpower 2 (Zpos p)) + + [|y|] / (Zpower 2 ((Zpos w_digits) - (Zpos p)))) mod wB. + Variable spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + + Section DIVAUX. + Variable b2p : w. + Variable b2p_le : wB/2 <= [|b2p|]. + + Definition gen_divn1_0_aux n (divn1: w -> word w n -> word w n * w) r h := + let (hh,hl) := gen_split w_0 n h in + let (qh,rh) := divn1 r hh in + let (ql,rl) := divn1 rh hl in + (gen_WW w_WW n qh ql, rl). + + Fixpoint gen_divn1_0 (n:nat) : w -> word w n -> word w n * w := + match n return w -> word w n -> word w n * w with + | O => fun r x => w_div21 r x b2p + | S n => gen_divn1_0_aux n (gen_divn1_0 n) + end. + + Lemma spec_split : forall (n : nat) (x : zn2z (word w n)), + let (h, l) := gen_split w_0 n x in + [!S n | x!] = [!n | h!] * gen_wB w_digits n + [!n | l!]. + Proof (spec_gen_split w_0 w_digits w_to_Z spec_0). + + Lemma spec_gen_divn1_0 : forall n r a, + [|r|] < [|b2p|] -> + let (q,r') := gen_divn1_0 n r a in + [|r|] * gen_wB w_digits n + [!n|a!] = [!n|q!] * [|b2p|] + [|r'|] /\ + 0 <= [|r'|] < [|b2p|]. + Proof. + induction n;intros. + exact (spec_div21 a b2p_le H). + unfold gen_divn1_0, gen_divn1_0_aux;fold gen_divn1_0. + assert (H1 := spec_split n a);destruct (gen_split w_0 n a) as (hh,hl). + rewrite H1. + assert (H2 := IHn r hh H);destruct (gen_divn1_0 n r hh) as (qh,rh). + destruct H2. + assert ([|rh|] < [|b2p|]). omega. + assert (H4 := IHn rh hl H3);destruct (gen_divn1_0 n rh hl) as (ql,rl). + destruct H4;split;trivial. + rewrite spec_gen_WW;trivial. + rewrite <- gen_wB_wwB. + rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite H0;rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc. + rewrite H4;ring. + Qed. + + Definition gen_modn1_0_aux n (modn1:w -> word w n -> w) r h := + let (hh,hl) := gen_split w_0 n h in modn1 (modn1 r hh) hl. + + Fixpoint gen_modn1_0 (n:nat) : w -> word w n -> w := + match n return w -> word w n -> w with + | O => fun r x => snd (w_div21 r x b2p) + | S n => gen_modn1_0_aux n (gen_modn1_0 n) + end. + + Lemma spec_gen_modn1_0 : forall n r x, + gen_modn1_0 n r x = snd (gen_divn1_0 n r x). + Proof. + induction n;simpl;intros;trivial. + unfold gen_modn1_0_aux, gen_divn1_0_aux. + destruct (gen_split w_0 n x) as (hh,hl). + rewrite (IHn r hh). + destruct (gen_divn1_0 n r hh) as (qh,rh);simpl. + rewrite IHn. destruct (gen_divn1_0 n rh hl);trivial. + Qed. + + Variable p : positive. + Variable p_bounded : Zpos p < Zpos w_digits. + + Lemma spec_add_mul_divp : forall x y, + [| w_add_mul_div p x y |] = + ([|x|] * (Zpower 2 (Zpos p)) + + [|y|] / (Zpower 2 ((Zpos w_digits) - (Zpos p)))) mod wB. + Proof. + intros;apply spec_add_mul_div;auto. + Qed. + + Definition gen_divn1_p_aux n + (divn1 : w -> word w n -> word w n -> word w n * w) r h l := + let (hh,hl) := gen_split w_0 n h in + let (lh,ll) := gen_split w_0 n l in + let (qh,rh) := divn1 r hh hl in + let (ql,rl) := divn1 rh hl lh in + (gen_WW w_WW n qh ql, rl). + + Fixpoint gen_divn1_p (n:nat) : w -> word w n -> word w n -> word w n * w := + match n return w -> word w n -> word w n -> word w n * w with + | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p + | S n => gen_divn1_p_aux n (gen_divn1_p n) + end. + + Lemma p_lt_gen_digits : forall n, Zpos p < Zpos (gen_digits w_digits n). + Proof. + induction n;simpl. destruct p_bounded;trivial. + assert (0 < Zpos p). unfold Zlt;reflexivity. + rewrite Zpos_xO;auto with zarith. + Qed. + + Lemma spec_gen_divn1_p : forall n r h l, + [|r|] < [|b2p|] -> + let (q,r') := gen_divn1_p n r h l in + [|r|] * gen_wB w_digits n + + ([!n|h!]*2^(Zpos p) + + [!n|l!] / (2^(Zpos(gen_digits w_digits n) - Zpos p))) + mod gen_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\ + 0 <= [|r'|] < [|b2p|]. + Proof. + induction n;intros. + unfold gen_divn1_p, gen_divn1_p_aux, gen_to_Z, gen_wB, gen_digits. + rewrite <- spec_add_mul_divp. + exact (spec_div21 (w_add_mul_div p h l) b2p_le H). + unfold gen_divn1_p,gen_divn1_p_aux;fold gen_divn1_p. + assert (H1 := spec_split n h);destruct (gen_split w_0 n h) as (hh,hl). + rewrite H1. rewrite <- gen_wB_wwB. + assert (H2 := spec_split n l);destruct (gen_split w_0 n l) as (lh,ll). + rewrite H2. + replace ([|r|] * (gen_wB w_digits n * gen_wB w_digits n) + + (([!n|hh!] * gen_wB w_digits n + [!n|hl!]) * 2 ^ Zpos p + + ([!n|lh!] * gen_wB w_digits n + [!n|ll!]) / + 2^(Zpos (gen_digits w_digits (S n)) - Zpos p)) mod + (gen_wB w_digits n * gen_wB w_digits n)) with + (([|r|] * gen_wB w_digits n + ([!n|hh!] * 2^Zpos p + + [!n|hl!] / 2^(Zpos (gen_digits w_digits n) - Zpos p)) mod + gen_wB w_digits n) * gen_wB w_digits n + + ([!n|hl!] * 2^Zpos p + + [!n|lh!] / 2^(Zpos (gen_digits w_digits n) - Zpos p)) mod + gen_wB w_digits n). + generalize (IHn r hh hl H);destruct (gen_divn1_p n r hh hl) as (qh,rh); + intros (H3,H4);rewrite H3. + assert ([|rh|] < [|b2p|]). omega. + replace (([!n|qh!] * [|b2p|] + [|rh|]) * gen_wB w_digits n + + ([!n|hl!] * 2 ^ Zpos p + + [!n|lh!] / 2 ^ (Zpos (gen_digits w_digits n) - Zpos p)) mod + gen_wB w_digits n) with + ([!n|qh!] * [|b2p|] *gen_wB w_digits n + ([|rh|]*gen_wB w_digits n + + ([!n|hl!] * 2 ^ Zpos p + + [!n|lh!] / 2 ^ (Zpos (gen_digits w_digits n) - Zpos p)) mod + gen_wB w_digits n)). 2:ring. + generalize (IHn rh hl lh H0);destruct (gen_divn1_p n rh hl lh) as (ql,rl); + intros (H5,H6);rewrite H5. + split;[rewrite spec_gen_WW;trivial;ring|trivial]. + assert (Uhh := spec_gen_to_Z w_digits w_to_Z spec_to_Z n hh); + unfold gen_wB,base in Uhh. + assert (Uhl := spec_gen_to_Z w_digits w_to_Z spec_to_Z n hl); + unfold gen_wB,base in Uhl. + assert (Ulh := spec_gen_to_Z w_digits w_to_Z spec_to_Z n lh); + unfold gen_wB,base in Ulh. + assert (Ull := spec_gen_to_Z w_digits w_to_Z spec_to_Z n ll); + unfold gen_wB,base in Ull. + unfold gen_wB,base. + assert (UU:=p_lt_gen_digits n). + rewrite Zdiv_shift_r;auto with zarith. + 2:change (Zpos (gen_digits w_digits (S n))) + with (2*Zpos (gen_digits w_digits n));auto with zarith. + replace (2 ^ (Zpos (gen_digits w_digits (S n)) - Zpos p)) with + (2^(Zpos (gen_digits w_digits n) - Zpos p)*2^Zpos (gen_digits w_digits n)). + rewrite Zdiv_Zmult_compat_r;auto with zarith. + rewrite Zmult_plus_distr_l with (p:= 2^Zpos p). + pattern ([!n|hl!] * 2^Zpos p) at 2; + rewrite (shift_unshift_mod (Zpos(gen_digits w_digits n))(Zpos p)([!n|hl!])); + auto with zarith. + rewrite Zplus_assoc. + replace + ([!n|hh!] * 2^Zpos (gen_digits w_digits n)* 2^Zpos p + + ([!n|hl!] / 2^(Zpos (gen_digits w_digits n)-Zpos p)* + 2^Zpos(gen_digits w_digits n))) + with + (([!n|hh!] *2^Zpos p + gen_to_Z w_digits w_to_Z n hl / + 2^(Zpos (gen_digits w_digits n)-Zpos p)) + * 2^Zpos(gen_digits w_digits n));try (ring;fail). + rewrite <- Zplus_assoc. + rewrite <- (Zmod_shift_r (Zpos p));auto with zarith. + replace + (2 ^ Zpos (gen_digits w_digits n) * 2 ^ Zpos (gen_digits w_digits n)) with + (2 ^ (Zpos (gen_digits w_digits n) + Zpos (gen_digits w_digits n))). + rewrite (Zmod_shift_r (Zpos (gen_digits w_digits n)));auto with zarith. + replace (2 ^ (Zpos (gen_digits w_digits n) + Zpos (gen_digits w_digits n))) + with (2^Zpos(gen_digits w_digits n) *2^Zpos(gen_digits w_digits n)). + rewrite (Zmult_comm (([!n|hh!] * 2 ^ Zpos p + + [!n|hl!] / 2 ^ (Zpos (gen_digits w_digits n) - Zpos p)))). + rewrite Zmod_Zmult_compat_l;auto with zarith. + ring. + rewrite Zpower_exp;auto with zarith. + assert (0 < Zpos (gen_digits w_digits n)). unfold Zlt;reflexivity. + auto with zarith. + apply Z_mod_lt;auto with zarith. + rewrite Zpower_exp;auto with zarith. + split;auto with zarith. + apply Zdiv_lt_upper_bound;auto with zarith. + rewrite <- Zpower_exp;auto with zarith. + replace (Zpos p + (Zpos (gen_digits w_digits n) - Zpos p)) with + (Zpos(gen_digits w_digits n));auto with zarith. + assert (0 < Zpos p). unfold Zlt;reflexivity. auto with zarith. + rewrite <- Zpower_exp;auto with zarith. + replace (Zpos (gen_digits w_digits (S n)) - Zpos p) with + (Zpos (gen_digits w_digits n) - Zpos p + + Zpos (gen_digits w_digits n));trivial. + change (Zpos (gen_digits w_digits (S n))) with + (2*Zpos (gen_digits w_digits n)). ring. + Qed. + + Definition gen_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:= + let (hh,hl) := gen_split w_0 n h in + let (lh,ll) := gen_split w_0 n l in + modn1 (modn1 r hh hl) hl lh. + + Fixpoint gen_modn1_p (n:nat) : w -> word w n -> word w n -> w := + match n return w -> word w n -> word w n -> w with + | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) + | S n => gen_modn1_p_aux n (gen_modn1_p n) + end. + + Lemma spec_gen_modn1_p : forall n r h l , + gen_modn1_p n r h l = snd (gen_divn1_p n r h l). + Proof. + induction n;simpl;intros;trivial. + unfold gen_modn1_p_aux, gen_divn1_p_aux. + destruct(gen_split w_0 n h)as(hh,hl);destruct(gen_split w_0 n l) as (lh,ll). + rewrite (IHn r hh hl);destruct (gen_divn1_p n r hh hl) as (qh,rh). + rewrite IHn;simpl;destruct (gen_divn1_p n rh hl lh);trivial. + Qed. + + End DIVAUX. + + Fixpoint hight (n:nat) : word w n -> w := + match n return word w n -> w with + | O => fun a => a + | S n => + fun (a:zn2z (word w n)) => + match a with + | W0 => w_0 + | WW h l => hight n h + end + end. + + Lemma spec_gen_digits:forall n, Zpos w_digits <= Zpos (gen_digits w_digits n). + Proof. + induction n;simpl;auto with zarith. + change (Zpos (xO (gen_digits w_digits n))) with + (2*Zpos (gen_digits w_digits n)). + assert (0 < Zpos w_digits);auto with zarith. + exact (refl_equal Lt). + Qed. + + Lemma spec_hight : forall n (x:word w n), + [|hight n x|] = [!n|x!] / 2^(Zpos (gen_digits w_digits n) - Zpos w_digits). + Proof. + induction n;intros. + unfold hight,gen_digits,gen_to_Z. + replace (Zpos w_digits - Zpos w_digits) with 0;try ring. + simpl. rewrite <- (Zdiv_unique [|x|] 1 [|x|] 0);auto with zarith. + assert (U2 := spec_gen_digits n). + assert (U3 : 0 < Zpos w_digits). exact (refl_equal Lt). + destruct x;unfold hight;fold hight. + unfold gen_to_Z,zn2z_to_Z;rewrite spec_0. + rewrite Zdiv_0;trivial. + apply Zpower_lt_0;auto with zarith. + change (Zpos (gen_digits w_digits (S n))) with + (2*Zpos (gen_digits w_digits n)). + auto with zarith. + assert (U0 := spec_gen_to_Z w_digits w_to_Z spec_to_Z n w0); + assert (U1 := spec_gen_to_Z w_digits w_to_Z spec_to_Z n w1). + unfold gen_to_Z,zn2z_to_Z;fold (gen_to_Z w_digits w_to_Z). + unfold gen_wB,base;rewrite Zdiv_shift_r;auto with zarith. + replace (2 ^ (Zpos (gen_digits w_digits (S n)) - Zpos w_digits)) with + (2^(Zpos (gen_digits w_digits n) - Zpos w_digits) * + 2^Zpos (gen_digits w_digits n)). + rewrite Zdiv_Zmult_compat_r;auto with zarith. + rewrite <- Zpower_exp;auto with zarith. + replace (Zpos (gen_digits w_digits n) - Zpos w_digits + + Zpos (gen_digits w_digits n)) with + (Zpos (gen_digits w_digits (S n)) - Zpos w_digits);trivial. + change (Zpos (gen_digits w_digits (S n))) with + (2*Zpos (gen_digits w_digits n));ring. + change (Zpos (gen_digits w_digits (S n))) with + (2*Zpos (gen_digits w_digits n)); auto with zarith. + Qed. + + Definition gen_divn1 (n:nat) (a:word w n) (b:w) := + match w_head0 b with + | N0 => gen_divn1_0 b n w_0 a + | Npos p => + let b2p := w_add_mul_div p b w_0 in + let ha := hight n a in + let k := Pminus w_digits p in + let lsr_n := w_add_mul_div k w_0 in + let r0 := w_add_mul_div p w_0 ha in + let (q,r) := gen_divn1_p b2p p n r0 a (gen_0 w_0 n) in + (q, lsr_n r) + end. + + Lemma spec_gen_divn1 : forall n a b, + 0 < [|b|] -> + let (q,r) := gen_divn1 n a b in + [!n|a!] = [!n|q!] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + intros n a b H. unfold gen_divn1. + assert (H0 := spec_head0 H). + destruct (w_head0 b). + unfold Z_of_N, Zpower in H0. + rewrite Zmult_1_l in H0;destruct H0. + rewrite <- spec_0 in H. + assert (H2 := spec_gen_divn1_0 H0 n a H). + rewrite spec_0 in H2;rewrite Zmult_0_l in H2;rewrite Zplus_0_l in H2. + exact H2. + unfold Z_of_N in H0. + assert (HHHH : 0 < Zpos p). unfold Zlt;reflexivity. + assert (Zpos p < Zpos w_digits). + destruct (Z_lt_le_dec (Zpos p) (Zpos w_digits));trivial. + assert (2 ^ Zpos p < wB). + apply Zle_lt_trans with (2 ^ Zpos p * [|b|]);auto with zarith. + replace (2 ^ Zpos p) with (2^Zpos p * 1);try (ring;fail). + apply Zmult_le_compat;auto with zarith. + assert (wB <= 2^Zpos p). + unfold base;apply Zpower_le_monotone;auto with zarith. omega. + assert ([|w_add_mul_div p b w_0|] = 2 ^ Zpos p * [|b|]). + assert (H2 := spec_add_mul_div b w_0 H1). + rewrite spec_0 in H2;rewrite Zdiv_0 in H2; + rewrite Zplus_0_r in H2;rewrite Zmult_comm in H2. + rewrite Zmod_def_small in H2;auto with zarith. + apply Zpower_lt_0;auto with zarith. + destruct H0. + assert (H4 := spec_to_Z (hight n a)). + assert + ([|w_add_mul_div p w_0 (hight n a)|]<[|w_add_mul_div p b w_0|]). + rewrite H2. + rewrite spec_add_mul_div;auto with zarith. + rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. + assert (([|hight n a|]/2^(Zpos w_digits - Zpos p)) < wB). + apply Zdiv_lt_upper_bound;auto with zarith. + apply Zlt_le_trans with wB;auto with zarith. + pattern wB at 1;replace wB with (wB*1);try ring. + apply Zmult_le_compat;auto with zarith. + assert (H5 := Zpower_lt_0 2 (Zpos w_digits - Zpos p)); + auto with zarith. + rewrite Zmod_def_small;auto with zarith. + apply Zdiv_lt_upper_bound;auto with zarith. + apply Zlt_le_trans with wB;auto with zarith. + apply Zle_trans with (2 ^ Zpos p * [|b|] * 2). + rewrite <- wB_div_2;auto with zarith. + apply Zmult_le_compat;auto with zarith. + pattern 2 at 1;rewrite <- Zpower_exp_1. + apply Zpower_le_monotone;split;auto with zarith. + rewrite <- H2 in H0. + assert (H6:= spec_gen_divn1_p H0 H1 n a (gen_0 w_0 n) H5). + destruct (gen_divn1_p (w_add_mul_div p b w_0) p n + (w_add_mul_div p w_0 (hight n a)) a + (gen_0 w_0 n)) as (q,r). + assert (U:= spec_gen_digits n). + rewrite spec_gen_0 in H6;trivial;rewrite Zdiv_0 in H6. + rewrite Zplus_0_r in H6. + rewrite spec_add_mul_div in H6;auto with zarith. + rewrite spec_0 in H6;rewrite Zmult_0_l in H6;rewrite Zplus_0_l in H6. + assert (([|hight n a|] / 2 ^ (Zpos w_digits - Zpos p)) mod wB + = [!n|a!] / 2^(Zpos (gen_digits w_digits n) - Zpos p)). + rewrite Zmod_def_small;auto with zarith. + rewrite spec_hight. rewrite Zdiv_Zdiv;auto with zarith. + rewrite <- Zpower_exp;auto with zarith. + replace (Zpos (gen_digits w_digits n) - Zpos w_digits + + (Zpos w_digits - Zpos p)) + with (Zpos (gen_digits w_digits n) - Zpos p);trivial;ring. + assert (H7 := Zpower_lt_0 2 (Zpos w_digits - Zpos p));auto with zarith. + split;auto with zarith. + apply Zle_lt_trans with ([|hight n a|]);auto with zarith. + apply Zdiv_le_upper_bound;auto with zarith. + pattern ([|hight n a|]) at 1;rewrite <- Zmult_1_r. + apply Zmult_le_compat;auto with zarith. + rewrite H7 in H6;unfold gen_wB,base in H6. + rewrite <- shift_unshift_mod in H6;auto with zarith. + rewrite H2 in H6. + assert ([|w_add_mul_div (w_digits - p) w_0 r|] = [|r|]/2^Zpos p). + rewrite spec_add_mul_div. + rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. + replace (Zpos w_digits - Zpos (w_digits - p)) with (Zpos p). + rewrite Zmod_def_small;auto with zarith. + assert (H8 := spec_to_Z r). + split;auto with zarith. + apply Zle_lt_trans with ([|r|]);auto with zarith. + apply Zdiv_le_upper_bound;auto with zarith. + pattern ([|r|]) at 1;rewrite <- Zmult_1_r. + apply Zmult_le_compat;auto with zarith. + assert (H9 := Zpower_lt_0 2 (Zpos p));auto with zarith. + rewrite Zpos_minus;auto with zarith. + rewrite Zpos_minus;auto with zarith. + destruct H6. + split. + rewrite <- (Z_div_mult [!n|a!] (2^Zpos p));auto with zarith. + rewrite H8;rewrite H6. + replace ([!n|q!] * (2 ^ Zpos p * [|b|])) with ([!n|q!] *[|b|] * 2^Zpos p); + try (ring;fail). + rewrite Z_div_plus_l;auto with zarith. + assert (H10 := spec_to_Z (w_add_mul_div (w_digits - p) w_0 r));split; + auto with zarith. + rewrite H8. + apply Zdiv_lt_upper_bound;auto with zarith. + rewrite Zmult_comm;auto with zarith. + exact (spec_gen_to_Z w_digits w_to_Z spec_to_Z n a). + apply Zpower_lt_0;auto with zarith. + Qed. + + Definition gen_modn1 (n:nat) (a:word w n) (b:w) := + match w_head0 b with + | N0 => gen_modn1_0 b n w_0 a + | Npos p => + let b2p := w_add_mul_div p b w_0 in + let ha := hight n a in + let k := Pminus w_digits p in + let lsr_n := w_add_mul_div k w_0 in + let r0 := w_add_mul_div p w_0 ha in + let r := gen_modn1_p b2p p n r0 a (gen_0 w_0 n) in + lsr_n r + end. + + Lemma spec_gen_modn1_aux : forall n a b, + gen_modn1 n a b = snd (gen_divn1 n a b). + Proof. + intros n a b;unfold gen_divn1,gen_modn1. + destruct (w_head0 b). + apply spec_gen_modn1_0. + rewrite spec_gen_modn1_p. + destruct (gen_divn1_p (w_add_mul_div p b w_0) p n + (w_add_mul_div p w_0 (hight n a)) a (gen_0 w_0 n));simpl;trivial. + Qed. + + Lemma spec_gen_modn1 : forall n a b, 0 < [|b|] -> + [|gen_modn1 n a b|] = [!n|a!] mod [|b|]. + Proof. + intros n a b H;assert (H1 := spec_gen_divn1 n a H). + assert (H2 := spec_gen_modn1_aux n a b). + rewrite H2;destruct (gen_divn1 n a b) as (q,r). + simpl;apply Zmod_unique with (gen_to_Z w_digits w_to_Z n q);auto with zarith. + destruct H1 as (h1,h2);rewrite h1;ring. + Qed. + +End GENDIVN1. diff --git a/theories/Ints/num/GenLift.v b/theories/Ints/num/GenLift.v new file mode 100644 index 000000000..14aa86979 --- /dev/null +++ b/theories/Ints/num/GenLift.v @@ -0,0 +1,278 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZAux. +Require Import ZPowerAux. +Require Import ZDivModAux. +Require Import Basic_type. +Require Import GenBase. + +Open Local Scope Z_scope. + +Section GenLift. + Variable w : Set. + Variable w_0 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_W0 : w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_compare : w -> w -> comparison. + Variable w_head0 : w -> N. + Variable w_add_mul_div : positive -> w -> w -> w. + Variable w_digits : positive. + Variable ww_Digits : positive. + + Definition ww_head0 x := + match x with + | W0 => Npos ww_Digits + | WW xh xl => + match w_compare w_0 xh with + | Eq => Nplus (Npos w_digits) (w_head0 xl) + | _ => w_head0 xh + end + end. + + (* 0 < p < ww_digits *) + Definition ww_add_mul_div p x y := + match x, y with + | W0, W0 => W0 + | W0, WW yh yl => + match Pcompare p w_digits Eq with + | Eq => w_0W yh + | Lt => w_0W (w_add_mul_div p w_0 yh) + | Gt => + let n := Pminus p w_digits in + w_WW (w_add_mul_div n w_0 yh) (w_add_mul_div n yh yl) + end + | WW xh xl, W0 => + match Pcompare p w_digits Eq with + | Eq => w_W0 xl + | Lt => w_WW (w_add_mul_div p xh xl) (w_add_mul_div p xl w_0) + | Gt => + let n := Pminus p w_digits in + w_W0 (w_add_mul_div n xl w_0) + end + | WW xh xl, WW yh yl => + match Pcompare p w_digits Eq with + | Eq => w_WW xl yh + | Lt => w_WW (w_add_mul_div p xh xl) (w_add_mul_div p xl yh) + | Gt => + let n := Pminus p w_digits in + w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) + end + end. + + Section GenProof. + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. + Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. + Variable spec_compare : forall x y, + match w_compare x y with + | Eq => [|x|] = [|y|] + | Lt => [|x|] < [|y|] + | Gt => [|x|] > [|y|] + end. + Variable spec_ww_digits : ww_Digits = xO w_digits. + Variable spec_w_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ (Z_of_N (w_head0 x)) * [|x|] < wB. + Variable spec_w_add_mul_div : forall x y p, + Zpos p < Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (Zpower 2 (Zpos p)) + + [|y|] / (Zpower 2 ((Zpos w_digits) - (Zpos p)))) mod wB. + + + Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift. + Ltac zarith := auto with zarith lift. + + Lemma spec_ww_head0 : forall x, 0 < [[x]] -> + wwB/ 2 <= 2 ^ (Z_of_N (ww_head0 x)) * [[x]] < wwB. + Proof. + rewrite wwB_div_2;rewrite Zmult_comm;rewrite wwB_wBwB. + assert (U:= lt_0_wB w_digits); destruct x as [ |xh xl];simpl ww_to_Z;intros H. + unfold Zlt in H;discriminate H. + assert (H0 := spec_compare w_0 xh);rewrite spec_w_0 in H0. + simpl Z_of_N; destruct (w_compare w_0 xh). + rewrite <- H0. simpl Zplus. rewrite <- H0 in H;simpl in H. + generalize (spec_w_head0 H);destruct (w_head0 xl) as [ |q]. + intros H1;simpl Zpower in H1;rewrite Zmult_1_l in H1. + change (2 ^ Z_of_N (Npos w_digits)) with wB;split;zarith. + rewrite Zpower_2; apply Zmult_lt_compat_l;zarith. + unfold Z_of_N;intros. + change (Zpos(w_digits + q))with (Zpos w_digits + Zpos q);rewrite Zpower_exp. + fold wB;rewrite <- Zmult_assoc;split;zarith. + rewrite Zpower_2; apply Zmult_lt_compat_l;zarith. + intro H2;discriminate H2. intro H2;discriminate H2. + assert (H1 := spec_w_head0 H0). + split. + rewrite Zmult_plus_distr_r;rewrite Zmult_assoc. + apply Zle_trans with (2 ^ Z_of_N (w_head0 xh) * [|xh|] * wB). + rewrite Zmult_comm;zarith. + assert (0 <= 2 ^ Z_of_N (w_head0 xh) * [|xl|]);zarith. + assert (H2:=spec_to_Z xl);apply Zmult_le_0_compat;zarith. + assert (0<= Z_of_N (w_head0 xh)). + case (w_head0 xh);intros;simpl;intro H2;discriminate H2. + generalize (Z_of_N (w_head0 xh)) H1 H2;clear H1 H2;intros p H1 H2. + assert (Eq1 : 2^p < wB). + rewrite <- (Zmult_1_r (2^p));apply Zle_lt_trans with (2^p*[|xh|]);zarith. + assert (Eq2: p < Zpos w_digits). + destruct (Zle_or_lt (Zpos w_digits) p);trivial;contradict Eq1. + apply Zle_not_lt;unfold base;apply Zpower_le_monotone;zarith. + assert (Zpos w_digits = p + (Zpos w_digits - p)). ring. + rewrite Zpower_2. + unfold base at 2;rewrite H3;rewrite Zpower_exp;zarith. + rewrite <- Zmult_assoc; apply Zmult_lt_compat_l; zarith. + rewrite <- (Zplus_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith. + apply Zmult_lt_reg_r with (2 ^ p); zarith. + rewrite <- Zpower_exp;zarith. + rewrite Zmult_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith. + assert (H1 := spec_to_Z xh);zarith. + Qed. + + Hint Rewrite Zdiv_0 Zmult_0_l Zplus_0_l Zmult_0_r Zplus_0_r + spec_w_W0 spec_w_0W spec_w_WW spec_w_0 + (wB_div w_digits w_to_Z spec_to_Z) + (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite. + Ltac w_rewrite := autorewrite with w_rewrite;trivial. + + Lemma spec_ww_add_mul_div_aux : forall xh xl yh yl p, + Zpos p < Zpos (xO w_digits) -> + [[match (p ?= w_digits)%positive Eq with + | Eq => w_WW xl yh + | Lt => w_WW (w_add_mul_div p xh xl) (w_add_mul_div p xl yh) + | Gt => + let n := (p - w_digits)%positive in + w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) + end]] = + ([[WW xh xl]] * (2^Zpos p) + + [[WW yh yl]] / (2^(Zpos (xO w_digits) - Zpos p))) mod wwB. + Proof. + intros xh xl yh yl p;assert (HwwB := wwB_pos w_digits). + assert (0 < Zpos p). unfold Zlt;reflexivity. + replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits). + 2 : rewrite Zpos_xO;ring. + replace (Zpos w_digits + Zpos w_digits - Zpos p) with + (Zpos w_digits + (Zpos w_digits - Zpos p)). 2:ring. + intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl); + assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)); + simpl in Hx;assert (Hyh := spec_to_Z yh);assert (Hyl:=spec_to_Z yl); + assert (Hy:=spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW yh yl));simpl in Hy. + case_eq ((p ?= w_digits)%positive Eq);intros;w_rewrite; + match goal with + | [H: (p ?= w_digits)%positive Eq = Eq |- _] => + let H1:= fresh "H" in + (assert (H1 : Zpos p = Zpos w_digits); + [ rewrite Pcompare_Eq_eq with (1:= H);trivial + | rewrite H1;try rewrite Zminus_diag;try rewrite Zplus_0_r]); + fold wB + | [H: (p ?= w_digits)%positive Eq = Lt |- _] => + change ((p ?= w_digits)%positive Eq = Lt) with + (Zpos p < Zpos w_digits) in H; + repeat rewrite spec_w_add_mul_div;zarith + | [H: (p ?= w_digits)%positive Eq = Gt |- _] => + change ((p ?= w_digits)%positive Eq=Gt)with(Zpos p > Zpos w_digits) in H; + let H1 := fresh "H" in + assert (H1 := Zpos_minus _ _ (Zgt_lt _ _ H)); + replace (Zpos w_digits + (Zpos w_digits - Zpos p)) with + (Zpos w_digits - Zpos (p - w_digits)); + [ repeat rewrite spec_w_add_mul_div;zarith + | zarith ] + | _ => idtac + end;simpl ww_to_Z;w_rewrite;zarith. + rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;rewrite <- Zplus_assoc. + rewrite <- Zpower_2. + rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. apply lt_0_wwB. + exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring. + rewrite Zmult_plus_distr_l. + pattern ([|xl|] * 2 ^ Zpos p) at 2; + rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith. + replace ([|xh|] * wB * 2^Zpos p) with ([|xh|] * 2^Zpos p * wB). 2:ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. + unfold base at 5;rewrite <- Zmod_shift_r;zarith. + unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); + fold wB;fold wwB;zarith. + rewrite wwB_wBwB;rewrite Zpower_2; rewrite Zmult_mod_distr_r;zarith. + unfold ww_digits;rewrite Zpos_xO;zarith. apply Z_mod_lt;zarith. + split;zarith. apply Zdiv_lt_upper_bound;zarith. + rewrite <- Zpower_exp;zarith. + ring_simplify (Zpos p + (Zpos w_digits - Zpos p));fold wB;zarith. + pattern wB at 5;replace wB with + (2^(Zpos (p - w_digits) + (Zpos w_digits - Zpos (p - w_digits)))). + rewrite Zpower_exp;zarith. rewrite Zmult_assoc. + rewrite Z_div_plus_l;zarith. + rewrite shift_unshift_mod with (a:= [|yh|]) (p:= Zpos (p - w_digits)) + (n := Zpos w_digits);zarith. fold wB. + replace (Zpos p) with (Zpos (p - w_digits) + Zpos w_digits);zarith. + rewrite Zpower_exp;zarith. rewrite Zmult_assoc. fold wB. + repeat rewrite Zplus_assoc. rewrite <- Zmult_plus_distr_l. + repeat rewrite <- Zplus_assoc. + unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); + fold wB;fold wwB;zarith. + unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) + (b:= Zpos w_digits);fold wB;fold wwB;zarith. + rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_mod_distr_r;zarith. + rewrite Zmult_plus_distr_l. + replace ([|xh|] * wB * 2 ^ Zpos (p - w_digits)) with + ([|xh|]*2^Zpos(p - w_digits)*wB). 2:ring. + repeat rewrite <- Zplus_assoc. + rewrite (Zplus_comm ([|xh|] * 2 ^ Zpos (p - w_digits) * wB)). + rewrite Z_mod_plus;zarith. rewrite Zmod_mult_0;zarith. + unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. + split;zarith. apply Zdiv_lt_upper_bound;zarith. + rewrite <- Zpower_exp;zarith. + ring_simplify (Zpos (p - w_digits) + (Zpos w_digits - Zpos (p - w_digits))); fold + wB;zarith. unfold ww_digits;rewrite Zpos_xO;zarith. + unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. + split;zarith. apply Zdiv_lt_upper_bound;zarith. + rewrite <- Zpower_exp;zarith. + ring_simplify (Zpos (p - w_digits) + (Zpos w_digits - Zpos (p - w_digits))); fold + wB;zarith. + ring_simplify (Zpos (p - w_digits) + (Zpos w_digits - Zpos (p - w_digits))); fold + wB;trivial. + Qed. + + Lemma spec_ww_add_mul_div : forall x y p, + Zpos p < Zpos (xO w_digits) -> + [[ ww_add_mul_div p x y ]] = + ([[x]] * (2^Zpos p) + + [[y]] / (2^(Zpos (xO w_digits) - Zpos p))) mod wwB. + Proof. + intros x y p H. + destruct x as [ |xh xl]; + [assert (H1 := @spec_ww_add_mul_div_aux w_0 w_0) + |assert (H1 := @spec_ww_add_mul_div_aux xh xl)]; + (destruct y as [ |yh yl]; + [generalize (H1 w_0 w_0 p H) | generalize (H1 yh yl p H)]; + clear H1;w_rewrite);simpl ww_add_mul_div. + replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. + intros Heq;rewrite <- Heq;clear Heq. + case_eq ((p ?= w_digits)%positive Eq);w_rewrite;intros;trivial. + rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. + replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. + intros Heq;rewrite <- Heq;clear Heq. + case_eq ((p ?= w_digits)%positive Eq);w_rewrite;intros;trivial. + rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. + change ((p ?= w_digits)%positive Eq = Gt)with(Zpos p > Zpos w_digits) in H0. + rewrite Zpos_minus;zarith. rewrite Zpos_xO in H;zarith. + Qed. + + End GenProof. + +End GenLift. + diff --git a/theories/Ints/num/GenMul.v b/theories/Ints/num/GenMul.v new file mode 100644 index 000000000..d30396550 --- /dev/null +++ b/theories/Ints/num/GenMul.v @@ -0,0 +1,623 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZAux. +Require Import ZDivModAux. +Require Import Basic_type. +Require Import GenBase. + +Open Local Scope Z_scope. + +Section GenMul. + Variable w : Set. + Variable w_0 : w. + Variable w_1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_W0 : w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_compare : w -> w -> comparison. + Variable w_succ : w -> w. + Variable w_add_c : w -> w -> carry w. + Variable w_add : w -> w -> w. + Variable w_sub: w -> w -> w. + Variable w_mul_c : w -> w -> zn2z w. + Variable w_mul : w -> w -> w. + Variable w_square_c : w -> zn2z w. + Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). + Variable ww_add : zn2z w -> zn2z w -> zn2z w. + Variable ww_add_carry : zn2z w -> zn2z w -> zn2z w. + Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). + Variable ww_sub : zn2z w -> zn2z w -> zn2z w. + + (* ** Multiplication ** *) + + (* (xh*B+xl) (yh*B + yl) + xh*yh = hh = |hhh|hhl|B2 + xh*yl +xl*yh = cc = |cch|ccl|B + xl*yl = ll = |llh|lll + *) + + Definition gen_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y := + match x, y with + | W0, _ => W0 + | _, W0 => W0 + | WW xh xl, WW yh yl => + let hh := w_mul_c xh yh in + let ll := w_mul_c xl yl in + let (wc,cc) := cross xh xl yh yl hh ll in + match cc with + | W0 => WW (ww_add hh (w_W0 wc)) ll + | WW cch ccl => + match ww_add_c (w_W0 ccl) ll with + | C0 l => WW (ww_add hh (w_WW wc cch)) l + | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l + end + end + end. + + Definition ww_mul_c := + gen_mul_c + (fun xh xl yh yl hh ll=> + match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with + | C0 cc => (w_0, cc) + | C1 cc => (w_1, cc) + end). + + Definition w_2 := w_add w_1 w_1. + + Definition kara_prod xh xl yh yl hh ll := + match ww_add_c hh ll with + C0 m => + match w_compare xl xh with + Eq => (w_0, m) + | Lt => + match w_compare yl yh with + Eq => (w_0, m) + | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl))) + | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with + C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) + end + end + | Gt => + match w_compare yl yh with + Eq => (w_0, m) + | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with + C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) + end + | Gt => (w_0, ww_sub m (w_mul_c (w_sub xl xh) (w_sub yl yh))) + end + end + | C1 m => + match w_compare xl xh with + Eq => (w_1, m) + | Lt => + match w_compare yl yh with + Eq => (w_1, m) + | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with + C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1) + end + | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with + C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) + end + end + | Gt => + match w_compare yl yh with + Eq => (w_1, m) + | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with + C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) + end + | Gt => match ww_sub_c m (w_mul_c (w_sub xl xh) (w_sub yl yh)) with + C1 m1 => (w_0, m1) | C0 m1 => (w_1, m1) + end + end + end + end. + + Definition ww_karatsuba_c := gen_mul_c kara_prod. + + Definition ww_mul x y := + match x, y with + | W0, _ => W0 + | _, W0 => W0 + | WW xh xl, WW yh yl => + let ccl := w_add (w_mul xh yl) (w_mul xl yh) in + ww_add (w_W0 ccl) (w_mul_c xl yl) + end. + + Definition ww_square_c x := + match x with + | W0 => W0 + | WW xh xl => + let hh := w_square_c xh in + let ll := w_square_c xl in + let xhxl := w_mul_c xh xl in + let (wc,cc) := + match ww_add_c xhxl xhxl with + | C0 cc => (w_0, cc) + | C1 cc => (w_1, cc) + end in + match cc with + | W0 => WW (ww_add hh (w_W0 wc)) ll + | WW cch ccl => + match ww_add_c (w_W0 ccl) ll with + | C0 l => WW (ww_add hh (w_WW wc cch)) l + | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l + end + end + end. + + Section GenMulAddn1. + Variable w_mul_add : w -> w -> w -> w * w. + + Fixpoint gen_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n := + match n return word w n -> w -> w -> w * word w n with + | O => w_mul_add + | S n1 => + let mul_add := gen_mul_add_n1 n1 in + fun x y r => + match x with + | W0 => (w_0,extend w_0W n1 r) + | WW xh xl => + let (rl,l) := mul_add xl y r in + let (rh,h) := mul_add xh y rl in + (rh, gen_WW w_WW n1 h l) + end + end. + + End GenMulAddn1. + + Section GenMulAddmn1. + Variable wn: Set. + Variable extend_n : w -> wn. + Variable wn_0W : wn -> zn2z wn. + Variable wn_WW : wn -> wn -> zn2z wn. + Variable w_mul_add_n1 : wn -> w -> w -> w*wn. + Fixpoint gen_mul_add_mn1 (m:nat) : + word wn m -> w -> w -> w*word wn m := + match m return word wn m -> w -> w -> w*word wn m with + | O => w_mul_add_n1 + | S m1 => + let mul_add := gen_mul_add_mn1 m1 in + fun x y r => + match x with + | W0 => (w_0,extend wn_0W m1 (extend_n r)) + | WW xh xl => + let (rl,l) := mul_add xl y r in + let (rh,h) := mul_add xh y rl in + (rh, gen_WW wn_WW m1 h l) + end + end. + + End GenMulAddmn1. + + Definition w_mul_add x y r := + match w_mul_c x y with + | W0 => (w_0, r) + | WW h l => + match w_add_c l r with + | C0 lr => (h,lr) + | C1 lr => (w_succ h, lr) + end + end. + + + (*Section GenProof. *) + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + Variable more_than_one_bit: 1 < Zpos w_digits. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). + Notation "[-| c |]" := + (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Notation "[|| x ||]" := + (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). + + Notation "[! n | x !]" := (gen_to_Z w_digits w_to_Z n x) + (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_1 : [|w_1|] = 1. + + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. + Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. + Variable spec_w_compare : + forall x y, + match w_compare x y with + | Eq => [|x|] = [|y|] + | Lt => [|x|] < [|y|] + | Gt => [|x|] > [|y|] + end. + Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. + Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. + Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. + Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + + Variable spec_w_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. + Variable spec_w_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB. + Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. + + Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. + Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. + Variable spec_ww_add_carry : + forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. + Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. + Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. + + + Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. + Proof. intros x;apply spec_ww_to_Z;auto. Qed. + + Lemma spec_ww_to_Z_wBwB : forall x, 0 <= [[x]] < wB^2. + Proof. rewrite <- wwB_wBwB;apply spec_ww_to_Z. Qed. + + Hint Resolve spec_ww_to_Z spec_ww_to_Z_wBwB : mult. + Ltac zarith := auto with zarith mult. + + Lemma wBwB_lex: forall a b c d, + a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> + a <= c. + Proof. + intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith. + Qed. + + Lemma wBwB_lex_inv: forall a b c d, + a < c -> + a * wB^2 + [[b]] < c * wB^2 + [[d]]. + Proof. + intros a b c d H; apply beta_lex_inv; zarith. + Qed. + + Lemma sum_mul_carry : forall xh xl yh yl wc cc, + [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> + 0 <= [|wc|] <= 1. + Proof. + intros. + apply (sum_mul_carry [|xh|] [|xl|] [|yh|] [|yl|] [|wc|][[cc]] wB);zarith. + apply wB_pos. + Qed. + + Theorem mult_add_ineq: forall xH yH crossH, + 0 <= [|xH|] * [|yH|] + [|crossH|] < wwB. + Proof. + intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith. + Qed. + + Hint Resolve mult_add_ineq : mult. + + Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll, + [[hh]] = [|xh|] * [|yh|] -> + [[ll]] = [|xl|] * [|yl|] -> + [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> + [||match cc with + | W0 => WW (ww_add hh (w_W0 wc)) ll + | WW cch ccl => + match ww_add_c (w_W0 ccl) ll with + | C0 l => WW (ww_add hh (w_WW wc cch)) l + | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l + end + end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]). + Proof. + intros;assert (U1 := wB_pos w_digits). + replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with + ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]). + 2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0. + assert (H2 := sum_mul_carry _ _ _ _ _ _ H1). + destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z. + rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_def_small; + rewrite wwB_wBwB. ring. + rewrite <- (Zplus_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith. + simpl ww_to_Z in H1. assert (U:=spec_to_Z cch). + assert ([|wc|]*wB + [|cch|] <= 2*wB - 3). + destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3));trivial. + assert ([|xh|] * [|yl|] + [|xl|] * [|yh|] <= (2*wB - 4)*wB + 2). + ring_simplify ((2*wB - 4)*wB + 2). + assert (H4 := Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). + assert (H5 := Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). + omega. + generalize H3;clear H3;rewrite <- H1. + rewrite Zplus_assoc; rewrite Zpower_2; rewrite Zmult_assoc; + rewrite <- Zmult_plus_distr_l. + assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB). + apply Zmult_le_compat;zarith. + rewrite Zmult_plus_distr_l in H3. + intros. assert (U2 := spec_to_Z ccl);omega. + generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll) + as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Zmult_1_l; + simpl zn2z_to_Z; + try rewrite spec_ww_add;try rewrite spec_ww_add_carry;rewrite spec_w_WW; + rewrite Zmod_def_small;rewrite wwB_wBwB;intros. + rewrite H4;ring. rewrite H;apply mult_add_ineq2;zarith. + rewrite Zplus_assoc;rewrite Zmult_plus_distr_l. + rewrite Zmult_1_l;rewrite <- Zplus_assoc;rewrite H4;ring. + repeat rewrite <- Zplus_assoc;rewrite H;apply mult_add_ineq2;zarith. + Qed. + + Lemma spec_gen_mul_c : forall cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w, + (forall xh xl yh yl hh ll, + [[hh]] = [|xh|]*[|yh|] -> + [[ll]] = [|xl|]*[|yl|] -> + let (wc,cc) := cross xh xl yh yl hh ll in + [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> + forall x y, [||gen_mul_c cross x y||] = [[x]] * [[y]]. + Proof. + intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial. + destruct y as [ |yh yl];simpl. rewrite Zmult_0_r;trivial. + assert (H1:= spec_w_mul_c xh yh);assert (H2:= spec_w_mul_c xl yl). + generalize (Hcross _ _ _ _ _ _ H1 H2). + destruct (cross xh xl yh yl (w_mul_c xh yh) (w_mul_c xl yl)) as (wc,cc). + intros;apply spec_mul_aux;trivial. + rewrite <- wwB_wBwB;trivial. + Qed. + + Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. + Proof. + intros x y;unfold ww_mul_c;apply spec_gen_mul_c. + intros xh xl yh yl hh ll H1 H2. + generalize (spec_ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)); + destruct (ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)) as [c|c]; + unfold interp_carry;repeat rewrite spec_w_mul_c;intros H; + (rewrite spec_w_0 || rewrite spec_w_1);rewrite H;ring. + Qed. + + Lemma spec_w_2: [|w_2|] = 2. + unfold w_2; rewrite spec_w_add; rewrite spec_w_1; simpl. + apply Zmod_def_small; split; auto with zarith. + rewrite <- (Zpower_exp_1 2); unfold base; apply Zpower_lt_monotone; auto with zarith. + Qed. + + Lemma kara_prod_aux : forall xh xl yh yl, + xh*yh + xl*yl - (xh-xl)*(yh-yl) = xh*yl + xl*yh. + Proof. intros;ring. Qed. + + Lemma spec_kara_prod : forall xh xl yh yl hh ll, + [[hh]] = [|xh|]*[|yh|] -> + [[ll]] = [|xl|]*[|yl|] -> + let (wc,cc) := kara_prod xh xl yh yl hh ll in + [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]. + Proof. + intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; + rewrite <- H; rewrite <- H0; unfold kara_prod. + assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); + assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)). + generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll); + intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)). + generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh; + try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail). + generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh; + try rewrite Hylh; try rewrite spec_w_0; try (ring; fail). + repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + split; auto with zarith. + simpl in Hz; rewrite Hz; rewrite H; rewrite H0. + rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith. + apply Zle_lt_trans with ([[z]]-0); auto with zarith. + unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive. + apply Zmult_le_0_compat; auto with zarith. + match goal with |- context[ww_add_c ?x ?y] => + generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2; + repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh; + try rewrite Hylh; try rewrite spec_w_0; try (ring; fail). + match goal with |- context[ww_add_c ?x ?y] => + generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2; + repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + split. + match goal with |- context[(?x - ?y) * (?z - ?t)] => + replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] + end. + simpl in Hz; rewrite Hz; rewrite H; rewrite H0. + rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith. + apply Zle_lt_trans with ([[z]]-0); auto with zarith. + unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive. + apply Zmult_le_0_compat; auto with zarith. + (** there is a carry in hh + ll **) + rewrite Zmult_1_l. + generalize (spec_w_compare xl xh); case (w_compare xl xh); intros Hxlh; + try rewrite Hxlh; try rewrite spec_w_1; try (ring; fail). + generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh; + try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). + match goal with |- context[ww_sub_c ?x ?y] => + generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l. + generalize Hz2; clear Hz2; unfold interp_carry. + repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + match goal with |- context[ww_add_c ?x ?y] => + generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + rewrite spec_w_2; unfold interp_carry in Hz2. + apply trans_equal with (wwB + (1 * wwB + [[z1]])). + ring. + rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh; + try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). + match goal with |- context[ww_add_c ?x ?y] => + generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + rewrite spec_w_2; unfold interp_carry in Hz2. + apply trans_equal with (wwB + (1 * wwB + [[z1]])). + ring. + rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + match goal with |- context[ww_sub_c ?x ?y] => + generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1; + intros z1 Hz2 + end. + simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l. + match goal with |- context[(?x - ?y) * (?z - ?t)] => + replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] + end. + generalize Hz2; clear Hz2; unfold interp_carry. + repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). + repeat rewrite Zmod_def_small; auto with zarith; try (ring; fail). + Qed. + + Lemma sub_carry : forall xh xl yh yl z, + 0 <= z -> + [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z -> + z < wwB. + Proof. + intros xh xl yh yl z Hle Heq. + destruct (Z_le_gt_dec wwB z);auto with zarith. + generalize (Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). + generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). + rewrite <- wwB_wBwB;intros H1 H2. + assert (H3 := wB_pos w_digits). + assert (2*wB <= wwB). + rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat;zarith. + omega. + Qed. + + Ltac Spec_ww_to_Z x := + let H:= fresh "H" in + assert (H:= spec_ww_to_Z x). + + Ltac Zmult_lt_b x y := + let H := fresh "H" in + assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). + + Lemma spec_ww_karatsuba_c : forall x y, [||ww_karatsuba_c x y||]=[[x]]*[[y]]. + Proof. + intros x y; unfold ww_karatsuba_c;apply spec_gen_mul_c. + intros; apply spec_kara_prod; auto. + Qed. + + Lemma spec_ww_mul : forall x y, [[ww_mul x y]] = [[x]]*[[y]] mod wwB. + Proof. + assert (U:= lt_0_wB w_digits). + assert (U1:= lt_0_wwB w_digits). + intros x y; case x; auto; intros xh xl. + case y; auto. + simpl; rewrite Zmult_0_r; rewrite Zmod_def_small; auto with zarith. + intros yh yl;simpl. + repeat (rewrite spec_ww_add || rewrite spec_w_W0 || rewrite spec_w_mul_c + || rewrite spec_w_add || rewrite spec_w_mul). + rewrite <- Zmod_plus; auto with zarith. + repeat (rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r). + rewrite <- Zmult_mod_distr_r; auto with zarith. + rewrite <- Zpower_2; rewrite <- wwB_wBwB; auto with zarith. + rewrite Zmod_plus; auto with zarith. + rewrite Zmod_mod; auto with zarith. + rewrite <- Zmod_plus; auto with zarith. + match goal with |- ?X mod _ = _ => + rewrite <- Z_mod_plus with (a := X) (b := [|xh|] * [|yh|]) + end; auto with zarith. + eq_tac; auto; rewrite wwB_wBwB; ring. + Qed. + + Lemma spec_ww_square_c : forall x, [||ww_square_c x||] = [[x]]*[[x]]. + Proof. + destruct x as [ |xh xl];simpl;trivial. + case_eq match ww_add_c (w_mul_c xh xl) (w_mul_c xh xl) with + | C0 cc => (w_0, cc) + | C1 cc => (w_1, cc) + end;intros wc cc Heq. + apply (spec_mul_aux xh xl xh xl wc cc);trivial. + generalize Heq (spec_ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));clear Heq. + rewrite spec_w_mul_c;destruct (ww_add_c (w_mul_c xh xl) (w_mul_c xh xl)); + unfold interp_carry;try rewrite Zmult_1_l;intros Heq Heq';inversion Heq; + rewrite (Zmult_comm [|xl|]);subst. + rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l;trivial. + rewrite spec_w_1;rewrite Zmult_1_l;rewrite <- wwB_wBwB;trivial. + Qed. + + Section GenMulAddn1Proof. + + Variable w_mul_add : w -> w -> w -> w * w. + Variable spec_w_mul_add : forall x y r, + let (h,l):= w_mul_add x y r in + [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. + + Lemma spec_gen_mul_add_n1 : forall n x y r, + let (h,l) := gen_mul_add_n1 w_mul_add n x y r in + [|h|]*gen_wB w_digits n + [!n|l!] = [!n|x!]*[|y|]+[|r|]. + Proof. + induction n;intros x y r;trivial. + exact (spec_w_mul_add x y r). + unfold gen_mul_add_n1;destruct x as[ |xh xl]; + fold(gen_mul_add_n1 w_mul_add). + rewrite spec_w_0;rewrite spec_extend;simpl;trivial. + assert(H:=IHn xl y r);destruct (gen_mul_add_n1 w_mul_add n xl y r)as(rl,l). + assert(U:=IHn xh y rl);destruct(gen_mul_add_n1 w_mul_add n xh y rl)as(rh,h). + rewrite <- gen_wB_wwB. rewrite spec_gen_WW;simpl;trivial. + rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc;rewrite <- H. + rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite U;ring. + Qed. + + End GenMulAddn1Proof. + + Lemma spec_w_mul_add : forall x y r, + let (h,l):= w_mul_add x y r in + [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. + Proof. + intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y); + destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H. + rewrite spec_w_0;trivial. + assert (U:=spec_w_add_c l r);destruct (w_add_c l r) as [lr|lr];unfold + interp_carry in U;try rewrite Zmult_1_l in H;simpl. + rewrite U;ring. rewrite spec_w_succ. rewrite Zmod_def_small. + rewrite <- Zplus_assoc;rewrite <- U;ring. + simpl in H;assert (H1:= Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). + rewrite <- H in H1. + assert (H2:=spec_to_Z h);split;zarith. + case H1;clear H1;intro H1;clear H1. + replace (wB ^ 2 - 2 * wB) with ((wB - 2)*wB). 2:ring. + intros H0;assert (U1:= wB_pos w_digits). + assert (H1 := beta_lex _ _ _ _ _ H0 (spec_to_Z l));zarith. + Qed. + +(* End GenProof. *) + +End GenMul. diff --git a/theories/Ints/num/GenSqrt.v b/theories/Ints/num/GenSqrt.v new file mode 100644 index 000000000..074f7eb53 --- /dev/null +++ b/theories/Ints/num/GenSqrt.v @@ -0,0 +1,1312 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZAux. +Require Import ZDivModAux. +Require Import Basic_type. +Require Import GenBase. + +Open Local Scope Z_scope. + +Section GenSqrt. + Variable w : Set. + Variable w_is_even : w -> bool. + Variable w_compare : w -> w -> comparison. + Variable w_0 : w. + Variable w_1 : w. + Variable w_Bm1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable w_W0 : w -> zn2z w. + Variable w_0W : w -> zn2z w. + Variable w_sub : w -> w -> w. + Variable w_sub_c : w -> w -> carry w. + Variable w_square_c : w -> zn2z w. + Variable w_div21 : w -> w -> w -> w * w. + Variable w_add_mul_div : positive -> w -> w -> w. + Variable w_digits : positive. + Variable w_add_c : w -> w -> carry w. + Variable w_sqrt2 : w -> w -> w * carry w. + Variable ww_pred_c : zn2z w -> carry (zn2z w). + Variable ww_pred : zn2z w -> zn2z w. + Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). + Variable ww_add : zn2z w -> zn2z w -> zn2z w. + Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). + Variable ww_add_mul_div : positive -> zn2z w -> zn2z w -> zn2z w. + Variable ww_head0 : zn2z w -> N. + Variable ww_compare : zn2z w -> zn2z w -> comparison. + + Let wwBm1 := ww_Bm1 w_Bm1. + + Definition ww_is_even x := + match x with + | W0 => true + | WW xh xl => w_is_even xl + end. + + Let w_div21c x y z := + match w_compare x z with + | Eq => + match w_compare y z with + Eq => (C1 w_1, w_0) + | Gt => (C1 w_1, w_sub y z) + | Lt => (C1 w_0, y) + end + | Gt => + let x1 := w_sub x z in + let (q, r) := w_div21 x1 y z in + (C1 q, r) + | Lt => + let (q, r) := w_div21 x y z in + (C0 q, r) + end. + + Let w_div2s x y s := + match x with + C1 x1 => + let x2 := w_sub x1 s in + let (q, r) := w_div21c x2 y s in + match q with + C0 q1 => + if w_is_even q1 then + (C0 (w_add_mul_div (w_digits - 1) w_1 q1), C0 r) + else + (C0 (w_add_mul_div (w_digits - 1) w_1 q1), w_add_c r s) + | C1 q1 => + if w_is_even q1 then + (C1 (w_add_mul_div (w_digits - 1) w_0 q1), C0 r) + else + (C1 (w_add_mul_div (w_digits - 1) w_0 q1), w_add_c r s) + end + | C0 x1 => + let (q, r) := w_div21c x1 y s in + match q with + C0 q1 => + if w_is_even q1 then + (C0 (w_add_mul_div (w_digits - 1) w_0 q1), C0 r) + else + (C0 (w_add_mul_div (w_digits - 1) w_0 q1), w_add_c r s) + | C1 q1 => + if w_is_even q1 then + (C0 (w_add_mul_div (w_digits - 1) w_1 q1), C0 r) + else + (C0 (w_add_mul_div (w_digits - 1) w_1 q1), w_add_c r s) + end + end. + + Definition split x := + match x with + | W0 => (w_0,w_0) + | WW h l => (h,l) + end. + + Definition ww_sqrt2 x y := + let (x1, x2) := split x in + let (y1, y2) := split y in + let ( q, r) := w_sqrt2 x1 x2 in + let (q1, r1) := w_div2s r y1 q in + match q1 with + C0 q1 => + let q2 := w_square_c q1 in + let a := WW q q1 in + match r1 with + C1 r2 => + match ww_sub_c (WW r2 y2) q2 with + C0 r3 => (a, C1 r3) + | C1 r3 => (a, C0 r3) + end + | C0 r2 => + match ww_sub_c (WW r2 y2) q2 with + C0 r3 => (a, C0 r3) + | C1 r3 => + let a2 := ww_add_mul_div 1 a W0 in + match ww_pred_c a2 with + C0 a3 => + (ww_pred a, ww_add_c a3 r3) + | C1 a3 => + (ww_pred a, C0 (ww_add a3 r3)) + end + end + end + | C1 q1 => + let a1 := WW q w_Bm1 in + let a2 := ww_add_mul_div 1 a1 wwBm1 in + (a1, ww_add_c a2 y) + end. + + Definition ww_is_zero x := + match ww_compare W0 x with + Eq => true + | _ => false + end. + + Definition ww_head1 x := + match ww_head0 x with + N0 => N0 + | Npos xH => N0 + | Npos (xO _) as U => U + | Npos (xI V) => Npos (xO V) + end. + + Definition ww_sqrt x := + if (ww_is_zero x) then W0 + else + match (ww_head1 x) with + N0 => + match x with + W0 => W0 + | WW x1 x2 => WW w_0 (fst (w_sqrt2 x1 x2)) + end + | Npos p => + match ww_add_mul_div p x W0 with + W0 => W0 + | WW x1 x2 => + let (r, _) := w_sqrt2 x1 x2 in + WW w_0 (w_add_mul_div (w_digits - (Pdiv2 p)) w_0 r) + end + end. + + + Variable w_to_Z : w -> Z. + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). + Notation "[-| c |]" := + (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Notation "[|| x ||]" := + (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). + + Notation "[! n | x !]" := (gen_to_Z w_digits w_to_Z n x) + (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_1 : [|w_1|] = 1. + Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. + + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. + Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. + Variable spec_w_is_even : forall x, + if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. + Variable spec_w_compare : forall x y, + match w_compare x y with + | Eq => [|x|] = [|y|] + | Lt => [|x|] < [|y|] + | Gt => [|x|] > [|y|] + end. + Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. + Variable spec_w_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Variable spec_w_add_mul_div : forall x y p, + Zpos p < Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (Zpower 2 (Zpos p)) + + [|y|] / (Zpower 2 ((Zpos w_digits) - (Zpos p)))) mod wB. + Variable spec_ww_add_mul_div : forall x y p, + Zpos p < Zpos (xO w_digits) -> + [[ ww_add_mul_div p x y ]] = + ([[x]] * (2^ Zpos p) + + [[y]] / (2^ (Zpos (xO w_digits) - Zpos p))) mod wwB. + Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. + Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. + Variable spec_w_sqrt2 : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := w_sqrt2 x y in + [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. + Variable spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. + Variable spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. + Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. + Variable spec_ww_compare : forall x y, + match ww_compare x y with + | Eq => [[x]] = [[y]] + | Lt => [[x]] < [[y]] + | Gt => [[x]] > [[y]] + end. + Variable spec_ww_head0 : forall x, 0 < [[x]] -> + wwB/ 2 <= 2 ^ (Z_of_N (ww_head0 x)) * [[x]] < wwB. + + Let spec_ww_Bm1 : [[wwBm1]] = wwB - 1. + Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. + + + Hint Rewrite spec_w_0 spec_w_1 w_Bm1 spec_w_WW spec_w_sub + spec_w_div21 spec_w_add_mul_div spec_ww_Bm1 + spec_w_add_c spec_w_sqrt2: w_rewrite. + + Lemma spec_ww_is_even : forall x, + if ww_is_even x then [[x]] mod 2 = 0 else [[x]] mod 2 = 1. + intros x; case x; simpl ww_is_even. + simpl. + rewrite Zmod_def_small; auto with zarith. + intros w1 w2; simpl. + unfold base. + rewrite Zmod_plus; auto with zarith. + rewrite (fun x y => (Zdivide_mod (x * y))); auto with zarith. + rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith. + apply spec_w_is_even; auto with zarith. + apply Zdivide_mult_r; apply Zpower_divide; auto with zarith. + red; simpl; auto. + Qed. + + Theorem spec_w_div21c : forall a1 a2 b, + wB/2 <= [|b|] -> + let (q,r) := w_div21c a1 a2 b in + [|a1|] * wB + [|a2|] = [+|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. + intros a1 a2 b Hb; unfold w_div21c. + assert (H: 0 < [|b|]); auto with zarith. + assert (U := wB_pos w_digits). + apply Zlt_le_trans with (2 := Hb); auto with zarith. + apply Zlt_le_trans with 1; auto with zarith. + apply Zdiv_le_lower_bound; auto with zarith. + repeat match goal with |- context[w_compare ?y ?z] => + generalize (spec_w_compare y z); + case (w_compare y z) + end. + intros H1 H2; split. + unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. + rewrite H1; rewrite H2; ring. + autorewrite with w_rewrite; auto with zarith. + intros H1 H2; split. + unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. + rewrite H2; ring. + destruct (spec_to_Z a2);auto with zarith. + intros H1 H2; split. + unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. + rewrite H2; rewrite Zmod_def_small; auto with zarith. + ring. + destruct (spec_to_Z a2);auto with zarith. + rewrite spec_w_sub; auto with zarith. + destruct (spec_to_Z a2) as [H3 H4];auto with zarith. + rewrite Zmod_def_small; auto with zarith. + split; auto with zarith. + assert ([|a2|] < 2 * [|b|]); auto with zarith. + apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith. + rewrite wB_div_2; auto. + intros H1. + match goal with |- context[w_div21 ?y ?z ?t] => + generalize (@spec_w_div21 y z t Hb H1); + case (w_div21 y z t); simpl; autorewrite with w_rewrite; + auto + end. + intros H1. + assert (H2: [|w_sub a1 b|] < [|b|]). + rewrite spec_w_sub; auto with zarith. + rewrite Zmod_def_small; auto with zarith. + assert ([|a1|] < 2 * [|b|]); auto with zarith. + apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith. + rewrite wB_div_2; auto. + destruct (spec_to_Z a1);auto with zarith. + destruct (spec_to_Z a1);auto with zarith. + match goal with |- context[w_div21 ?y ?z ?t] => + generalize (@spec_w_div21 y z t Hb H2); + case (w_div21 y z t); autorewrite with w_rewrite; + auto + end. + intros w0 w1; replace [+|C1 w0|] with (wB + [|w0|]). + rewrite Zmod_def_small; auto with zarith. + intros (H3, H4); split; auto. + rewrite Zmult_plus_distr_l. + rewrite <- Zplus_assoc; rewrite <- H3; ring. + split; auto with zarith. + assert ([|a1|] < 2 * [|b|]); auto with zarith. + apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith. + rewrite wB_div_2; auto. + destruct (spec_to_Z a1);auto with zarith. + destruct (spec_to_Z a1);auto with zarith. + simpl; case wB; auto. + Qed. + + Theorem C0_id: forall p, [+|C0 p|] = [|p|]. + intros p; simpl; auto. + Qed. + + Hypothesis more_than_one_bit: 1 < Zpos w_digits. + + Theorem add_mult_div_2: forall w, + [|w_add_mul_div (w_digits - 1) w_0 w|] = [|w|] / 2. + intros w1. + rewrite spec_w_add_mul_div; auto with zarith. + autorewrite with w_rewrite rm10. + match goal with |- context[?X - ?Y] => + replace (X - Y) with 1 + end. + rewrite Zpower_exp_1; rewrite Zmod_def_small; auto with zarith. + destruct (spec_to_Z w1) as [H1 H2];auto with zarith. + split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + rewrite Zpos_minus; auto with zarith. + rewrite Zpos_minus; auto with zarith. + Qed. + + Theorem add_mult_div_2_plus_1: forall w, + [|w_add_mul_div (w_digits - 1) w_1 w|] = + [|w|] / 2 + 2 ^ Zpos (w_digits - 1). + intros w1. + autorewrite with w_rewrite rm10; auto with zarith. + match goal with |- context[?X - ?Y] => + replace (X - Y) with 1 + end. + rewrite Zpower_exp_1; rewrite Zmod_def_small; auto with zarith. + destruct (spec_to_Z w1) as [H1 H2];auto with zarith. + split; auto with zarith. + unfold base. + match goal with |- _ < _ ^ ?X => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp + end. + rewrite Zpower_exp; try rewrite Zpower_exp_1; auto with zarith. + rewrite Zpos_minus; auto with zarith. + match goal with |- ?X + ?Y < _ => + assert (Y < X); auto with zarith + end. + apply Zdiv_lt_upper_bound; auto with zarith. + pattern 2 at 2; rewrite <- Zpower_exp_1; rewrite <- Zpower_exp; + auto with zarith. + assert (tmp: forall p, (p - 1) + 1 = p); auto with zarith; + rewrite tmp; clear tmp; auto with zarith. + rewrite Zpos_minus; auto with zarith. + rewrite Zpos_minus; auto with zarith. + Qed. + + Theorem add_mult_mult_2: forall w, + [|w_add_mul_div 1 w w_0|] = 2 * [|w|] mod wB. + intros w1. + autorewrite with w_rewrite rm10; auto with zarith. + rewrite Zpower_exp_1; auto with zarith. + rewrite Zmult_comm; auto. + Qed. + + Theorem ww_add_mult_mult_2: forall w, + [[ww_add_mul_div 1 w W0]] = 2 * [[w]] mod wwB. + intros w1. + rewrite spec_ww_add_mul_div; auto with zarith. + autorewrite with w_rewrite rm10. + rewrite Zpower_exp_1; auto with zarith. + rewrite Zmult_comm; auto. + Qed. + + Theorem ww_add_mult_mult_2_plus_1: forall w, + [[ww_add_mul_div 1 w wwBm1]] = + (2 * [[w]] + 1) mod wwB. + intros w1. + rewrite spec_ww_add_mul_div; auto with zarith. + rewrite Zpower_exp_1; auto with zarith. + eq_tac; auto. + rewrite Zmult_comm; eq_tac; auto. + autorewrite with w_rewrite rm10. + unfold ww_digits, base. + apply sym_equal; apply Zdiv_unique with (r := 2 ^ (Zpos (ww_digits w_digits) - 1) -1); + auto with zarith. + apply Zpower_lt_0; auto with zarith. + match goal with |- 0 <= ?X - 1 => + assert (0 < X); auto with zarith; red; reflexivity + end. + unfold ww_digits; split; auto with zarith. + match goal with |- 0 <= ?X - 1 => + assert (0 < X); auto with zarith + end. + apply Zpower_lt_0; auto with zarith. + match goal with |- 0 <= ?X - 1 => + assert (0 < X); auto with zarith; red; reflexivity + end. + unfold ww_digits; autorewrite with rm10. + assert (tmp: forall p q r, p + (q - r) = p + q - r); auto with zarith; + rewrite tmp; clear tmp. + assert (tmp: forall p, p + p = 2 * p); auto with zarith; + rewrite tmp; clear tmp. + eq_tac; auto. + pattern 2 at 2; rewrite <- Zpower_exp_1; rewrite <- Zpower_exp; + auto with zarith. + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite tmp; clear tmp; auto. + match goal with |- ?X - 1 >= 0 => + assert (0 < X); auto with zarith; red; reflexivity + end. + Qed. + + Theorem Zmod_plus_one: forall a1 b1, 0 < b1 -> (a1 + b1) mod b1 = a1 mod b1. + intros a1 b1 H; rewrite Zmod_plus; auto with zarith. + rewrite Z_mod_same; try rewrite Zplus_0_r; auto with zarith. + apply Zmod_mod; auto. + Qed. + + Lemma C1_plus_wB: forall x, [+|C1 x|] = wB + [|x|]. + unfold interp_carry; auto with zarith. + Qed. + + Theorem spec_w_div2s : forall a1 a2 b, + wB/2 <= [|b|] -> [+|a1|] <= 2 * [|b|] -> + let (q,r) := w_div2s a1 a2 b in + [+|a1|] * wB + [|a2|] = [+|q|] * (2 * [|b|]) + [+|r|] /\ 0 <= [+|r|] < 2 * [|b|]. + intros a1 a2 b H. + assert (HH: 0 < [|b|]); auto with zarith. + assert (U := wB_pos w_digits). + apply Zlt_le_trans with (2 := H); auto with zarith. + apply Zlt_le_trans with 1; auto with zarith. + apply Zdiv_le_lower_bound; auto with zarith. + unfold w_div2s; case a1; intros w0 H0. + match goal with |- context[w_div21c ?y ?z ?t] => + generalize (@spec_w_div21c y z t H); + case (w_div21c y z t); autorewrite with w_rewrite; + auto + end. + intros c w1; case c. + simpl interp_carry; intros w2 (Hw1, Hw2). + match goal with |- context[w_is_even ?y] => + generalize (spec_w_is_even y); + case (w_is_even y) + end. + repeat rewrite C0_id. + rewrite add_mult_div_2. + intros H1; split; auto with zarith. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; ring. + repeat rewrite C0_id. + rewrite add_mult_div_2. + rewrite spec_w_add_c; auto with zarith. + intros H1; split; auto with zarith. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; ring. + intros w2; rewrite C1_plus_wB. + intros (Hw1, Hw2). + match goal with |- context[w_is_even ?y] => + generalize (spec_w_is_even y); + case (w_is_even y) + end. + repeat rewrite C0_id. + intros H1; split; auto with zarith. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1. + repeat rewrite C0_id. + rewrite add_mult_div_2_plus_1; unfold base. + match goal with |- context[_ ^ ?X] => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + try rewrite Zpower_exp_1; auto with zarith + end. + rewrite Zpos_minus; auto with zarith. + ring. + repeat rewrite C0_id. + rewrite spec_w_add_c; auto with zarith. + intros H1; split; auto with zarith. + rewrite add_mult_div_2_plus_1. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1. + unfold base. + match goal with |- context[_ ^ ?X] => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + try rewrite Zpower_exp_1; auto with zarith + end. + rewrite Zpos_minus; auto with zarith. + ring. + repeat rewrite C1_plus_wB in H0. + rewrite C1_plus_wB. + match goal with |- context[w_div21c ?y ?z ?t] => + generalize (@spec_w_div21c y z t H); + case (w_div21c y z t); autorewrite with w_rewrite; + auto + end. + intros c w1; case c. + intros w2 (Hw1, Hw2); rewrite C0_id in Hw1. + rewrite <- Zmod_plus_one in Hw1; auto with zarith. + rewrite Zmod_def_small in Hw1; auto with zarith. + match goal with |- context[w_is_even ?y] => + generalize (spec_w_is_even y); + case (w_is_even y) + end. + repeat rewrite C0_id. + intros H1; split; auto with zarith. + rewrite add_mult_div_2_plus_1. + replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); + auto with zarith. + rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; unfold base. + match goal with |- context[_ ^ ?X] => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + try rewrite Zpower_exp_1; auto with zarith + end. + rewrite Zpos_minus; auto with zarith. + ring. + repeat rewrite C0_id. + rewrite add_mult_div_2_plus_1. + rewrite spec_w_add_c; auto with zarith. + intros H1; split; auto with zarith. + replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); + auto with zarith. + rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; unfold base. + match goal with |- context[_ ^ ?X] => + assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + try rewrite Zpower_exp_1; auto with zarith + end. + rewrite Zpos_minus; auto with zarith. + ring. + split; auto with zarith. + destruct (spec_to_Z b);auto with zarith. + destruct (spec_to_Z w0);auto with zarith. + destruct (spec_to_Z b);auto with zarith. + destruct (spec_to_Z b);auto with zarith. + intros w2; rewrite C1_plus_wB. + rewrite <- Zmod_plus_one; auto with zarith. + rewrite Zmod_def_small; auto with zarith. + intros (Hw1, Hw2). + match goal with |- context[w_is_even ?y] => + generalize (spec_w_is_even y); + case (w_is_even y) + end. + repeat (rewrite C0_id || rewrite C1_plus_wB). + intros H1; split; auto with zarith. + rewrite add_mult_div_2. + replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); + auto with zarith. + rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; ring. + repeat (rewrite C0_id || rewrite C1_plus_wB). + rewrite spec_w_add_c; auto with zarith. + intros H1; split; auto with zarith. + rewrite add_mult_div_2. + replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); + auto with zarith. + rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc. + rewrite Hw1. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); + auto with zarith. + rewrite H1; ring. + split; auto with zarith. + destruct (spec_to_Z b);auto with zarith. + destruct (spec_to_Z w0);auto with zarith. + destruct (spec_to_Z b);auto with zarith. + destruct (spec_to_Z b);auto with zarith. + Qed. + + Theorem wB_div_4: 4 * (wB / 4) = wB. + Proof. + unfold base. + assert (2 ^ Zpos w_digits = + 4 * (2 ^ (Zpos w_digits - 2))). + change 4 with (2 ^ 2). + rewrite <- Zpower_exp; auto with zarith. + eq_tac; auto with zarith. + rewrite H. + rewrite (fun x => (Zmult_comm 4 (2 ^x))). + rewrite Z_div_mult; auto with zarith. + Qed. + + Theorem Zsquare_mult: forall p, p ^ 2 = p * p. + intros p; change 2 with (1 + 1); rewrite Zpower_exp; + try rewrite Zpower_exp_1; auto with zarith. + Qed. + + Theorem Zsquare_pos: forall p, 0 <= p ^ 2. + intros p; case (Zle_or_lt 0 p); intros H1. + rewrite Zsquare_mult; apply Zmult_le_0_compat; auto with zarith. + rewrite Zsquare_mult; replace (p * p) with ((- p) * (- p)); try ring. + apply Zmult_le_0_compat; auto with zarith. + Qed. + + Lemma spec_split: forall x, + [|fst (split x)|] * wB + [|snd (split x)|] = [[x]]. + intros x; case x; simpl; autorewrite with w_rewrite; + auto with zarith. + Qed. + + Theorem mult_wwB: forall x y, [|x|] * [|y|] < wwB. + Proof. + intros x y; rewrite wwB_wBwB; rewrite Zpower_2. + generalize (spec_to_Z x); intros U. + generalize (spec_to_Z y); intros U1. + apply Zle_lt_trans with ((wB -1 ) * (wB - 1)); auto with zarith. + apply Zmult_le_compat; auto with zarith. + repeat (rewrite Zmult_minus_distr_r || rewrite Zmult_minus_distr_l); + auto with zarith. + Qed. + Hint Resolve mult_wwB. + + Lemma spec_ww_sqrt2 : forall x y, + wwB/ 4 <= [[x]] -> + let (s,r) := ww_sqrt2 x y in + [||WW x y||] = [[s]] ^ 2 + [+[r]] /\ + [+[r]] <= 2 * [[s]]. + intros x y H; unfold ww_sqrt2. + repeat match goal with |- context[split ?x] => + generalize (spec_split x); case (split x) + end; simpl fst; simpl snd. + intros w0 w1 Hw0 w2 w3 Hw1. + assert (U: wB/4 <= [|w2|]). + case (Zle_or_lt (wB / 4) [|w2|]); auto; intros H1. + contradict H; apply Zlt_not_le. + rewrite wwB_wBwB; rewrite Zpower_2. + pattern wB at 1; rewrite <- wB_div_4; rewrite <- Zmult_assoc; + rewrite Zmult_comm. + rewrite Z_div_mult; auto with zarith. + rewrite <- Hw1. + match goal with |- _ < ?X => + pattern X; rewrite <- Zplus_0_r; apply beta_lex_inv; + auto with zarith + end. + destruct (spec_to_Z w3);auto with zarith. + generalize (@spec_w_sqrt2 w2 w3 U); case (w_sqrt2 w2 w3). + intros w4 c (H1, H2). + assert (U1: wB/2 <= [|w4|]). + case (Zle_or_lt (wB/2) [|w4|]); auto with zarith. + intros U1. + assert (U2 : [|w4|] <= wB/2 -1); auto with zarith. + assert (U3 : [|w4|] ^ 2 <= wB/4 * wB - wB + 1); auto with zarith. + match goal with |- ?X ^ 2 <= ?Y => + rewrite Zsquare_mult; + replace Y with ((wB/2 - 1) * (wB/2 -1)) + end. + apply Zmult_le_compat; auto with zarith. + destruct (spec_to_Z w4);auto with zarith. + destruct (spec_to_Z w4);auto with zarith. + pattern wB at 4 5; rewrite <- wB_div_2. + rewrite Zmult_assoc. + replace ((wB / 4) * 2) with (wB / 2). + ring. + pattern wB at 1; rewrite <- wB_div_4. + change 4 with (2 * 2). + rewrite <- Zmult_assoc; rewrite (Zmult_comm 2). + rewrite Z_div_mult; try ring; auto with zarith. + assert (U4 : [+|c|] <= wB -2); auto with zarith. + apply Zle_trans with (1 := H2). + match goal with |- ?X <= ?Y => + replace Y with (2 * (wB/ 2 - 1)); auto with zarith + end. + pattern wB at 2; rewrite <- wB_div_2; auto with zarith. + match type of H1 with ?X = _ => + assert (U5: X < wB / 4 * wB) + end. + rewrite H1; auto with zarith. + contradict U; apply Zlt_not_le. + apply Zmult_lt_reg_r with wB; auto with zarith. + destruct (spec_to_Z w4);auto with zarith. + apply Zle_lt_trans with (2 := U5). + unfold ww_to_Z, zn2z_to_Z. + destruct (spec_to_Z w3);auto with zarith. + generalize (@spec_w_div2s c w0 w4 U1 H2). + case (w_div2s c w0 w4). + intros c0; case c0; intros w5; + repeat (rewrite C0_id || rewrite C1_plus_wB). + intros c1; case c1; intros w6; + repeat (rewrite C0_id || rewrite C1_plus_wB). + intros (H3, H4). + match goal with |- context [ww_sub_c ?y ?z] => + generalize (spec_ww_sub_c y z); case (ww_sub_c y z) + end. + intros z; change [-[C0 z]] with ([[z]]). + change [+[C0 z]] with ([[z]]). + intros H5; rewrite spec_w_square_c in H5; + auto. + split. + unfold zn2z_to_Z; rewrite <- Hw1. + unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. + rewrite <- Hw0. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite H5. + unfold ww_to_Z, zn2z_to_Z. + repeat rewrite Zsquare_mult; ring. + rewrite H5. + unfold ww_to_Z, zn2z_to_Z. + match goal with |- ?X - ?Y * ?Y <= _ => + assert (V := Zsquare_pos Y); + rewrite Zsquare_mult in V; + apply Zle_trans with X; auto with zarith; + clear V + end. + match goal with |- ?X * wB + ?Y <= 2 * (?Z * wB + ?T) => + apply Zle_trans with ((2 * Z - 1) * wB + wB); auto with zarith + end. + destruct (spec_to_Z w1);auto with zarith. + match goal with |- ?X <= _ => + replace X with (2 * [|w4|] * wB); auto with zarith + end. + rewrite Zmult_plus_distr_r; rewrite Zmult_assoc. + destruct (spec_to_Z w5); auto with zarith. + ring. + intros z; replace [-[C1 z]] with (- wwB + [[z]]). + 2: simpl; case wwB; auto with zarith. + intros H5; rewrite spec_w_square_c in H5; + auto. + match goal with |- context [ww_pred_c ?y] => + generalize (spec_ww_pred_c y); case (ww_pred_c y) + end. + intros z1; change [-[C0 z1]] with ([[z1]]). + rewrite ww_add_mult_mult_2. + rewrite spec_ww_add_c. + rewrite spec_ww_pred. + rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); + auto with zarith. + intros Hz1; rewrite Zmod_def_small; auto with zarith. + match type of H5 with -?X + ?Y = ?Z => + assert (V: Y = Z + X); + try (rewrite <- H5; ring) + end. + split. + unfold zn2z_to_Z; rewrite <- Hw1. + unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. + rewrite <- Hw0. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite V. + rewrite Hz1. + unfold ww_to_Z; simpl zn2z_to_Z. + repeat rewrite Zsquare_mult; ring. + rewrite Hz1. + destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. + assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)). + assert (0 < [[WW w4 w5]]); auto with zarith. + apply Zlt_le_trans with (wB/ 2 * wB + 0); auto with zarith. + autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith. + apply Zmult_lt_reg_r with 2; auto with zarith. + autorewrite with rm10. + rewrite Zmult_comm; rewrite wB_div_2; auto with zarith. + case (spec_to_Z w5);auto with zarith. + case (spec_to_Z w5);auto with zarith. + simpl. + assert (V2 := spec_to_Z w5);auto with zarith. + assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. + split; auto with zarith. + assert (wwB <= 2 * [[WW w4 w5]]); auto with zarith. + apply Zle_trans with (2 * ([|w4|] * wB)). + rewrite wwB_wBwB; rewrite Zpower_2. + rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith. + rewrite <- wB_div_2; auto with zarith. + assert (V2 := spec_to_Z w5);auto with zarith. + simpl ww_to_Z; assert (V2 := spec_to_Z w5);auto with zarith. + assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. + intros z1; change [-[C1 z1]] with (-wwB + [[z1]]). + match goal with |- context[([+[C0 ?z]])] => + change [+[C0 z]] with ([[z]]) + end. + rewrite spec_ww_add; auto with zarith. + rewrite spec_ww_pred; auto with zarith. + rewrite ww_add_mult_mult_2. + assert (VV1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)). + assert (VV2: 0 < [[WW w4 w5]]); auto with zarith. + apply Zlt_le_trans with (wB/ 2 * wB + 0); auto with zarith. + autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith. + apply Zmult_lt_reg_r with 2; auto with zarith. + autorewrite with rm10. + rewrite Zmult_comm; rewrite wB_div_2; auto with zarith. + assert (VV3 := spec_to_Z w5);auto with zarith. + assert (VV3 := spec_to_Z w5);auto with zarith. + simpl. + assert (VV3 := spec_to_Z w5);auto with zarith. + assert (VV3: wwB <= 2 * [[WW w4 w5]]); auto with zarith. + apply Zle_trans with (2 * ([|w4|] * wB)). + rewrite wwB_wBwB; rewrite Zpower_2. + rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith. + rewrite <- wB_div_2; auto with zarith. + case (spec_to_Z w5);auto with zarith. + simpl ww_to_Z; assert (V4 := spec_to_Z w5);auto with zarith. + rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); + auto with zarith. + intros Hz1; rewrite Zmod_def_small; auto with zarith. + match type of H5 with -?X + ?Y = ?Z => + assert (V: Y = Z + X); + try (rewrite <- H5; ring) + end. + match type of Hz1 with -?X + ?Y = -?X + ?Z - 1 => + assert (V1: Y = Z - 1); + [replace (Z - 1) with (X + (-X + Z -1)); + [rewrite <- Hz1 | idtac]; ring + | idtac] + end. + rewrite <- Zmod_unique with (q := 1) (r := -wwB + [[z1]] + [[z]]); + auto with zarith. + unfold zn2z_to_Z; rewrite <- Hw1. + unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. + rewrite <- Hw0. + split. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite V. + rewrite Hz1. + unfold ww_to_Z; simpl zn2z_to_Z. + repeat rewrite Zsquare_mult; ring. + assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. + assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. + assert (V3 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z1);auto with zarith. + split; auto with zarith. + rewrite (Zplus_comm (-wwB)); rewrite <- Zplus_assoc. + rewrite H5. + match goal with |- 0 <= ?X + (?Y - ?Z) => + apply Zle_trans with (X - Z); auto with zarith + end. + 2: generalize (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w6 w1)); unfold ww_to_Z; auto with zarith. + rewrite V1. + match goal with |- 0 <= ?X - 1 - ?Y => + assert (Y < X); auto with zarith + end. + apply Zlt_le_trans with wwB; auto with zarith. + intros (H3, H4). + match goal with |- context [ww_sub_c ?y ?z] => + generalize (spec_ww_sub_c y z); case (ww_sub_c y z) + end. + intros z; change [-[C0 z]] with ([[z]]). + match goal with |- context[([+[C1 ?z]])] => + replace [+[C1 z]] with (wwB + [[z]]) + end. + 2: simpl; case wwB; auto. + intros H5; rewrite spec_w_square_c in H5; + auto. + split. + change ([||WW x y||]) with ([[x]] * wwB + [[y]]). + rewrite <- Hw1. + unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. + rewrite <- Hw0. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite H5. + unfold ww_to_Z; simpl zn2z_to_Z. + rewrite wwB_wBwB. + repeat rewrite Zsquare_mult; ring. + simpl ww_to_Z. + rewrite H5. + simpl ww_to_Z. + rewrite wwB_wBwB; rewrite Zpower_2. + match goal with |- ?X * ?Y + (?Z * ?Y + ?T - ?U) <= _ => + apply Zle_trans with (X * Y + (Z * Y + T - 0)); + auto with zarith + end. + assert (V := Zsquare_pos [|w5|]); + rewrite Zsquare_mult in V; auto with zarith. + autorewrite with rm10. + match goal with |- _ <= 2 * (?U * ?V + ?W) => + apply Zle_trans with (2 * U * V + 0); + auto with zarith + end. + match goal with |- ?X * ?Y + (?Z * ?Y + ?T) <= _ => + replace (X * Y + (Z * Y + T)) with ((X + Z) * Y + T); + try ring + end. + apply Zlt_le_weak; apply beta_lex_inv; auto with zarith. + destruct (spec_to_Z w1);auto with zarith. + destruct (spec_to_Z w5);auto with zarith. + rewrite Zmult_plus_distr_r; auto with zarith. + rewrite Zmult_assoc; auto with zarith. + intros z; replace [-[C1 z]] with (- wwB + [[z]]). + 2: simpl; case wwB; auto with zarith. + intros H5; rewrite spec_w_square_c in H5; + auto. + match goal with |- context[([+[C0 ?z]])] => + change [+[C0 z]] with ([[z]]) + end. + match type of H5 with -?X + ?Y = ?Z => + assert (V: Y = Z + X); + try (rewrite <- H5; ring) + end. + change ([||WW x y||]) with ([[x]] * wwB + [[y]]). + simpl ww_to_Z. + rewrite <- Hw1. + simpl ww_to_Z in H1; rewrite H1. + rewrite <- Hw0. + split. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H3. + rewrite V. + simpl ww_to_Z. + rewrite wwB_wBwB. + repeat rewrite Zsquare_mult; ring. + rewrite V. + simpl ww_to_Z. + rewrite wwB_wBwB; rewrite Zpower_2. + match goal with |- (?Z * ?Y + ?T - ?U) + ?X * ?Y <= _ => + apply Zle_trans with ((Z * Y + T - 0) + X * Y); + auto with zarith + end. + assert (V1 := Zsquare_pos [|w5|]); + rewrite Zsquare_mult in V1; auto with zarith. + autorewrite with rm10. + match goal with |- _ <= 2 * (?U * ?V + ?W) => + apply Zle_trans with (2 * U * V + 0); + auto with zarith + end. + match goal with |- (?Z * ?Y + ?T) + ?X * ?Y <= _ => + replace ((Z * Y + T) + X * Y) with ((X + Z) * Y + T); + try ring + end. + apply Zlt_le_weak; apply beta_lex_inv; auto with zarith. + destruct (spec_to_Z w1);auto with zarith. + destruct (spec_to_Z w5);auto with zarith. + rewrite Zmult_plus_distr_r; auto with zarith. + rewrite Zmult_assoc; auto with zarith. + case Zle_lt_or_eq with (1 := H2); clear H2; intros H2. + intros c1 (H3, H4). + match type of H3 with ?X = ?Y => + absurd (X < Y) + end. + apply Zle_not_lt; rewrite <- H3; auto with zarith. + rewrite Zmult_plus_distr_l. + apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0); + auto with zarith. + apply beta_lex_inv; auto with zarith. + destruct (spec_to_Z w0);auto with zarith. + assert (V1 := spec_to_Z w5);auto with zarith. + rewrite (Zmult_comm wB); auto with zarith. + assert (0 <= [|w5|] * (2 * [|w4|])); auto with zarith. + intros c1 (H3, H4); rewrite H2 in H3. + match type of H3 with ?X + ?Y = (?Z + ?T) * ?U + ?V => + assert (VV: (Y = (T * U) + V)); + [replace Y with ((X + Y) - X); + [rewrite H3; ring | ring] | idtac] + end. + assert (V1 := spec_to_Z w0);auto with zarith. + assert (V2 := spec_to_Z w5);auto with zarith. + case (Zle_lt_or_eq 0 [|w5|]); auto with zarith; intros V3. + match type of VV with ?X = ?Y => + absurd (X < Y) + end. + apply Zle_not_lt; rewrite <- VV; auto with zarith. + apply Zlt_le_trans with wB; auto with zarith. + match goal with |- _ <= ?X + _ => + apply Zle_trans with X; auto with zarith + end. + match goal with |- _ <= _ * ?X => + apply Zle_trans with (1 * X); auto with zarith + end. + autorewrite with rm10. + rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith. + rewrite <- V3 in VV; generalize VV; autorewrite with rm10; + clear VV; intros VV. + rewrite spec_ww_add_c; auto with zarith. + rewrite ww_add_mult_mult_2_plus_1. + match goal with |- context[?X mod wwB] => + rewrite <- Zmod_unique with (q := 1) (r := -wwB + X) + end; auto with zarith. + simpl ww_to_Z. + rewrite spec_w_Bm1; auto with zarith. + split. + change ([||WW x y||]) with ([[x]] * wwB + [[y]]). + rewrite <- Hw1. + simpl ww_to_Z in H1; rewrite H1. + rewrite <- Hw0. + match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => + apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) + end. + repeat rewrite Zsquare_mult. + rewrite wwB_wBwB; ring. + rewrite H2. + rewrite wwB_wBwB. + repeat rewrite Zsquare_mult; ring. + assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. + assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. + simpl ww_to_Z; unfold ww_to_Z. + rewrite spec_w_Bm1; auto with zarith. + split. + rewrite wwB_wBwB; rewrite Zpower_2. + match goal with |- _ <= -?X + (2 * (?Z * ?T + ?U) + ?V) => + assert (X <= 2 * Z * T); auto with zarith + end. + apply Zmult_le_compat_r; auto with zarith. + rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith. + rewrite Zmult_plus_distr_r; auto with zarith. + rewrite Zmult_assoc; auto with zarith. + match goal with |- _ + ?X < _ => + replace X with ((2 * (([|w4|]) + 1) * wB) - 1); try ring + end. + assert (2 * ([|w4|] + 1) * wB <= 2 * wwB); auto with zarith. + rewrite <- Zmult_assoc; apply Zmult_le_compat_l; auto with zarith. + rewrite wwB_wBwB; rewrite Zpower_2. + apply Zmult_le_compat_r; auto with zarith. + case (spec_to_Z w4);auto with zarith. + Qed. + + Lemma spec_ww_is_zero: forall x, + if ww_is_zero x then [[x]] = 0 else 0 < [[x]]. + intro x; unfold ww_is_zero. + generalize (spec_ww_compare W0 x); case (ww_compare W0 x); + auto with zarith. + simpl ww_to_Z. + assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z x);auto with zarith. + Qed. + + Lemma Zdiv_le_monotone: forall p q r, 0 <= p -> 0 < q < r -> + p / r <= p / q. + intros p q r H H1. + apply Zdiv_le_lower_bound; auto with zarith. + rewrite Zmult_comm. + pattern p at 2; rewrite (Z_div_mod_eq p r); auto with zarith. + apply Zle_trans with (r * (p / r)); auto with zarith. + case (Z_mod_lt p r); auto with zarith. + Qed. + + Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. + pattern wwB at 1; rewrite wwB_wBwB; rewrite Zpower_2. + rewrite <- wB_div_2. + match goal with |- context[(2 * ?X) * (2 * ?Z)] => + replace ((2 * X) * (2 * Z)) with ((X * Z) * 4); try ring + end. + rewrite Z_div_mult; auto with zarith. + rewrite Zmult_assoc; rewrite wB_div_2. + rewrite wwB_div_2; ring. + Qed. + + + Lemma spec_ww_head1 + : forall x : zn2z w, + (forall p, ww_head1 x = Npos p -> (2 * Zpos (Pdiv2 p) = Zpos p)) /\ + (0 < [[x]] -> wwB / 4 <= 2 ^ Z_of_N (ww_head1 x) * [[x]] < wwB). + assert (U := wB_pos w_digits). + intros x; unfold ww_head1. + generalize (spec_ww_head0 x); case (ww_head0 x); simpl Z_of_N; + autorewrite with rm10. + intros H1; split. + intros; discriminate. + intros H2; assert (H3:= H1 H2). + split; auto with zarith. + apply Zle_trans with (wwB/2); auto with zarith. + apply Zdiv_le_monotone; auto with zarith. + intros p; case p; clear p; simpl Z_of_N. + intros p H1; split. + intros p1 H2; injection H2; intros; subst; clear H2; auto. + intros H2; assert (H3:= H1 H2). + split; auto with zarith. + apply Zmult_le_reg_r with 2; auto with zarith. + repeat rewrite (fun x => Zmult_comm x 2). + rewrite wwB_4_2. + pattern 2 at 2; rewrite <- Zpower_exp_1; rewrite Zmult_assoc; + rewrite <- Zpower_exp; auto with zarith. + replace (1 + Zpos (xO p)) with (Zpos (xI p)); auto with zarith. + case H3; intros _ tmp; apply Zlt_trans with (2 := tmp). + apply Zmult_lt_compat_r; auto with zarith. + apply Zpower_lt_monotone; auto with zarith. + split; try (red; intros; discriminate). + replace (Zpos (xI p)) with (1 + Zpos (xO p)); auto with zarith. + intros p H1; split. + intros p1 H2; injection H2; intros; subst; clear H2; auto. + intros H2; assert (H3:= H1 H2). + split; auto with zarith. + apply Zle_trans with (wwB/2); auto with zarith. + apply Zdiv_le_monotone; auto with zarith. + generalize (wwB_pos w_digits); auto with zarith. + rewrite Zpower_exp_1; try rewrite Zpower_exp_0. + intros H1; split. + intros; discriminate. + intros H2; assert (H3 := H1 H2). + autorewrite with rm10. + split; auto with zarith. + apply Zmult_le_reg_r with 2; auto with zarith. + repeat rewrite (fun x => Zmult_comm x 2). + rewrite wwB_4_2; auto with zarith. + Qed. + + Theorem wwB_4_wB_4: wwB / 4 = wB / 4 * wB. + apply sym_equal; apply Zdiv_unique with 0; + auto with zarith. + rewrite Zmult_assoc; rewrite wB_div_4; auto with zarith. + rewrite wwB_wBwB; ring. + Qed. + + Lemma spec_ww_sqrt : forall x, + [[ww_sqrt x]] ^ 2 <= [[x]] < ([[ww_sqrt x]] + 1) ^ 2. + assert (U := wB_pos w_digits). + intro x; unfold ww_sqrt. + generalize (spec_ww_is_zero x); case (ww_is_zero x). + simpl ww_to_Z; simpl Zpower; unfold Zpower_pos; simpl; + auto with zarith. + intros H1; generalize (spec_ww_head1 x); case (ww_head1 x); simpl Z_of_N; + autorewrite with rm10. + generalize H1; case x. + intros HH; contradict HH; simpl ww_to_Z; auto with zarith. + intros w0 w1; simpl ww_to_Z; autorewrite with w_rewrite rm10. + intros H2 (H3, H4). + generalize (H4 H2); clear H4; intros (H4, H5). + assert (V: wB/4 <= [|w0|]). + apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. + rewrite <- wwB_4_wB_4; auto. + generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. + case (w_sqrt2 w0 w1); intros w2 c. + simpl ww_to_Z; simpl fst. + case c; unfold interp_carry; autorewrite with rm10. + intros w3 (H6, H7); rewrite H6. + assert (V1 := spec_to_Z w3);auto with zarith. + split; auto with zarith. + apply Zle_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. + match goal with |- ?X < ?Z => + replace Z with (X + 1); auto with zarith + end. + repeat rewrite Zsquare_mult; ring. + intros w3 (H6, H7); rewrite H6. + assert (V1 := spec_to_Z w3);auto with zarith. + split; auto with zarith. + apply Zle_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. + match goal with |- ?X < ?Z => + replace Z with (X + 1); auto with zarith + end. + repeat rewrite Zsquare_mult; ring. + intros p (Hp1, Hp2). + assert (F0: 0 < Zpos (Pdiv2 p)); try (red; reflexivity). + assert (Hp3 := Hp1 p (refl_equal _)). + assert (U0: Zpos p < Zpos (ww_digits w_digits)). + case (Zle_or_lt (Zpos (ww_digits w_digits)) (Zpos p)); auto; intros H2; + case (Hp2 H1); intros _ tmp; contradict tmp; apply Zle_not_lt; + unfold base. + apply Zle_trans with (2 ^ Zpos p * 1); auto with zarith. + autorewrite with rm10; apply Zpower_le_monotone; auto with zarith. + assert (U1: Zpos (Pdiv2 p) < Zpos (ww_digits w_digits)); auto with zarith. + match goal with |- context[ww_add_mul_div ?y ?z ?t] => + assert (UU:= spec_ww_add_mul_div z t ); + generalize (UU p U0); + case (ww_add_mul_div y z t) + end. + simpl ww_to_Z; autorewrite with w_rewrite rm10. + rewrite Zmod_def_small; auto with zarith. + intros H2; case (Zmult_integral _ _ (sym_equal H2)); clear H2; intros H2. + rewrite H2; unfold Zpower, Zpower_pos; simpl; auto with zarith. + match type of H2 with ?X = ?Y => + absurd (Y < X); try (rewrite H2; auto with zarith; fail) + end. + apply Zpower_lt_0; auto with zarith. + split; auto with zarith. + case (Hp2 H1); intros _ tmp; apply Zle_lt_trans with (2 := tmp); + clear tmp. + rewrite Zmult_comm; apply Zmult_le_compat_r; auto with zarith. + intros w0 w1; autorewrite with w_rewrite rm10. + rewrite Zmod_def_small; auto with zarith. + 2: rewrite Zmult_comm; auto with zarith. + intros H2. + assert (V: wB/4 <= [|w0|]). + apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. + simpl ww_to_Z in H2; rewrite H2. + rewrite <- wwB_4_wB_4; auto with zarith. + rewrite Zmult_comm; auto with zarith. + assert (V1 := spec_to_Z w1);auto with zarith. + generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. + case (w_sqrt2 w0 w1); intros w2 c. + simpl ww_to_Z; simpl fst. + assert (U2: Zpos (Pdiv2 p) < Zpos w_digits). + apply Zmult_lt_reg_r with 2; auto with zarith. + repeat rewrite (fun x => Zmult_comm x 2). + rewrite Hp3. + rewrite <- Zpos_xO; auto. + autorewrite with w_rewrite rm10. + 2: rewrite Zpos_minus; auto with zarith; auto. + rewrite Zpos_minus; auto with zarith. + match goal with |- context[?X - (?X -?Y)] => + replace (X - (X - Y)) with Y; try ring + end. + assert (V2 := spec_to_Z w2);auto with zarith. + rewrite Zmod_def_small; auto with zarith. + simpl ww_to_Z in H2; rewrite H2; auto with zarith. + intros (H4, H5); split. + apply Zmult_le_reg_r with (2 ^ Zpos p); auto with zarith. + rewrite H4. + apply Zle_trans with ([|w2|] ^ 2); auto with zarith. + repeat rewrite (fun x => Zmult_comm x (2 ^ Zpos p)). + rewrite <- Hp3; rewrite (Zmult_comm 2); rewrite Zpower_mult; + auto with zarith. + assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); + try (intros; repeat rewrite Zsquare_mult; ring); + rewrite tmp; clear tmp. + apply ZPowerAux.Zpower_le_monotone_exp; auto with zarith. + split; auto with zarith. + pattern [|w2|] at 2; rewrite (Z_div_mod_eq [|w2|] (2 ^ Zpos (Pdiv2 p))); + auto with zarith. + match goal with |- ?X <= ?X + ?Y => + assert (0 <= Y); auto with zarith + end. + case (Z_mod_lt [|w2|] (2 ^ Zpos (Pdiv2 p))); auto with zarith. + case c; unfold interp_carry; autorewrite with rm10; + intros w3; assert (V3 := spec_to_Z w3);auto with zarith. + apply Zmult_lt_reg_r with (2 ^ Zpos p); auto with zarith. + rewrite H4. + apply Zle_lt_trans with ([|w2|] ^ 2 + 2 * [|w2|]); auto with zarith. + apply Zlt_le_trans with (([|w2|] + 1) ^ 2); auto with zarith. + match goal with |- ?X < ?Y => + replace Y with (X + 1); auto with zarith + end. + repeat rewrite (Zsquare_mult); ring. + repeat rewrite (fun x => Zmult_comm x (2 ^ Zpos p)). + rewrite <- Hp3; rewrite (Zmult_comm 2); rewrite Zpower_mult; + auto with zarith. + assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); + try (intros; repeat rewrite Zsquare_mult; ring); + rewrite tmp; clear tmp. + apply ZPowerAux.Zpower_le_monotone_exp; auto with zarith. + split; auto with zarith. + pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] (2 ^ Zpos (Pdiv2 p))); + auto with zarith. + rewrite <- Zplus_assoc; rewrite Zmult_plus_distr_r. + autorewrite with rm10; apply Zplus_le_compat_l; auto with zarith. + case (Z_mod_lt [|w2|] (2 ^ Zpos (Pdiv2 p))); auto with zarith. + split; auto with zarith. + apply Zle_lt_trans with ([|w2|]); auto with zarith. + apply Zdiv_le_upper_bound; auto with zarith. + pattern [|w2|] at 1; replace [|w2|] with ([|w2|] * 2 ^0); + auto with zarith. + apply Zmult_le_compat_l; auto with zarith. + apply Zpower_le_monotone; auto with zarith. + rewrite Zpower_exp_0; autorewrite with rm10; auto. + Qed. + +End GenSqrt. diff --git a/theories/Ints/num/GenSub.v b/theories/Ints/num/GenSub.v new file mode 100644 index 000000000..43661edd5 --- /dev/null +++ b/theories/Ints/num/GenSub.v @@ -0,0 +1,354 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZAux. +Require Import ZDivModAux. +Require Import Basic_type. +Require Import GenBase. + +Open Local Scope Z_scope. + +Section GenSub. + Variable w : Set. + Variable w_0 : w. + Variable w_Bm1 : w. + Variable w_WW : w -> w -> zn2z w. + Variable ww_Bm1 : zn2z w. + Variable w_opp_c : w -> carry w. + Variable w_opp_carry : w -> w. + Variable w_pred_c : w -> carry w. + Variable w_sub_c : w -> w -> carry w. + Variable w_sub_carry_c : w -> w -> carry w. + Variable w_opp : w -> w. + Variable w_pred : w -> w. + Variable w_sub : w -> w -> w. + Variable w_sub_carry : w -> w -> w. + + (* ** Opposites ** *) + Definition ww_opp_c x := + match x with + | W0 => C0 W0 + | WW xh xl => + match w_opp_c xl with + | C0 _ => + match w_opp_c xh with + | C0 h => C0 W0 + | C1 h => C1 (WW h w_0) + end + | C1 l => C1 (WW (w_opp_carry xh) l) + end + end. + + Definition ww_opp x := + match x with + | W0 => W0 + | WW xh xl => + match w_opp_c xl with + | C0 _ => WW (w_opp xh) w_0 + | C1 l => WW (w_opp_carry xh) l + end + end. + + Definition ww_opp_carry x := + match x with + | W0 => ww_Bm1 + | WW xh xl => w_WW (w_opp_carry xh) (w_opp_carry xl) + end. + + Definition ww_pred_c x := + match x with + | W0 => C1 ww_Bm1 + | WW xh xl => + match w_pred_c xl with + | C0 l => C0 (w_WW xh l) + | C1 _ => + match w_pred_c xh with + | C0 h => C0 (WW h w_Bm1) + | C1 _ => C1 ww_Bm1 + end + end + end. + + Definition ww_pred x := + match x with + | W0 => ww_Bm1 + | WW xh xl => + match w_pred_c xl with + | C0 l => w_WW xh l + | C1 l => WW (w_pred xh) w_Bm1 + end + end. + + Definition ww_sub_c x y := + match y, x with + | W0, _ => C0 x + | WW yh yl, W0 => ww_opp_c (WW yh yl) + | WW yh yl, WW xh xl => + match w_sub_c xl yl with + | C0 l => + match w_sub_c xh yh with + | C0 h => C0 (w_WW h l) + | C1 h => C1 (WW h l) + end + | C1 l => + match w_sub_carry_c xh yh with + | C0 h => C0 (WW h l) + | C1 h => C1 (WW h l) + end + end + end. + + Definition ww_sub x y := + match y, x with + | W0, _ => x + | WW yh yl, W0 => ww_opp (WW yh yl) + | WW yh yl, WW xh xl => + match w_sub_c xl yl with + | C0 l => w_WW (w_sub xh yh) l + | C1 l => WW (w_sub_carry xh yh) l + end + end. + + Definition ww_sub_carry_c x y := + match y, x with + | W0, W0 => C1 ww_Bm1 + | W0, WW xh xl => ww_pred_c (WW xh xl) + | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl)) + | WW yh yl, WW xh xl => + match w_sub_carry_c xl yl with + | C0 l => + match w_sub_c xh yh with + | C0 h => C0 (w_WW h l) + | C1 h => C1 (WW h l) + end + | C1 l => + match w_sub_carry_c xh yh with + | C0 h => C0 (w_WW h l) + | C1 h => C1 (w_WW h l) + end + end + end. + + Definition ww_sub_carry x y := + match y, x with + | W0, W0 => ww_Bm1 + | W0, WW xh xl => ww_pred (WW xh xl) + | WW yh yl, W0 => ww_opp_carry (WW yh yl) + | WW yh yl, WW xh xl => + match w_sub_carry_c xl yl with + | C0 l => w_WW (w_sub xh yh) l + | C1 l => w_WW (w_sub_carry xh yh) l + end + end. + + (*Section GenProof.*) + Variable w_digits : positive. + Variable w_to_Z : w -> Z. + + + Notation wB := (base w_digits). + Notation wwB := (base (ww_digits w_digits)). + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + Notation "[+| c |]" := + (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). + Notation "[-| c |]" := + (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + + Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + (at level 0, x at level 99). + + Variable spec_w_0 : [|w_0|] = 0. + Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. + Variable spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. + Variable spec_to_Z : forall x, 0 <= [|x|] < wB. + Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. + + Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. + Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. + Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. + + Variable spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1. + Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. + Variable spec_sub_carry_c : + forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1. + + Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. + Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. + Variable spec_sub_carry : + forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. + + + Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]]. + Proof. + destruct x as [ |xh xl];simpl. reflexivity. + rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) + as [l|l];intros H;unfold interp_carry in H;rewrite <- H; + rewrite Zopp_mult_distr_l. + assert ([|l|] = 0). + assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. + rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) + as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1. + assert ([|h|] = 0). + assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. + rewrite H2;reflexivity. + simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_w_0;ring. + unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_opp_carry; + ring. + Qed. + + Lemma spec_ww_opp : forall x, [[ww_opp x]] = (-[[x]]) mod wwB. + Proof. + destruct x as [ |xh xl];simpl. reflexivity. + rewrite Zopp_plus_distr;rewrite Zopp_mult_distr_l. + generalize (spec_opp_c xl);destruct (w_opp_c xl) + as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. + rewrite spec_w_0;rewrite Zplus_0_r;rewrite wwB_wBwB. + assert ([|l|] = 0). + assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. + rewrite H0;rewrite Zplus_0_r; rewrite Zpower_2; + rewrite Zmult_mod_distr_r;try apply lt_0_wB. + rewrite spec_opp;trivial. + apply Zmod_unique with (q:= -1). apply lt_0_wwB. + exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW (w_opp_carry xh) l)). + rewrite spec_opp_carry;rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_opp_carry : forall x, [[ww_opp_carry x]] = wwB - [[x]] - 1. + Proof. + destruct x as [ |xh xl];simpl. rewrite spec_ww_Bm1;ring. + rewrite spec_w_WW;simpl;repeat rewrite spec_opp_carry;rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. + Proof. + destruct x as [ |xh xl];unfold ww_pred_c. + unfold interp_carry;rewrite spec_ww_Bm1;simpl ww_to_Z;ring. + simpl ww_to_Z;replace (([|xh|]*wB+[|xl|])-1) with ([|xh|]*wB+([|xl|]-1)). + 2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l]; + intros H;unfold interp_carry in H;rewrite <- H. simpl;apply spec_w_WW. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + assert ([|l|] = wB - 1). + assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. + rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1). + generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h]; + intros H1;unfold interp_carry in H1;rewrite <- H1. + simpl;rewrite spec_w_Bm1;ring. + assert ([|h|] = wB - 1). + assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. + rewrite H2;unfold interp_carry;rewrite spec_ww_Bm1;rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. + Proof. + destruct y as [ |yh yl];simpl. ring. + destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)). + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) + with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring. + generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H; + unfold interp_carry in H;rewrite <- H. + generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; + unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; + try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). + generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; + intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z; + try rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_sub_carry_c : + forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1. + Proof. + destruct y as [ |yh yl];simpl. + unfold Zminus;simpl;rewrite Zplus_0_r;exact (spec_ww_pred_c x). + destruct x as [ |xh xl]. + unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB; + repeat rewrite spec_opp_carry;ring. + simpl ww_to_Z. + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) + with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring. + generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) + as [l|l];intros H;unfold interp_carry in H;rewrite <- H. + generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; + unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; + try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). + generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; + intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW; + simpl ww_to_Z; try rewrite wwB_wBwB;ring. + Qed. + + Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. + Proof. + destruct x as [ |xh xl];simpl. + apply Zmod_unique with (-1). apply lt_0_wwB. apply spec_ww_to_Z;trivial. + rewrite spec_ww_Bm1;ring. + replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring. + generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H; + unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. + rewrite Zmod_def_small. apply spec_w_WW. + exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)). + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + change ([|xh|] + -1) with ([|xh|] - 1). + assert ([|l|] = wB - 1). + assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega. + rewrite (mod_wwB w_digits w_to_Z);trivial. + rewrite spec_pred;rewrite spec_w_Bm1;rewrite <- H0;trivial. + Qed. + + Lemma spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. + Proof. + destruct y as [ |yh yl];simpl. + ring_simplify ([[x]] - 0);rewrite Zmod_def_small;trivial. apply spec_ww_to_Z;trivial. + destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)). + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) + with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring. + generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H; + unfold interp_carry in H;rewrite <- H. + rewrite spec_w_WW;rewrite (mod_wwB w_digits w_to_Z spec_to_Z). + rewrite spec_sub;trivial. + simpl ww_to_Z;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. + Qed. + + Lemma spec_ww_sub_carry : + forall x y, [[ww_sub_carry x y]] = ([[x]] - [[y]] - 1) mod wwB. + Proof. + destruct y as [ |yh yl];simpl. + ring_simplify ([[x]] - 0);exact (spec_ww_pred x). + destruct x as [ |xh xl];simpl. + apply Zmod_unique with (-1). apply lt_0_wwB. + apply spec_ww_to_Z;trivial. + fold (ww_opp_carry (WW yh yl)). + rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring. + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) + with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring. + generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l]; + intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW. + rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub;trivial. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. + Qed. + +(* End GenProof. *) + +End GenSub. + + + + + diff --git a/theories/Ints/num/NMake.v b/theories/Ints/num/NMake.v new file mode 100644 index 000000000..c7cd3360f --- /dev/null +++ b/theories/Ints/num/NMake.v @@ -0,0 +1,3473 @@ +Require Import ZArith. +Require Import Basic_type. +Require Import ZnZ. +Require Import Zn2Z. +Require Import Nbasic. +Require Import GenMul. +Require Import GenDivn1. + + + +Fixpoint plength (p: positive) : positive := + match p with + xH => xH + | xO p1 => Psucc (plength p1) + | xI p1 => Psucc (plength p1) + end. + +Definition pheight p := plength (Ppred (plength (Ppred p))). + +Module Type W0Type. + Parameter w : Set. + Parameter w_op : znz_op w. + Parameter w_spec : znz_spec w_op. +End W0Type. + +Module Make (W0:W0Type). + Import W0. + + Definition w0 := W0.w. + Definition w1 := zn2z w0. + Definition w2 := zn2z w1. + Definition w3 := zn2z w2. + Definition w4 := zn2z w3. + Definition w5 := zn2z w4. + Definition w6 := zn2z w5. + Definition w7 := zn2z w6. + Definition w8 := zn2z w7. + Definition w9 := zn2z w8. + Definition w10 := zn2z w9. + Definition w11 := zn2z w10. + Definition w12 := zn2z w11. + + Definition w0_op := W0.w_op. + Definition w1_op := mk_zn2z_op w0_op. + Definition w2_op := mk_zn2z_op w1_op. + Definition w3_op := mk_zn2z_op w2_op. + Definition w4_op := mk_zn2z_op_karatsuba w3_op. + Definition w5_op := mk_zn2z_op_karatsuba w4_op. + Definition w6_op := mk_zn2z_op_karatsuba w5_op. + Definition w7_op := mk_zn2z_op_karatsuba w6_op. + Definition w8_op := mk_zn2z_op_karatsuba w7_op. + Definition w9_op := mk_zn2z_op_karatsuba w8_op. + Definition w10_op := mk_zn2z_op_karatsuba w9_op. + Definition w11_op := mk_zn2z_op_karatsuba w10_op. + Definition w12_op := mk_zn2z_op_karatsuba w11_op. + Definition w13_op := mk_zn2z_op_karatsuba w12_op. + Definition w14_op := mk_zn2z_op_karatsuba w13_op. + Definition w15_op := mk_zn2z_op_karatsuba w14_op. + + Section Make_op. + Variable mk : forall w', znz_op w' -> znz_op (zn2z w'). + + Fixpoint make_op_aux (n:nat) : znz_op (word w12 (S n)):= + match n return znz_op (word w12 (S n)) with + | O => w13_op + | S n1 => + match n1 return znz_op (word w12 (S (S n1))) with + | O => w14_op + | S n2 => + match n2 return znz_op (word w12 (S (S (S n2)))) with + | O => w15_op + | S n3 => mk _ (mk _ (mk _ (make_op_aux n3))) + end + end + end. + + End Make_op. + + Definition make_op := make_op_aux mk_zn2z_op_karatsuba. + + Inductive t_ : Set := + | N0 : w0 -> t_ + | N1 : w1 -> t_ + | N2 : w2 -> t_ + | N3 : w3 -> t_ + | N4 : w4 -> t_ + | N5 : w5 -> t_ + | N6 : w6 -> t_ + | N7 : w7 -> t_ + | N8 : w8 -> t_ + | N9 : w9 -> t_ + | N10 : w10 -> t_ + | N11 : w11 -> t_ + | N12 : w12 -> t_ + | Nn : forall n, word w12 (S n) -> t_. + + Definition t := t_. + + Definition w_0 := w0_op.(znz_0). + + Definition one0 := w0_op.(znz_1). + Definition one1 := w1_op.(znz_1). + Definition one2 := w2_op.(znz_1). + Definition one3 := w3_op.(znz_1). + Definition one4 := w4_op.(znz_1). + Definition one5 := w5_op.(znz_1). + Definition one6 := w6_op.(znz_1). + Definition one7 := w7_op.(znz_1). + Definition one8 := w8_op.(znz_1). + Definition one9 := w9_op.(znz_1). + Definition one10 := w10_op.(znz_1). + Definition one11 := w11_op.(znz_1). + Definition one12 := w12_op.(znz_1). + + Definition zero := N0 w_0. + Definition one := N0 one0. + + Definition w0_succ_c := w0_op.(znz_succ_c). + Definition w1_succ_c := w1_op.(znz_succ_c). + Definition w2_succ_c := w2_op.(znz_succ_c). + Definition w3_succ_c := w3_op.(znz_succ_c). + Definition w4_succ_c := w4_op.(znz_succ_c). + Definition w5_succ_c := w5_op.(znz_succ_c). + Definition w6_succ_c := w6_op.(znz_succ_c). + Definition w7_succ_c := w7_op.(znz_succ_c). + Definition w8_succ_c := w8_op.(znz_succ_c). + Definition w9_succ_c := w9_op.(znz_succ_c). + Definition w10_succ_c := w10_op.(znz_succ_c). + Definition w11_succ_c := w11_op.(znz_succ_c). + Definition w12_succ_c := w12_op.(znz_succ_c). + + Definition w0_succ := w0_op.(znz_succ). + Definition w1_succ := w1_op.(znz_succ). + Definition w2_succ := w2_op.(znz_succ). + Definition w3_succ := w3_op.(znz_succ). + Definition w4_succ := w4_op.(znz_succ). + Definition w5_succ := w5_op.(znz_succ). + Definition w6_succ := w6_op.(znz_succ). + Definition w7_succ := w7_op.(znz_succ). + Definition w8_succ := w8_op.(znz_succ). + Definition w9_succ := w9_op.(znz_succ). + Definition w10_succ := w10_op.(znz_succ). + Definition w11_succ := w11_op.(znz_succ). + Definition w12_succ := w12_op.(znz_succ). + + Definition succ x := + match x with + | N0 wx => + match w0_succ_c wx with + | C0 r => N0 r + | C1 r => N1 (WW one0 r) + end + | N1 wx => + match w1_succ_c wx with + | C0 r => N1 r + | C1 r => N2 (WW one1 r) + end + | N2 wx => + match w2_succ_c wx with + | C0 r => N2 r + | C1 r => N3 (WW one2 r) + end + | N3 wx => + match w3_succ_c wx with + | C0 r => N3 r + | C1 r => N4 (WW one3 r) + end + | N4 wx => + match w4_succ_c wx with + | C0 r => N4 r + | C1 r => N5 (WW one4 r) + end + | N5 wx => + match w5_succ_c wx with + | C0 r => N5 r + | C1 r => N6 (WW one5 r) + end + | N6 wx => + match w6_succ_c wx with + | C0 r => N6 r + | C1 r => N7 (WW one6 r) + end + | N7 wx => + match w7_succ_c wx with + | C0 r => N7 r + | C1 r => N8 (WW one7 r) + end + | N8 wx => + match w8_succ_c wx with + | C0 r => N8 r + | C1 r => N9 (WW one8 r) + end + | N9 wx => + match w9_succ_c wx with + | C0 r => N9 r + | C1 r => N10 (WW one9 r) + end + | N10 wx => + match w10_succ_c wx with + | C0 r => N10 r + | C1 r => N11 (WW one10 r) + end + | N11 wx => + match w11_succ_c wx with + | C0 r => N11 r + | C1 r => N12 (WW one11 r) + end + | N12 wx => + match w12_succ_c wx with + | C0 r => N12 r + | C1 r => Nn 0 (WW one12 r) + end + | Nn n wx => + let op := make_op n in + match op.(znz_succ_c) wx with + | C0 r => Nn n r + | C1 r => Nn (S n) (WW op.(znz_1) r) + end + end. + + Definition extend1 := + Eval lazy beta zeta iota delta [extend]in extend 1. + Definition extend2 := + Eval lazy beta zeta iota delta [extend]in extend 2. + Definition extend3 := + Eval lazy beta zeta iota delta [extend]in extend 3. + Definition extend4 := + Eval lazy beta zeta iota delta [extend]in extend 4. + Definition extend5 := + Eval lazy beta zeta iota delta [extend]in extend 5. + Definition extend6 := + Eval lazy beta zeta iota delta [extend]in extend 6. + Definition extend7 := + Eval lazy beta zeta iota delta [extend]in extend 7. + Definition extend8 := + Eval lazy beta zeta iota delta [extend]in extend 8. + Definition extend9 := + Eval lazy beta zeta iota delta [extend]in extend 9. + Definition extend10 := + Eval lazy beta zeta iota delta [extend]in extend 10. + Definition extend11 := + Eval lazy beta zeta iota delta [extend]in extend 11. + Definition extend12 := + Eval lazy beta zeta iota delta [extend]in extend 12. + + Definition w0_eq0 := w0_op.(znz_eq0). + Definition w1_eq0 := w1_op.(znz_eq0). + Definition w2_eq0 := w2_op.(znz_eq0). + Definition w3_eq0 := w3_op.(znz_eq0). + Definition w4_eq0 := w4_op.(znz_eq0). + Definition w5_eq0 := w5_op.(znz_eq0). + Definition w6_eq0 := w6_op.(znz_eq0). + Definition w7_eq0 := w7_op.(znz_eq0). + Definition w8_eq0 := w8_op.(znz_eq0). + Definition w9_eq0 := w9_op.(znz_eq0). + Definition w10_eq0 := w10_op.(znz_eq0). + Definition w11_eq0 := w11_op.(znz_eq0). + Definition w12_eq0 := w12_op.(znz_eq0). + + + Definition w0_add_c := w0_op.(znz_add_c). + Definition w1_add_c := w1_op.(znz_add_c). + Definition w2_add_c := w2_op.(znz_add_c). + Definition w3_add_c := w3_op.(znz_add_c). + Definition w4_add_c := w4_op.(znz_add_c). + Definition w5_add_c := w5_op.(znz_add_c). + Definition w6_add_c := w6_op.(znz_add_c). + Definition w7_add_c := w7_op.(znz_add_c). + Definition w8_add_c := w8_op.(znz_add_c). + Definition w9_add_c := w9_op.(znz_add_c). + Definition w10_add_c := w10_op.(znz_add_c). + Definition w11_add_c := w11_op.(znz_add_c). + Definition w12_add_c := w12_op.(znz_add_c). + + Definition w0_add x y := + match w0_add_c x y with + | C0 r => N0 r + | C1 r => N1 (WW one0 r) + end. + Definition w1_add x y := + match w1_add_c x y with + | C0 r => N1 r + | C1 r => N2 (WW one1 r) + end. + Definition w2_add x y := + match w2_add_c x y with + | C0 r => N2 r + | C1 r => N3 (WW one2 r) + end. + Definition w3_add x y := + match w3_add_c x y with + | C0 r => N3 r + | C1 r => N4 (WW one3 r) + end. + Definition w4_add x y := + match w4_add_c x y with + | C0 r => N4 r + | C1 r => N5 (WW one4 r) + end. + Definition w5_add x y := + match w5_add_c x y with + | C0 r => N5 r + | C1 r => N6 (WW one5 r) + end. + Definition w6_add x y := + match w6_add_c x y with + | C0 r => N6 r + | C1 r => N7 (WW one6 r) + end. + Definition w7_add x y := + match w7_add_c x y with + | C0 r => N7 r + | C1 r => N8 (WW one7 r) + end. + Definition w8_add x y := + match w8_add_c x y with + | C0 r => N8 r + | C1 r => N9 (WW one8 r) + end. + Definition w9_add x y := + match w9_add_c x y with + | C0 r => N9 r + | C1 r => N10 (WW one9 r) + end. + Definition w10_add x y := + match w10_add_c x y with + | C0 r => N10 r + | C1 r => N11 (WW one10 r) + end. + Definition w11_add x y := + match w11_add_c x y with + | C0 r => N11 r + | C1 r => N12 (WW one11 r) + end. + Definition w12_add x y := + match w12_add_c x y with + | C0 r => N12 r + | C1 r => Nn 0 (WW one12 r) + end. + Definition addn n (x y : word w12 (S n)) := + let op := make_op n in + match op.(znz_add_c) x y with + | C0 r => Nn n r + | C1 r => Nn (S n) (WW op.(znz_1) r) end. + + Definition add x y := + match x, y with + | N0 wx, N0 wy => w0_add wx wy + | N0 wx, N1 wy => + if w0_eq0 wx then y else w1_add (WW w_0 wx) wy + | N0 wx, N2 wy => + if w0_eq0 wx then y else w2_add (extend1 w0 (WW w_0 wx)) wy + | N0 wx, N3 wy => + if w0_eq0 wx then y else w3_add (extend2 w0 (WW w_0 wx)) wy + | N0 wx, N4 wy => + if w0_eq0 wx then y else w4_add (extend3 w0 (WW w_0 wx)) wy + | N0 wx, N5 wy => + if w0_eq0 wx then y else w5_add (extend4 w0 (WW w_0 wx)) wy + | N0 wx, N6 wy => + if w0_eq0 wx then y else w6_add (extend5 w0 (WW w_0 wx)) wy + | N0 wx, N7 wy => + if w0_eq0 wx then y else w7_add (extend6 w0 (WW w_0 wx)) wy + | N0 wx, N8 wy => + if w0_eq0 wx then y else w8_add (extend7 w0 (WW w_0 wx)) wy + | N0 wx, N9 wy => + if w0_eq0 wx then y else w9_add (extend8 w0 (WW w_0 wx)) wy + | N0 wx, N10 wy => + if w0_eq0 wx then y else w10_add (extend9 w0 (WW w_0 wx)) wy + | N0 wx, N11 wy => + if w0_eq0 wx then y else w11_add (extend10 w0 (WW w_0 wx)) wy + | N0 wx, N12 wy => + if w0_eq0 wx then y else w12_add (extend11 w0 (WW w_0 wx)) wy + | N0 wx, Nn n wy => + if w0_eq0 wx then y + else addn n (extend n w12 (extend12 w0 (WW w_0 wx))) wy + | N1 wx, N0 wy => + if w0_eq0 wy then x else w1_add wx (WW w_0 wy) + | N1 wx, N1 wy => w1_add wx wy + | N1 wx, N2 wy => w2_add (extend1 w0 wx) wy + | N1 wx, N3 wy => w3_add (extend2 w0 wx) wy + | N1 wx, N4 wy => w4_add (extend3 w0 wx) wy + | N1 wx, N5 wy => w5_add (extend4 w0 wx) wy + | N1 wx, N6 wy => w6_add (extend5 w0 wx) wy + | N1 wx, N7 wy => w7_add (extend6 w0 wx) wy + | N1 wx, N8 wy => w8_add (extend7 w0 wx) wy + | N1 wx, N9 wy => w9_add (extend8 w0 wx) wy + | N1 wx, N10 wy => w10_add (extend9 w0 wx) wy + | N1 wx, N11 wy => w11_add (extend10 w0 wx) wy + | N1 wx, N12 wy => w12_add (extend11 w0 wx) wy + | N1 wx, Nn n wy => addn n (extend n w12 (extend12 w0 wx)) wy + | N2 wx, N0 wy => + if w0_eq0 wy then x else w2_add wx (extend1 w0 (WW w_0 wy)) + | N2 wx, N1 wy => w2_add wx (extend1 w0 wy) + | N2 wx, N2 wy => w2_add wx wy + | N2 wx, N3 wy => w3_add (extend1 w1 wx) wy + | N2 wx, N4 wy => w4_add (extend2 w1 wx) wy + | N2 wx, N5 wy => w5_add (extend3 w1 wx) wy + | N2 wx, N6 wy => w6_add (extend4 w1 wx) wy + | N2 wx, N7 wy => w7_add (extend5 w1 wx) wy + | N2 wx, N8 wy => w8_add (extend6 w1 wx) wy + | N2 wx, N9 wy => w9_add (extend7 w1 wx) wy + | N2 wx, N10 wy => w10_add (extend8 w1 wx) wy + | N2 wx, N11 wy => w11_add (extend9 w1 wx) wy + | N2 wx, N12 wy => w12_add (extend10 w1 wx) wy + | N2 wx, Nn n wy => addn n (extend n w12 (extend11 w1 wx)) wy + | N3 wx, N0 wy => + if w0_eq0 wy then x else w3_add wx (extend2 w0 (WW w_0 wy)) + | N3 wx, N1 wy => w3_add wx (extend2 w0 wy) + | N3 wx, N2 wy => w3_add wx (extend1 w1 wy) + | N3 wx, N3 wy => w3_add wx wy + | N3 wx, N4 wy => w4_add (extend1 w2 wx) wy + | N3 wx, N5 wy => w5_add (extend2 w2 wx) wy + | N3 wx, N6 wy => w6_add (extend3 w2 wx) wy + | N3 wx, N7 wy => w7_add (extend4 w2 wx) wy + | N3 wx, N8 wy => w8_add (extend5 w2 wx) wy + | N3 wx, N9 wy => w9_add (extend6 w2 wx) wy + | N3 wx, N10 wy => w10_add (extend7 w2 wx) wy + | N3 wx, N11 wy => w11_add (extend8 w2 wx) wy + | N3 wx, N12 wy => w12_add (extend9 w2 wx) wy + | N3 wx, Nn n wy => addn n (extend n w12 (extend10 w2 wx)) wy + | N4 wx, N0 wy => + if w0_eq0 wy then x else w4_add wx (extend3 w0 (WW w_0 wy)) + | N4 wx, N1 wy => w4_add wx (extend3 w0 wy) + | N4 wx, N2 wy => w4_add wx (extend2 w1 wy) + | N4 wx, N3 wy => w4_add wx (extend1 w2 wy) + | N4 wx, N4 wy => w4_add wx wy + | N4 wx, N5 wy => w5_add (extend1 w3 wx) wy + | N4 wx, N6 wy => w6_add (extend2 w3 wx) wy + | N4 wx, N7 wy => w7_add (extend3 w3 wx) wy + | N4 wx, N8 wy => w8_add (extend4 w3 wx) wy + | N4 wx, N9 wy => w9_add (extend5 w3 wx) wy + | N4 wx, N10 wy => w10_add (extend6 w3 wx) wy + | N4 wx, N11 wy => w11_add (extend7 w3 wx) wy + | N4 wx, N12 wy => w12_add (extend8 w3 wx) wy + | N4 wx, Nn n wy => addn n (extend n w12 (extend9 w3 wx)) wy + | N5 wx, N0 wy => + if w0_eq0 wy then x else w5_add wx (extend4 w0 (WW w_0 wy)) + | N5 wx, N1 wy => w5_add wx (extend4 w0 wy) + | N5 wx, N2 wy => w5_add wx (extend3 w1 wy) + | N5 wx, N3 wy => w5_add wx (extend2 w2 wy) + | N5 wx, N4 wy => w5_add wx (extend1 w3 wy) + | N5 wx, N5 wy => w5_add wx wy + | N5 wx, N6 wy => w6_add (extend1 w4 wx) wy + | N5 wx, N7 wy => w7_add (extend2 w4 wx) wy + | N5 wx, N8 wy => w8_add (extend3 w4 wx) wy + | N5 wx, N9 wy => w9_add (extend4 w4 wx) wy + | N5 wx, N10 wy => w10_add (extend5 w4 wx) wy + | N5 wx, N11 wy => w11_add (extend6 w4 wx) wy + | N5 wx, N12 wy => w12_add (extend7 w4 wx) wy + | N5 wx, Nn n wy => addn n (extend n w12 (extend8 w4 wx)) wy + | N6 wx, N0 wy => + if w0_eq0 wy then x else w6_add wx (extend5 w0 (WW w_0 wy)) + | N6 wx, N1 wy => w6_add wx (extend5 w0 wy) + | N6 wx, N2 wy => w6_add wx (extend4 w1 wy) + | N6 wx, N3 wy => w6_add wx (extend3 w2 wy) + | N6 wx, N4 wy => w6_add wx (extend2 w3 wy) + | N6 wx, N5 wy => w6_add wx (extend1 w4 wy) + | N6 wx, N6 wy => w6_add wx wy + | N6 wx, N7 wy => w7_add (extend1 w5 wx) wy + | N6 wx, N8 wy => w8_add (extend2 w5 wx) wy + | N6 wx, N9 wy => w9_add (extend3 w5 wx) wy + | N6 wx, N10 wy => w10_add (extend4 w5 wx) wy + | N6 wx, N11 wy => w11_add (extend5 w5 wx) wy + | N6 wx, N12 wy => w12_add (extend6 w5 wx) wy + | N6 wx, Nn n wy => addn n (extend n w12 (extend7 w5 wx)) wy + | N7 wx, N0 wy => + if w0_eq0 wy then x else w7_add wx (extend6 w0 (WW w_0 wy)) + | N7 wx, N1 wy => w7_add wx (extend6 w0 wy) + | N7 wx, N2 wy => w7_add wx (extend5 w1 wy) + | N7 wx, N3 wy => w7_add wx (extend4 w2 wy) + | N7 wx, N4 wy => w7_add wx (extend3 w3 wy) + | N7 wx, N5 wy => w7_add wx (extend2 w4 wy) + | N7 wx, N6 wy => w7_add wx (extend1 w5 wy) + | N7 wx, N7 wy => w7_add wx wy + | N7 wx, N8 wy => w8_add (extend1 w6 wx) wy + | N7 wx, N9 wy => w9_add (extend2 w6 wx) wy + | N7 wx, N10 wy => w10_add (extend3 w6 wx) wy + | N7 wx, N11 wy => w11_add (extend4 w6 wx) wy + | N7 wx, N12 wy => w12_add (extend5 w6 wx) wy + | N7 wx, Nn n wy => addn n (extend n w12 (extend6 w6 wx)) wy + | N8 wx, N0 wy => + if w0_eq0 wy then x else w8_add wx (extend7 w0 (WW w_0 wy)) + | N8 wx, N1 wy => w8_add wx (extend7 w0 wy) + | N8 wx, N2 wy => w8_add wx (extend6 w1 wy) + | N8 wx, N3 wy => w8_add wx (extend5 w2 wy) + | N8 wx, N4 wy => w8_add wx (extend4 w3 wy) + | N8 wx, N5 wy => w8_add wx (extend3 w4 wy) + | N8 wx, N6 wy => w8_add wx (extend2 w5 wy) + | N8 wx, N7 wy => w8_add wx (extend1 w6 wy) + | N8 wx, N8 wy => w8_add wx wy + | N8 wx, N9 wy => w9_add (extend1 w7 wx) wy + | N8 wx, N10 wy => w10_add (extend2 w7 wx) wy + | N8 wx, N11 wy => w11_add (extend3 w7 wx) wy + | N8 wx, N12 wy => w12_add (extend4 w7 wx) wy + | N8 wx, Nn n wy => addn n (extend n w12 (extend5 w7 wx)) wy + | N9 wx, N0 wy => + if w0_eq0 wy then x else w9_add wx (extend8 w0 (WW w_0 wy)) + | N9 wx, N1 wy => w9_add wx (extend8 w0 wy) + | N9 wx, N2 wy => w9_add wx (extend7 w1 wy) + | N9 wx, N3 wy => w9_add wx (extend6 w2 wy) + | N9 wx, N4 wy => w9_add wx (extend5 w3 wy) + | N9 wx, N5 wy => w9_add wx (extend4 w4 wy) + | N9 wx, N6 wy => w9_add wx (extend3 w5 wy) + | N9 wx, N7 wy => w9_add wx (extend2 w6 wy) + | N9 wx, N8 wy => w9_add wx (extend1 w7 wy) + | N9 wx, N9 wy => w9_add wx wy + | N9 wx, N10 wy => w10_add (extend1 w8 wx) wy + | N9 wx, N11 wy => w11_add (extend2 w8 wx) wy + | N9 wx, N12 wy => w12_add (extend3 w8 wx) wy + | N9 wx, Nn n wy => addn n (extend n w12 (extend4 w8 wx)) wy + | N10 wx, N0 wy => + if w0_eq0 wy then x else w10_add wx (extend9 w0 (WW w_0 wy)) + | N10 wx, N1 wy => w10_add wx (extend9 w0 wy) + | N10 wx, N2 wy => w10_add wx (extend8 w1 wy) + | N10 wx, N3 wy => w10_add wx (extend7 w2 wy) + | N10 wx, N4 wy => w10_add wx (extend6 w3 wy) + | N10 wx, N5 wy => w10_add wx (extend5 w4 wy) + | N10 wx, N6 wy => w10_add wx (extend4 w5 wy) + | N10 wx, N7 wy => w10_add wx (extend3 w6 wy) + | N10 wx, N8 wy => w10_add wx (extend2 w7 wy) + | N10 wx, N9 wy => w10_add wx (extend1 w8 wy) + | N10 wx, N10 wy => w10_add wx wy + | N10 wx, N11 wy => w11_add (extend1 w9 wx) wy + | N10 wx, N12 wy => w12_add (extend2 w9 wx) wy + | N10 wx, Nn n wy => addn n (extend n w12 (extend3 w9 wx)) wy + | N11 wx, N0 wy => + if w0_eq0 wy then x else w11_add wx (extend10 w0 (WW w_0 wy)) + | N11 wx, N1 wy => w11_add wx (extend10 w0 wy) + | N11 wx, N2 wy => w11_add wx (extend9 w1 wy) + | N11 wx, N3 wy => w11_add wx (extend8 w2 wy) + | N11 wx, N4 wy => w11_add wx (extend7 w3 wy) + | N11 wx, N5 wy => w11_add wx (extend6 w4 wy) + | N11 wx, N6 wy => w11_add wx (extend5 w5 wy) + | N11 wx, N7 wy => w11_add wx (extend4 w6 wy) + | N11 wx, N8 wy => w11_add wx (extend3 w7 wy) + | N11 wx, N9 wy => w11_add wx (extend2 w8 wy) + | N11 wx, N10 wy => w11_add wx (extend1 w9 wy) + | N11 wx, N11 wy => w11_add wx wy + | N11 wx, N12 wy => w12_add (extend1 w10 wx) wy + | N11 wx, Nn n wy => addn n (extend n w12 (extend2 w10 wx)) wy + | N12 wx, N0 wy => + if w0_eq0 wy then x else w12_add wx (extend11 w0 (WW w_0 wy)) + | N12 wx, N1 wy => w12_add wx (extend11 w0 wy) + | N12 wx, N2 wy => w12_add wx (extend10 w1 wy) + | N12 wx, N3 wy => w12_add wx (extend9 w2 wy) + | N12 wx, N4 wy => w12_add wx (extend8 w3 wy) + | N12 wx, N5 wy => w12_add wx (extend7 w4 wy) + | N12 wx, N6 wy => w12_add wx (extend6 w5 wy) + | N12 wx, N7 wy => w12_add wx (extend5 w6 wy) + | N12 wx, N8 wy => w12_add wx (extend4 w7 wy) + | N12 wx, N9 wy => w12_add wx (extend3 w8 wy) + | N12 wx, N10 wy => w12_add wx (extend2 w9 wy) + | N12 wx, N11 wy => w12_add wx (extend1 w10 wy) + | N12 wx, N12 wy => w12_add wx wy + | N12 wx, Nn n wy => addn n (extend n w12 (extend1 w11 wx)) wy + | Nn n wx, N0 wy => + if w0_eq0 wy then x + else addn n wx (extend n w12 (extend12 w0 (WW w_0 wy))) + | Nn n wx, N1 wy => addn n wx (extend n w12 (extend12 w0 wy)) + | Nn n wx, N2 wy => addn n wx (extend n w12 (extend11 w1 wy)) + | Nn n wx, N3 wy => addn n wx (extend n w12 (extend10 w2 wy)) + | Nn n wx, N4 wy => addn n wx (extend n w12 (extend9 w3 wy)) + | Nn n wx, N5 wy => addn n wx (extend n w12 (extend8 w4 wy)) + | Nn n wx, N6 wy => addn n wx (extend n w12 (extend7 w5 wy)) + | Nn n wx, N7 wy => addn n wx (extend n w12 (extend6 w6 wy)) + | Nn n wx, N8 wy => addn n wx (extend n w12 (extend5 w7 wy)) + | Nn n wx, N9 wy => addn n wx (extend n w12 (extend4 w8 wy)) + | Nn n wx, N10 wy => addn n wx (extend n w12 (extend3 w9 wy)) + | Nn n wx, N11 wy => addn n wx (extend n w12 (extend2 w10 wy)) + | Nn n wx, N12 wy => addn n wx (extend n w12 (extend1 w11 wy)) + | Nn n wx, Nn m wy => + match extend_to_max w12 n m wx wy with + | inl wx' => addn m wx' wy + | inr wy' => addn n wx wy' + end + end. + + Definition reduce_0 (x:w) := N0 x. + Definition reduce_1 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w0_eq0 N0 N1. + Definition reduce_2 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w1_eq0 reduce_1 N2. + Definition reduce_3 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w2_eq0 reduce_2 N3. + Definition reduce_4 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w3_eq0 reduce_3 N4. + Definition reduce_5 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w4_eq0 reduce_4 N5. + Definition reduce_6 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w5_eq0 reduce_5 N6. + Definition reduce_7 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w6_eq0 reduce_6 N7. + Definition reduce_8 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w7_eq0 reduce_7 N8. + Definition reduce_9 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w8_eq0 reduce_8 N9. + Definition reduce_10 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w9_eq0 reduce_9 N10. + Definition reduce_11 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w10_eq0 reduce_10 N11. + Definition reduce_12 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w11_eq0 reduce_11 N12. + Definition reduce_13 := + Eval lazy beta iota delta[reduce_n1] in + reduce_n1 _ _ zero w12_eq0 reduce_12 (Nn 0). + Definition reduce_n n := + Eval lazy beta iota delta[reduce_n] in + reduce_n _ _ zero reduce_13 Nn n. + + Definition w0_pred_c := w0_op.(znz_pred_c). + Definition w1_pred_c := w1_op.(znz_pred_c). + Definition w2_pred_c := w2_op.(znz_pred_c). + Definition w3_pred_c := w3_op.(znz_pred_c). + Definition w4_pred_c := w4_op.(znz_pred_c). + Definition w5_pred_c := w5_op.(znz_pred_c). + Definition w6_pred_c := w6_op.(znz_pred_c). + Definition w7_pred_c := w7_op.(znz_pred_c). + Definition w8_pred_c := w8_op.(znz_pred_c). + Definition w9_pred_c := w9_op.(znz_pred_c). + Definition w10_pred_c := w10_op.(znz_pred_c). + Definition w11_pred_c := w11_op.(znz_pred_c). + Definition w12_pred_c := w12_op.(znz_pred_c). + + Definition pred x := + match x with + | N0 wx => + match w0_pred_c wx with + | C0 r => reduce_0 r + | C1 r => zero + end + | N1 wx => + match w1_pred_c wx with + | C0 r => reduce_1 r + | C1 r => zero + end + | N2 wx => + match w2_pred_c wx with + | C0 r => reduce_2 r + | C1 r => zero + end + | N3 wx => + match w3_pred_c wx with + | C0 r => reduce_3 r + | C1 r => zero + end + | N4 wx => + match w4_pred_c wx with + | C0 r => reduce_4 r + | C1 r => zero + end + | N5 wx => + match w5_pred_c wx with + | C0 r => reduce_5 r + | C1 r => zero + end + | N6 wx => + match w6_pred_c wx with + | C0 r => reduce_6 r + | C1 r => zero + end + | N7 wx => + match w7_pred_c wx with + | C0 r => reduce_7 r + | C1 r => zero + end + | N8 wx => + match w8_pred_c wx with + | C0 r => reduce_8 r + | C1 r => zero + end + | N9 wx => + match w9_pred_c wx with + | C0 r => reduce_9 r + | C1 r => zero + end + | N10 wx => + match w10_pred_c wx with + | C0 r => reduce_10 r + | C1 r => zero + end + | N11 wx => + match w11_pred_c wx with + | C0 r => reduce_11 r + | C1 r => zero + end + | N12 wx => + match w12_pred_c wx with + | C0 r => reduce_12 r + | C1 r => zero + end + | Nn n wx => + let op := make_op n in + match op.(znz_pred_c) wx with + | C0 r => reduce_n n r + | C1 r => zero + end + end. + + + Definition w0_sub_c := w0_op.(znz_sub_c). + Definition w1_sub_c := w1_op.(znz_sub_c). + Definition w2_sub_c := w2_op.(znz_sub_c). + Definition w3_sub_c := w3_op.(znz_sub_c). + Definition w4_sub_c := w4_op.(znz_sub_c). + Definition w5_sub_c := w5_op.(znz_sub_c). + Definition w6_sub_c := w6_op.(znz_sub_c). + Definition w7_sub_c := w7_op.(znz_sub_c). + Definition w8_sub_c := w8_op.(znz_sub_c). + Definition w9_sub_c := w9_op.(znz_sub_c). + Definition w10_sub_c := w10_op.(znz_sub_c). + Definition w11_sub_c := w11_op.(znz_sub_c). + Definition w12_sub_c := w12_op.(znz_sub_c). + + Definition w0_sub x y := + match w0_sub_c x y with + | C0 r => reduce_0 r + | C1 r => zero + end. + Definition w1_sub x y := + match w1_sub_c x y with + | C0 r => reduce_1 r + | C1 r => zero + end. + Definition w2_sub x y := + match w2_sub_c x y with + | C0 r => reduce_2 r + | C1 r => zero + end. + Definition w3_sub x y := + match w3_sub_c x y with + | C0 r => reduce_3 r + | C1 r => zero + end. + Definition w4_sub x y := + match w4_sub_c x y with + | C0 r => reduce_4 r + | C1 r => zero + end. + Definition w5_sub x y := + match w5_sub_c x y with + | C0 r => reduce_5 r + | C1 r => zero + end. + Definition w6_sub x y := + match w6_sub_c x y with + | C0 r => reduce_6 r + | C1 r => zero + end. + Definition w7_sub x y := + match w7_sub_c x y with + | C0 r => reduce_7 r + | C1 r => zero + end. + Definition w8_sub x y := + match w8_sub_c x y with + | C0 r => reduce_8 r + | C1 r => zero + end. + Definition w9_sub x y := + match w9_sub_c x y with + | C0 r => reduce_9 r + | C1 r => zero + end. + Definition w10_sub x y := + match w10_sub_c x y with + | C0 r => reduce_10 r + | C1 r => zero + end. + Definition w11_sub x y := + match w11_sub_c x y with + | C0 r => reduce_11 r + | C1 r => zero + end. + Definition w12_sub x y := + match w12_sub_c x y with + | C0 r => reduce_12 r + | C1 r => zero + end. + + Definition subn n (x y : word w12 (S n)) := + let op := make_op n in + match op.(znz_sub_c) x y with + | C0 r => Nn n r + | C1 r => Nn (S n) (WW op.(znz_1) r) end. + + Definition sub x y := + match x, y with + | N0 wx, N0 wy => w0_sub wx wy + | N0 wx, N1 wy => + if w0_eq0 wx then zero else w1_sub (WW w_0 wx) wy + | N0 wx, N2 wy => + if w0_eq0 wx then zero else w2_sub (extend1 w0 (WW w_0 wx)) wy + | N0 wx, N3 wy => + if w0_eq0 wx then zero else w3_sub (extend2 w0 (WW w_0 wx)) wy + | N0 wx, N4 wy => + if w0_eq0 wx then zero else w4_sub (extend3 w0 (WW w_0 wx)) wy + | N0 wx, N5 wy => + if w0_eq0 wx then zero else w5_sub (extend4 w0 (WW w_0 wx)) wy + | N0 wx, N6 wy => + if w0_eq0 wx then zero else w6_sub (extend5 w0 (WW w_0 wx)) wy + | N0 wx, N7 wy => + if w0_eq0 wx then zero else w7_sub (extend6 w0 (WW w_0 wx)) wy + | N0 wx, N8 wy => + if w0_eq0 wx then zero else w8_sub (extend7 w0 (WW w_0 wx)) wy + | N0 wx, N9 wy => + if w0_eq0 wx then zero else w9_sub (extend8 w0 (WW w_0 wx)) wy + | N0 wx, N10 wy => + if w0_eq0 wx then zero else w10_sub (extend9 w0 (WW w_0 wx)) wy + | N0 wx, N11 wy => + if w0_eq0 wx then zero else w11_sub (extend10 w0 (WW w_0 wx)) wy + | N0 wx, N12 wy => + if w0_eq0 wx then zero else w12_sub (extend11 w0 (WW w_0 wx)) wy + | N0 wx, Nn n wy => + if w0_eq0 wx then zero + else subn n (extend n w12 (extend12 w0 (WW w_0 wx))) wy + | N1 wx, N0 wy => + if w0_eq0 wy then x + else w1_sub wx (WW w_0 wy) + | N1 wx, N1 wy => w1_sub wx wy + | N1 wx, N2 wy => w2_sub (extend1 w0 wx) wy + | N1 wx, N3 wy => w3_sub (extend2 w0 wx) wy + | N1 wx, N4 wy => w4_sub (extend3 w0 wx) wy + | N1 wx, N5 wy => w5_sub (extend4 w0 wx) wy + | N1 wx, N6 wy => w6_sub (extend5 w0 wx) wy + | N1 wx, N7 wy => w7_sub (extend6 w0 wx) wy + | N1 wx, N8 wy => w8_sub (extend7 w0 wx) wy + | N1 wx, N9 wy => w9_sub (extend8 w0 wx) wy + | N1 wx, N10 wy => w10_sub (extend9 w0 wx) wy + | N1 wx, N11 wy => w11_sub (extend10 w0 wx) wy + | N1 wx, N12 wy => w12_sub (extend11 w0 wx) wy + | N1 wx, Nn n wy => subn n (extend n w12 (extend12 w0 wx)) wy + | N2 wx, N0 wy => + if w0_eq0 wy then x + else w2_sub wx (extend1 w0 (WW w_0 wy)) + | N2 wx, N1 wy => w2_sub wx (extend1 w0 wy) + | N2 wx, N2 wy => w2_sub wx wy + | N2 wx, N3 wy => w3_sub (extend1 w1 wx) wy + | N2 wx, N4 wy => w4_sub (extend2 w1 wx) wy + | N2 wx, N5 wy => w5_sub (extend3 w1 wx) wy + | N2 wx, N6 wy => w6_sub (extend4 w1 wx) wy + | N2 wx, N7 wy => w7_sub (extend5 w1 wx) wy + | N2 wx, N8 wy => w8_sub (extend6 w1 wx) wy + | N2 wx, N9 wy => w9_sub (extend7 w1 wx) wy + | N2 wx, N10 wy => w10_sub (extend8 w1 wx) wy + | N2 wx, N11 wy => w11_sub (extend9 w1 wx) wy + | N2 wx, N12 wy => w12_sub (extend10 w1 wx) wy + | N2 wx, Nn n wy => subn n (extend n w12 (extend11 w1 wx)) wy + | N3 wx, N0 wy => + if w0_eq0 wy then x + else w3_sub wx (extend2 w0 (WW w_0 wy)) + | N3 wx, N1 wy => w3_sub wx (extend2 w0 wy) + | N3 wx, N2 wy => w3_sub wx (extend1 w1 wy) + | N3 wx, N3 wy => w3_sub wx wy + | N3 wx, N4 wy => w4_sub (extend1 w2 wx) wy + | N3 wx, N5 wy => w5_sub (extend2 w2 wx) wy + | N3 wx, N6 wy => w6_sub (extend3 w2 wx) wy + | N3 wx, N7 wy => w7_sub (extend4 w2 wx) wy + | N3 wx, N8 wy => w8_sub (extend5 w2 wx) wy + | N3 wx, N9 wy => w9_sub (extend6 w2 wx) wy + | N3 wx, N10 wy => w10_sub (extend7 w2 wx) wy + | N3 wx, N11 wy => w11_sub (extend8 w2 wx) wy + | N3 wx, N12 wy => w12_sub (extend9 w2 wx) wy + | N3 wx, Nn n wy => subn n (extend n w12 (extend10 w2 wx)) wy + | N4 wx, N0 wy => + if w0_eq0 wy then x + else w4_sub wx (extend3 w0 (WW w_0 wy)) + | N4 wx, N1 wy => w4_sub wx (extend3 w0 wy) + | N4 wx, N2 wy => w4_sub wx (extend2 w1 wy) + | N4 wx, N3 wy => w4_sub wx (extend1 w2 wy) + | N4 wx, N4 wy => w4_sub wx wy + | N4 wx, N5 wy => w5_sub (extend1 w3 wx) wy + | N4 wx, N6 wy => w6_sub (extend2 w3 wx) wy + | N4 wx, N7 wy => w7_sub (extend3 w3 wx) wy + | N4 wx, N8 wy => w8_sub (extend4 w3 wx) wy + | N4 wx, N9 wy => w9_sub (extend5 w3 wx) wy + | N4 wx, N10 wy => w10_sub (extend6 w3 wx) wy + | N4 wx, N11 wy => w11_sub (extend7 w3 wx) wy + | N4 wx, N12 wy => w12_sub (extend8 w3 wx) wy + | N4 wx, Nn n wy => subn n (extend n w12 (extend9 w3 wx)) wy + | N5 wx, N0 wy => + if w0_eq0 wy then x + else w5_sub wx (extend4 w0 (WW w_0 wy)) + | N5 wx, N1 wy => w5_sub wx (extend4 w0 wy) + | N5 wx, N2 wy => w5_sub wx (extend3 w1 wy) + | N5 wx, N3 wy => w5_sub wx (extend2 w2 wy) + | N5 wx, N4 wy => w5_sub wx (extend1 w3 wy) + | N5 wx, N5 wy => w5_sub wx wy + | N5 wx, N6 wy => w6_sub (extend1 w4 wx) wy + | N5 wx, N7 wy => w7_sub (extend2 w4 wx) wy + | N5 wx, N8 wy => w8_sub (extend3 w4 wx) wy + | N5 wx, N9 wy => w9_sub (extend4 w4 wx) wy + | N5 wx, N10 wy => w10_sub (extend5 w4 wx) wy + | N5 wx, N11 wy => w11_sub (extend6 w4 wx) wy + | N5 wx, N12 wy => w12_sub (extend7 w4 wx) wy + | N5 wx, Nn n wy => subn n (extend n w12 (extend8 w4 wx)) wy + | N6 wx, N0 wy => + if w0_eq0 wy then x + else w6_sub wx (extend5 w0 (WW w_0 wy)) + | N6 wx, N1 wy => w6_sub wx (extend5 w0 wy) + | N6 wx, N2 wy => w6_sub wx (extend4 w1 wy) + | N6 wx, N3 wy => w6_sub wx (extend3 w2 wy) + | N6 wx, N4 wy => w6_sub wx (extend2 w3 wy) + | N6 wx, N5 wy => w6_sub wx (extend1 w4 wy) + | N6 wx, N6 wy => w6_sub wx wy + | N6 wx, N7 wy => w7_sub (extend1 w5 wx) wy + | N6 wx, N8 wy => w8_sub (extend2 w5 wx) wy + | N6 wx, N9 wy => w9_sub (extend3 w5 wx) wy + | N6 wx, N10 wy => w10_sub (extend4 w5 wx) wy + | N6 wx, N11 wy => w11_sub (extend5 w5 wx) wy + | N6 wx, N12 wy => w12_sub (extend6 w5 wx) wy + | N6 wx, Nn n wy => subn n (extend n w12 (extend7 w5 wx)) wy + | N7 wx, N0 wy => + if w0_eq0 wy then x + else w7_sub wx (extend6 w0 (WW w_0 wy)) + | N7 wx, N1 wy => w7_sub wx (extend6 w0 wy) + | N7 wx, N2 wy => w7_sub wx (extend5 w1 wy) + | N7 wx, N3 wy => w7_sub wx (extend4 w2 wy) + | N7 wx, N4 wy => w7_sub wx (extend3 w3 wy) + | N7 wx, N5 wy => w7_sub wx (extend2 w4 wy) + | N7 wx, N6 wy => w7_sub wx (extend1 w5 wy) + | N7 wx, N7 wy => w7_sub wx wy + | N7 wx, N8 wy => w8_sub (extend1 w6 wx) wy + | N7 wx, N9 wy => w9_sub (extend2 w6 wx) wy + | N7 wx, N10 wy => w10_sub (extend3 w6 wx) wy + | N7 wx, N11 wy => w11_sub (extend4 w6 wx) wy + | N7 wx, N12 wy => w12_sub (extend5 w6 wx) wy + | N7 wx, Nn n wy => subn n (extend n w12 (extend6 w6 wx)) wy + | N8 wx, N0 wy => + if w0_eq0 wy then x + else w8_sub wx (extend7 w0 (WW w_0 wy)) + | N8 wx, N1 wy => w8_sub wx (extend7 w0 wy) + | N8 wx, N2 wy => w8_sub wx (extend6 w1 wy) + | N8 wx, N3 wy => w8_sub wx (extend5 w2 wy) + | N8 wx, N4 wy => w8_sub wx (extend4 w3 wy) + | N8 wx, N5 wy => w8_sub wx (extend3 w4 wy) + | N8 wx, N6 wy => w8_sub wx (extend2 w5 wy) + | N8 wx, N7 wy => w8_sub wx (extend1 w6 wy) + | N8 wx, N8 wy => w8_sub wx wy + | N8 wx, N9 wy => w9_sub (extend1 w7 wx) wy + | N8 wx, N10 wy => w10_sub (extend2 w7 wx) wy + | N8 wx, N11 wy => w11_sub (extend3 w7 wx) wy + | N8 wx, N12 wy => w12_sub (extend4 w7 wx) wy + | N8 wx, Nn n wy => subn n (extend n w12 (extend5 w7 wx)) wy + | N9 wx, N0 wy => + if w0_eq0 wy then x + else w9_sub wx (extend8 w0 (WW w_0 wy)) + | N9 wx, N1 wy => w9_sub wx (extend8 w0 wy) + | N9 wx, N2 wy => w9_sub wx (extend7 w1 wy) + | N9 wx, N3 wy => w9_sub wx (extend6 w2 wy) + | N9 wx, N4 wy => w9_sub wx (extend5 w3 wy) + | N9 wx, N5 wy => w9_sub wx (extend4 w4 wy) + | N9 wx, N6 wy => w9_sub wx (extend3 w5 wy) + | N9 wx, N7 wy => w9_sub wx (extend2 w6 wy) + | N9 wx, N8 wy => w9_sub wx (extend1 w7 wy) + | N9 wx, N9 wy => w9_sub wx wy + | N9 wx, N10 wy => w10_sub (extend1 w8 wx) wy + | N9 wx, N11 wy => w11_sub (extend2 w8 wx) wy + | N9 wx, N12 wy => w12_sub (extend3 w8 wx) wy + | N9 wx, Nn n wy => subn n (extend n w12 (extend4 w8 wx)) wy + | N10 wx, N0 wy => + if w0_eq0 wy then x + else w10_sub wx (extend9 w0 (WW w_0 wy)) + | N10 wx, N1 wy => w10_sub wx (extend9 w0 wy) + | N10 wx, N2 wy => w10_sub wx (extend8 w1 wy) + | N10 wx, N3 wy => w10_sub wx (extend7 w2 wy) + | N10 wx, N4 wy => w10_sub wx (extend6 w3 wy) + | N10 wx, N5 wy => w10_sub wx (extend5 w4 wy) + | N10 wx, N6 wy => w10_sub wx (extend4 w5 wy) + | N10 wx, N7 wy => w10_sub wx (extend3 w6 wy) + | N10 wx, N8 wy => w10_sub wx (extend2 w7 wy) + | N10 wx, N9 wy => w10_sub wx (extend1 w8 wy) + | N10 wx, N10 wy => w10_sub wx wy + | N10 wx, N11 wy => w11_sub (extend1 w9 wx) wy + | N10 wx, N12 wy => w12_sub (extend2 w9 wx) wy + | N10 wx, Nn n wy => subn n (extend n w12 (extend3 w9 wx)) wy + | N11 wx, N0 wy => + if w0_eq0 wy then x + else w11_sub wx (extend10 w0 (WW w_0 wy)) + | N11 wx, N1 wy => w11_sub wx (extend10 w0 wy) + | N11 wx, N2 wy => w11_sub wx (extend9 w1 wy) + | N11 wx, N3 wy => w11_sub wx (extend8 w2 wy) + | N11 wx, N4 wy => w11_sub wx (extend7 w3 wy) + | N11 wx, N5 wy => w11_sub wx (extend6 w4 wy) + | N11 wx, N6 wy => w11_sub wx (extend5 w5 wy) + | N11 wx, N7 wy => w11_sub wx (extend4 w6 wy) + | N11 wx, N8 wy => w11_sub wx (extend3 w7 wy) + | N11 wx, N9 wy => w11_sub wx (extend2 w8 wy) + | N11 wx, N10 wy => w11_sub wx (extend1 w9 wy) + | N11 wx, N11 wy => w11_sub wx wy + | N11 wx, N12 wy => w12_sub (extend1 w10 wx) wy + | N11 wx, Nn n wy => subn n (extend n w12 (extend2 w10 wx)) wy + | N12 wx, N0 wy => + if w0_eq0 wy then x + else w12_sub wx (extend11 w0 (WW w_0 wy)) + | N12 wx, N1 wy => w12_sub wx (extend11 w0 wy) + | N12 wx, N2 wy => w12_sub wx (extend10 w1 wy) + | N12 wx, N3 wy => w12_sub wx (extend9 w2 wy) + | N12 wx, N4 wy => w12_sub wx (extend8 w3 wy) + | N12 wx, N5 wy => w12_sub wx (extend7 w4 wy) + | N12 wx, N6 wy => w12_sub wx (extend6 w5 wy) + | N12 wx, N7 wy => w12_sub wx (extend5 w6 wy) + | N12 wx, N8 wy => w12_sub wx (extend4 w7 wy) + | N12 wx, N9 wy => w12_sub wx (extend3 w8 wy) + | N12 wx, N10 wy => w12_sub wx (extend2 w9 wy) + | N12 wx, N11 wy => w12_sub wx (extend1 w10 wy) + | N12 wx, N12 wy => w12_sub wx wy + | N12 wx, Nn n wy => subn n (extend n w12 (extend1 w11 wx)) wy + | Nn n wx, N0 wy => + if w0_eq0 wy then x + else subn n wx (extend n w12 (extend12 w0 (WW w_0 wy))) + | Nn n wx, N1 wy => subn n wx (extend n w12 (extend12 w0 wy)) + | Nn n wx, N2 wy => subn n wx (extend n w12 (extend11 w1 wy)) + | Nn n wx, N3 wy => subn n wx (extend n w12 (extend10 w2 wy)) + | Nn n wx, N4 wy => subn n wx (extend n w12 (extend9 w3 wy)) + | Nn n wx, N5 wy => subn n wx (extend n w12 (extend8 w4 wy)) + | Nn n wx, N6 wy => subn n wx (extend n w12 (extend7 w5 wy)) + | Nn n wx, N7 wy => subn n wx (extend n w12 (extend6 w6 wy)) + | Nn n wx, N8 wy => subn n wx (extend n w12 (extend5 w7 wy)) + | Nn n wx, N9 wy => subn n wx (extend n w12 (extend4 w8 wy)) + | Nn n wx, N10 wy => subn n wx (extend n w12 (extend3 w9 wy)) + | Nn n wx, N11 wy => subn n wx (extend n w12 (extend2 w10 wy)) + | Nn n wx, N12 wy => subn n wx (extend n w12 (extend1 w11 wy)) + | Nn n wx, Nn m wy => + match extend_to_max w12 n m wx wy with + | inl wx' => subn m wx' wy + | inr wy' => subn n wx wy' + end + end. + + Definition compare_0 := w0_op.(znz_compare). + Definition comparen_0 := + compare_mn_1 w0 w0 w_0 compare_0 (compare_0 w_0) compare_0. + Definition compare_1 := w1_op.(znz_compare). + Definition comparen_1 := + compare_mn_1 w1 w1 W0 compare_1 (compare_1 W0) compare_1. + Definition compare_2 := w2_op.(znz_compare). + Definition comparen_2 := + compare_mn_1 w2 w2 W0 compare_2 (compare_2 W0) compare_2. + Definition compare_3 := w3_op.(znz_compare). + Definition comparen_3 := + compare_mn_1 w3 w3 W0 compare_3 (compare_3 W0) compare_3. + Definition compare_4 := w4_op.(znz_compare). + Definition comparen_4 := + compare_mn_1 w4 w4 W0 compare_4 (compare_4 W0) compare_4. + Definition compare_5 := w5_op.(znz_compare). + Definition comparen_5 := + compare_mn_1 w5 w5 W0 compare_5 (compare_5 W0) compare_5. + Definition compare_6 := w6_op.(znz_compare). + Definition comparen_6 := + compare_mn_1 w6 w6 W0 compare_6 (compare_6 W0) compare_6. + Definition compare_7 := w7_op.(znz_compare). + Definition comparen_7 := + compare_mn_1 w7 w7 W0 compare_7 (compare_7 W0) compare_7. + Definition compare_8 := w8_op.(znz_compare). + Definition comparen_8 := + compare_mn_1 w8 w8 W0 compare_8 (compare_8 W0) compare_8. + Definition compare_9 := w9_op.(znz_compare). + Definition comparen_9 := + compare_mn_1 w9 w9 W0 compare_9 (compare_9 W0) compare_9. + Definition compare_10 := w10_op.(znz_compare). + Definition comparen_10 := + compare_mn_1 w10 w10 W0 compare_10 (compare_10 W0) compare_10. + Definition compare_11 := w11_op.(znz_compare). + Definition comparen_11 := + compare_mn_1 w11 w11 W0 compare_11 (compare_11 W0) compare_11. + Definition compare_12 := w12_op.(znz_compare). + Definition comparen_12 := + compare_mn_1 w12 w12 W0 compare_12 (compare_12 W0) compare_12. + + Definition compare x y := + match x, y with + | N0 wx, N0 wy => compare_0 wx wy + | N0 wx, N1 wy => opp_compare (comparen_0 1 wy wx) + | N0 wx, N2 wy => opp_compare (comparen_0 2 wy wx) + | N0 wx, N3 wy => opp_compare (comparen_0 3 wy wx) + | N0 wx, N4 wy => opp_compare (comparen_0 4 wy wx) + | N0 wx, N5 wy => opp_compare (comparen_0 5 wy wx) + | N0 wx, N6 wy => opp_compare (comparen_0 6 wy wx) + | N0 wx, N7 wy => opp_compare (comparen_0 7 wy wx) + | N0 wx, N8 wy => opp_compare (comparen_0 8 wy wx) + | N0 wx, N9 wy => opp_compare (comparen_0 9 wy wx) + | N0 wx, N10 wy => opp_compare (comparen_0 10 wy wx) + | N0 wx, N11 wy => opp_compare (comparen_0 11 wy wx) + | N0 wx, N12 wy => opp_compare (comparen_0 12 wy wx) + | N0 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w0 w_0 compare_0 (compare_12 W0) (comparen_0 12) (S n) wy wx) + | N1 wx, N0 wy => comparen_0 1 wx wy + | N1 wx, N1 wy => compare_1 wx wy + | N1 wx, N2 wy => opp_compare (comparen_1 1 wy wx) + | N1 wx, N3 wy => opp_compare (comparen_1 2 wy wx) + | N1 wx, N4 wy => opp_compare (comparen_1 3 wy wx) + | N1 wx, N5 wy => opp_compare (comparen_1 4 wy wx) + | N1 wx, N6 wy => opp_compare (comparen_1 5 wy wx) + | N1 wx, N7 wy => opp_compare (comparen_1 6 wy wx) + | N1 wx, N8 wy => opp_compare (comparen_1 7 wy wx) + | N1 wx, N9 wy => opp_compare (comparen_1 8 wy wx) + | N1 wx, N10 wy => opp_compare (comparen_1 9 wy wx) + | N1 wx, N11 wy => opp_compare (comparen_1 10 wy wx) + | N1 wx, N12 wy => opp_compare (comparen_1 11 wy wx) + | N1 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w1 W0 compare_1 (compare_12 W0) (comparen_1 11) (S n) wy wx) + | N2 wx, N0 wy => comparen_0 2 wx wy + | N2 wx, N1 wy => comparen_1 1 wx wy + | N2 wx, N2 wy => compare_2 wx wy + | N2 wx, N3 wy => opp_compare (comparen_2 1 wy wx) + | N2 wx, N4 wy => opp_compare (comparen_2 2 wy wx) + | N2 wx, N5 wy => opp_compare (comparen_2 3 wy wx) + | N2 wx, N6 wy => opp_compare (comparen_2 4 wy wx) + | N2 wx, N7 wy => opp_compare (comparen_2 5 wy wx) + | N2 wx, N8 wy => opp_compare (comparen_2 6 wy wx) + | N2 wx, N9 wy => opp_compare (comparen_2 7 wy wx) + | N2 wx, N10 wy => opp_compare (comparen_2 8 wy wx) + | N2 wx, N11 wy => opp_compare (comparen_2 9 wy wx) + | N2 wx, N12 wy => opp_compare (comparen_2 10 wy wx) + | N2 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w2 W0 compare_2 (compare_12 W0) (comparen_2 10) (S n) wy wx) + | N3 wx, N0 wy => comparen_0 3 wx wy + | N3 wx, N1 wy => comparen_1 2 wx wy + | N3 wx, N2 wy => comparen_2 1 wx wy + | N3 wx, N3 wy => compare_3 wx wy + | N3 wx, N4 wy => opp_compare (comparen_3 1 wy wx) + | N3 wx, N5 wy => opp_compare (comparen_3 2 wy wx) + | N3 wx, N6 wy => opp_compare (comparen_3 3 wy wx) + | N3 wx, N7 wy => opp_compare (comparen_3 4 wy wx) + | N3 wx, N8 wy => opp_compare (comparen_3 5 wy wx) + | N3 wx, N9 wy => opp_compare (comparen_3 6 wy wx) + | N3 wx, N10 wy => opp_compare (comparen_3 7 wy wx) + | N3 wx, N11 wy => opp_compare (comparen_3 8 wy wx) + | N3 wx, N12 wy => opp_compare (comparen_3 9 wy wx) + | N3 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w3 W0 compare_3 (compare_12 W0) (comparen_3 9) (S n) wy wx) + | N4 wx, N0 wy => comparen_0 4 wx wy + | N4 wx, N1 wy => comparen_1 3 wx wy + | N4 wx, N2 wy => comparen_2 2 wx wy + | N4 wx, N3 wy => comparen_3 1 wx wy + | N4 wx, N4 wy => compare_4 wx wy + | N4 wx, N5 wy => opp_compare (comparen_4 1 wy wx) + | N4 wx, N6 wy => opp_compare (comparen_4 2 wy wx) + | N4 wx, N7 wy => opp_compare (comparen_4 3 wy wx) + | N4 wx, N8 wy => opp_compare (comparen_4 4 wy wx) + | N4 wx, N9 wy => opp_compare (comparen_4 5 wy wx) + | N4 wx, N10 wy => opp_compare (comparen_4 6 wy wx) + | N4 wx, N11 wy => opp_compare (comparen_4 7 wy wx) + | N4 wx, N12 wy => opp_compare (comparen_4 8 wy wx) + | N4 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w4 W0 compare_4 (compare_12 W0) (comparen_4 8) (S n) wy wx) + | N5 wx, N0 wy => comparen_0 5 wx wy + | N5 wx, N1 wy => comparen_1 4 wx wy + | N5 wx, N2 wy => comparen_2 3 wx wy + | N5 wx, N3 wy => comparen_3 2 wx wy + | N5 wx, N4 wy => comparen_4 1 wx wy + | N5 wx, N5 wy => compare_5 wx wy + | N5 wx, N6 wy => opp_compare (comparen_5 1 wy wx) + | N5 wx, N7 wy => opp_compare (comparen_5 2 wy wx) + | N5 wx, N8 wy => opp_compare (comparen_5 3 wy wx) + | N5 wx, N9 wy => opp_compare (comparen_5 4 wy wx) + | N5 wx, N10 wy => opp_compare (comparen_5 5 wy wx) + | N5 wx, N11 wy => opp_compare (comparen_5 6 wy wx) + | N5 wx, N12 wy => opp_compare (comparen_5 7 wy wx) + | N5 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w5 W0 compare_5 (compare_12 W0) (comparen_5 7) (S n) wy wx) + | N6 wx, N0 wy => comparen_0 6 wx wy + | N6 wx, N1 wy => comparen_1 5 wx wy + | N6 wx, N2 wy => comparen_2 4 wx wy + | N6 wx, N3 wy => comparen_3 3 wx wy + | N6 wx, N4 wy => comparen_4 2 wx wy + | N6 wx, N5 wy => comparen_5 1 wx wy + | N6 wx, N6 wy => compare_6 wx wy + | N6 wx, N7 wy => opp_compare (comparen_6 1 wy wx) + | N6 wx, N8 wy => opp_compare (comparen_6 2 wy wx) + | N6 wx, N9 wy => opp_compare (comparen_6 3 wy wx) + | N6 wx, N10 wy => opp_compare (comparen_6 4 wy wx) + | N6 wx, N11 wy => opp_compare (comparen_6 5 wy wx) + | N6 wx, N12 wy => opp_compare (comparen_6 6 wy wx) + | N6 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w6 W0 compare_6 (compare_12 W0) (comparen_6 6) (S n) wy wx) + | N7 wx, N0 wy => comparen_0 7 wx wy + | N7 wx, N1 wy => comparen_1 6 wx wy + | N7 wx, N2 wy => comparen_2 5 wx wy + | N7 wx, N3 wy => comparen_3 4 wx wy + | N7 wx, N4 wy => comparen_4 3 wx wy + | N7 wx, N5 wy => comparen_5 2 wx wy + | N7 wx, N6 wy => comparen_6 1 wx wy + | N7 wx, N7 wy => compare_7 wx wy + | N7 wx, N8 wy => opp_compare (comparen_7 1 wy wx) + | N7 wx, N9 wy => opp_compare (comparen_7 2 wy wx) + | N7 wx, N10 wy => opp_compare (comparen_7 3 wy wx) + | N7 wx, N11 wy => opp_compare (comparen_7 4 wy wx) + | N7 wx, N12 wy => opp_compare (comparen_7 5 wy wx) + | N7 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w7 W0 compare_7 (compare_12 W0) (comparen_7 5) (S n) wy wx) + | N8 wx, N0 wy => comparen_0 8 wx wy + | N8 wx, N1 wy => comparen_1 7 wx wy + | N8 wx, N2 wy => comparen_2 6 wx wy + | N8 wx, N3 wy => comparen_3 5 wx wy + | N8 wx, N4 wy => comparen_4 4 wx wy + | N8 wx, N5 wy => comparen_5 3 wx wy + | N8 wx, N6 wy => comparen_6 2 wx wy + | N8 wx, N7 wy => comparen_7 1 wx wy + | N8 wx, N8 wy => compare_8 wx wy + | N8 wx, N9 wy => opp_compare (comparen_8 1 wy wx) + | N8 wx, N10 wy => opp_compare (comparen_8 2 wy wx) + | N8 wx, N11 wy => opp_compare (comparen_8 3 wy wx) + | N8 wx, N12 wy => opp_compare (comparen_8 4 wy wx) + | N8 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w8 W0 compare_8 (compare_12 W0) (comparen_8 4) (S n) wy wx) + | N9 wx, N0 wy => comparen_0 9 wx wy + | N9 wx, N1 wy => comparen_1 8 wx wy + | N9 wx, N2 wy => comparen_2 7 wx wy + | N9 wx, N3 wy => comparen_3 6 wx wy + | N9 wx, N4 wy => comparen_4 5 wx wy + | N9 wx, N5 wy => comparen_5 4 wx wy + | N9 wx, N6 wy => comparen_6 3 wx wy + | N9 wx, N7 wy => comparen_7 2 wx wy + | N9 wx, N8 wy => comparen_8 1 wx wy + | N9 wx, N9 wy => compare_9 wx wy + | N9 wx, N10 wy => opp_compare (comparen_9 1 wy wx) + | N9 wx, N11 wy => opp_compare (comparen_9 2 wy wx) + | N9 wx, N12 wy => opp_compare (comparen_9 3 wy wx) + | N9 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w9 W0 compare_9 (compare_12 W0) (comparen_9 3) (S n) wy wx) + | N10 wx, N0 wy => comparen_0 10 wx wy + | N10 wx, N1 wy => comparen_1 9 wx wy + | N10 wx, N2 wy => comparen_2 8 wx wy + | N10 wx, N3 wy => comparen_3 7 wx wy + | N10 wx, N4 wy => comparen_4 6 wx wy + | N10 wx, N5 wy => comparen_5 5 wx wy + | N10 wx, N6 wy => comparen_6 4 wx wy + | N10 wx, N7 wy => comparen_7 3 wx wy + | N10 wx, N8 wy => comparen_8 2 wx wy + | N10 wx, N9 wy => comparen_9 1 wx wy + | N10 wx, N10 wy => compare_10 wx wy + | N10 wx, N11 wy => opp_compare (comparen_10 1 wy wx) + | N10 wx, N12 wy => opp_compare (comparen_10 2 wy wx) + | N10 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w10 W0 compare_10 (compare_12 W0) (comparen_10 2) (S n) wy wx) + | N11 wx, N0 wy => comparen_0 11 wx wy + | N11 wx, N1 wy => comparen_1 10 wx wy + | N11 wx, N2 wy => comparen_2 9 wx wy + | N11 wx, N3 wy => comparen_3 8 wx wy + | N11 wx, N4 wy => comparen_4 7 wx wy + | N11 wx, N5 wy => comparen_5 6 wx wy + | N11 wx, N6 wy => comparen_6 5 wx wy + | N11 wx, N7 wy => comparen_7 4 wx wy + | N11 wx, N8 wy => comparen_8 3 wx wy + | N11 wx, N9 wy => comparen_9 2 wx wy + | N11 wx, N10 wy => comparen_10 1 wx wy + | N11 wx, N11 wy => compare_11 wx wy + | N11 wx, N12 wy => opp_compare (comparen_11 1 wy wx) + | N11 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w11 W0 compare_11 (compare_12 W0) (comparen_11 1) (S n) wy wx) + | N12 wx, N0 wy => comparen_0 12 wx wy + | N12 wx, N1 wy => comparen_1 11 wx wy + | N12 wx, N2 wy => comparen_2 10 wx wy + | N12 wx, N3 wy => comparen_3 9 wx wy + | N12 wx, N4 wy => comparen_4 8 wx wy + | N12 wx, N5 wy => comparen_5 7 wx wy + | N12 wx, N6 wy => comparen_6 6 wx wy + | N12 wx, N7 wy => comparen_7 5 wx wy + | N12 wx, N8 wy => comparen_8 4 wx wy + | N12 wx, N9 wy => comparen_9 3 wx wy + | N12 wx, N10 wy => comparen_10 2 wx wy + | N12 wx, N11 wy => comparen_11 1 wx wy + | N12 wx, N12 wy => compare_12 wx wy + | N12 wx, Nn n wy => + opp_compare (compare_mn_1 w12 w12 W0 compare_12 (compare_12 W0) (comparen_12 0) (S n) wy wx) + | Nn n wx, N0 wy => + compare_mn_1 w12 w0 w_0 compare_0 (compare_12 W0) (comparen_0 12) (S n) wx wy + | Nn n wx, N1 wy => + compare_mn_1 w12 w1 W0 compare_1 (compare_12 W0) (comparen_1 11) (S n) wx wy + | Nn n wx, N2 wy => + compare_mn_1 w12 w2 W0 compare_2 (compare_12 W0) (comparen_2 10) (S n) wx wy + | Nn n wx, N3 wy => + compare_mn_1 w12 w3 W0 compare_3 (compare_12 W0) (comparen_3 9) (S n) wx wy + | Nn n wx, N4 wy => + compare_mn_1 w12 w4 W0 compare_4 (compare_12 W0) (comparen_4 8) (S n) wx wy + | Nn n wx, N5 wy => + compare_mn_1 w12 w5 W0 compare_5 (compare_12 W0) (comparen_5 7) (S n) wx wy + | Nn n wx, N6 wy => + compare_mn_1 w12 w6 W0 compare_6 (compare_12 W0) (comparen_6 6) (S n) wx wy + | Nn n wx, N7 wy => + compare_mn_1 w12 w7 W0 compare_7 (compare_12 W0) (comparen_7 5) (S n) wx wy + | Nn n wx, N8 wy => + compare_mn_1 w12 w8 W0 compare_8 (compare_12 W0) (comparen_8 4) (S n) wx wy + | Nn n wx, N9 wy => + compare_mn_1 w12 w9 W0 compare_9 (compare_12 W0) (comparen_9 3) (S n) wx wy + | Nn n wx, N10 wy => + compare_mn_1 w12 w10 W0 compare_10 (compare_12 W0) (comparen_10 2) (S n) wx wy + | Nn n wx, N11 wy => + compare_mn_1 w12 w11 W0 compare_11 (compare_12 W0) (comparen_11 1) (S n) wx wy + | Nn n wx, N12 wy => + compare_mn_1 w12 w12 W0 compare_12 (compare_12 W0) (comparen_12 0) (S n) wx wy + | Nn n wx, Nn m wy => + match extend_to_max w12 n m wx wy with + | inl wx' => let op := make_op m in op.(znz_compare) wx' wy + | inr wy' => let op := make_op n in op.(znz_compare) wx wy' + end + end. + + Definition eq_bool x y := + match compare x y with + | Eq => true + | _ => false + end. + + Definition w0_mul_c := w0_op.(znz_mul_c). + Definition w1_mul_c := w1_op.(znz_mul_c). + Definition w2_mul_c := w2_op.(znz_mul_c). + Definition w3_mul_c := w3_op.(znz_mul_c). + Definition w4_mul_c := w4_op.(znz_mul_c). + Definition w5_mul_c := w5_op.(znz_mul_c). + Definition w6_mul_c := w6_op.(znz_mul_c). + Definition w7_mul_c := w7_op.(znz_mul_c). + Definition w8_mul_c := w8_op.(znz_mul_c). + Definition w9_mul_c := w9_op.(znz_mul_c). + Definition w10_mul_c := w10_op.(znz_mul_c). + Definition w11_mul_c := w11_op.(znz_mul_c). + Definition w12_mul_c := w12_op.(znz_mul_c). + + Definition w0_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w0 w_0 w0_succ w0_add_c w0_mul_c. + Definition w1_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w1 W0 w1_succ w1_add_c w1_mul_c. + Definition w2_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w2 W0 w2_succ w2_add_c w2_mul_c. + Definition w3_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w3 W0 w3_succ w3_add_c w3_mul_c. + Definition w4_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w4 W0 w4_succ w4_add_c w4_mul_c. + Definition w5_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w5 W0 w5_succ w5_add_c w5_mul_c. + Definition w6_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w6 W0 w6_succ w6_add_c w6_mul_c. + Definition w7_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w7 W0 w7_succ w7_add_c w7_mul_c. + Definition w8_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w8 W0 w8_succ w8_add_c w8_mul_c. + Definition w9_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w9 W0 w9_succ w9_add_c w9_mul_c. + Definition w10_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w10 W0 w10_succ w10_add_c w10_mul_c. + Definition w11_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w11 W0 w11_succ w11_add_c w11_mul_c. + Definition w12_mul_add := + Eval lazy beta delta [w_mul_add] in + @w_mul_add w12 W0 w12_succ w12_add_c w12_mul_c. + + Definition w0_mul_add_n1 := + @gen_mul_add_n1 w0 w_0 w0_op.(znz_WW) w0_op.(znz_0W) w0_mul_add. + Definition w1_mul_add_n1 := + @gen_mul_add_n1 w1 W0 w1_op.(znz_WW) w1_op.(znz_0W) w1_mul_add. + Definition w2_mul_add_n1 := + @gen_mul_add_n1 w2 W0 w2_op.(znz_WW) w2_op.(znz_0W) w2_mul_add. + Definition w3_mul_add_n1 := + @gen_mul_add_n1 w3 W0 w3_op.(znz_WW) w3_op.(znz_0W) w3_mul_add. + Definition w4_mul_add_n1 := + @gen_mul_add_n1 w4 W0 w4_op.(znz_WW) w4_op.(znz_0W) w4_mul_add. + Definition w5_mul_add_n1 := + @gen_mul_add_n1 w5 W0 w5_op.(znz_WW) w5_op.(znz_0W) w5_mul_add. + Definition w6_mul_add_n1 := + @gen_mul_add_n1 w6 W0 w6_op.(znz_WW) w6_op.(znz_0W) w6_mul_add. + Definition w7_mul_add_n1 := + @gen_mul_add_n1 w7 W0 w7_op.(znz_WW) w7_op.(znz_0W) w7_mul_add. + Definition w8_mul_add_n1 := + @gen_mul_add_n1 w8 W0 w8_op.(znz_WW) w8_op.(znz_0W) w8_mul_add. + Definition w9_mul_add_n1 := + @gen_mul_add_n1 w9 W0 w9_op.(znz_WW) w9_op.(znz_0W) w9_mul_add. + Definition w10_mul_add_n1 := + @gen_mul_add_n1 w10 W0 w10_op.(znz_WW) w10_op.(znz_0W) w10_mul_add. + Definition w11_mul_add_n1 := + @gen_mul_add_n1 w11 W0 w11_op.(znz_WW) w11_op.(znz_0W) w11_mul_add. + Definition w12_mul_add_n1 := + @gen_mul_add_n1 w12 W0 w12_op.(znz_WW) w12_op.(znz_0W) w12_mul_add. + + Definition mul x y := + match x, y with + | N0 wx, N0 wy => + reduce_1 (w0_mul_c wx wy) + | N0 wx, N1 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 1 wy wx w_0 in + if w0_eq0 w then N1 r + else N2 (WW (WW w_0 w) r) + | N0 wx, N2 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 2 wy wx w_0 in + if w0_eq0 w then N2 r + else N3 (WW (extend1 w0 (WW w_0 w)) r) + | N0 wx, N3 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 3 wy wx w_0 in + if w0_eq0 w then N3 r + else N4 (WW (extend2 w0 (WW w_0 w)) r) + | N0 wx, N4 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 4 wy wx w_0 in + if w0_eq0 w then N4 r + else N5 (WW (extend3 w0 (WW w_0 w)) r) + | N0 wx, N5 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 5 wy wx w_0 in + if w0_eq0 w then N5 r + else N6 (WW (extend4 w0 (WW w_0 w)) r) + | N0 wx, N6 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 6 wy wx w_0 in + if w0_eq0 w then N6 r + else N7 (WW (extend5 w0 (WW w_0 w)) r) + | N0 wx, N7 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 7 wy wx w_0 in + if w0_eq0 w then N7 r + else N8 (WW (extend6 w0 (WW w_0 w)) r) + | N0 wx, N8 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 8 wy wx w_0 in + if w0_eq0 w then N8 r + else N9 (WW (extend7 w0 (WW w_0 w)) r) + | N0 wx, N9 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 9 wy wx w_0 in + if w0_eq0 w then N9 r + else N10 (WW (extend8 w0 (WW w_0 w)) r) + | N0 wx, N10 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 10 wy wx w_0 in + if w0_eq0 w then N10 r + else N11 (WW (extend9 w0 (WW w_0 w)) r) + | N0 wx, N11 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 11 wy wx w_0 in + if w0_eq0 w then N11 r + else N12 (WW (extend10 w0 (WW w_0 w)) r) + | N0 wx, N12 wy => + if w0_eq0 wx then zero + else + let (w,r) := w0_mul_add_n1 12 wy wx w_0 in + if w0_eq0 w then N12 r + else Nn 0 (WW (extend11 w0 (WW w_0 w)) r) + | N0 wx, Nn n wy => + if w0_eq0 wx then zero + else + let (w,r) := + gen_mul_add_mn1 w_0 (fun r => extend11 w0 (WW w_0 r)) + w12_op.(znz_0W) w12_op.(znz_WW) + (w0_mul_add_n1 12) (S n) wy wx w_0 in + if w0_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (extend12 w0 (WW w_0 w))) r) + | N1 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 1 wx wy w_0 in + if w0_eq0 w then N1 r + else N2 (WW (WW w_0 w) r) + | N1 wx, N1 wy => + N2 (w1_mul_c wx wy) + | N1 wx, N2 wy => + let (w,r) := w1_mul_add_n1 1 wy wx W0 in + if w1_eq0 w then N2 r + else N3 (WW (extend1 w0 w) r) + | N1 wx, N3 wy => + let (w,r) := w1_mul_add_n1 2 wy wx W0 in + if w1_eq0 w then N3 r + else N4 (WW (extend2 w0 w) r) + | N1 wx, N4 wy => + let (w,r) := w1_mul_add_n1 3 wy wx W0 in + if w1_eq0 w then N4 r + else N5 (WW (extend3 w0 w) r) + | N1 wx, N5 wy => + let (w,r) := w1_mul_add_n1 4 wy wx W0 in + if w1_eq0 w then N5 r + else N6 (WW (extend4 w0 w) r) + | N1 wx, N6 wy => + let (w,r) := w1_mul_add_n1 5 wy wx W0 in + if w1_eq0 w then N6 r + else N7 (WW (extend5 w0 w) r) + | N1 wx, N7 wy => + let (w,r) := w1_mul_add_n1 6 wy wx W0 in + if w1_eq0 w then N7 r + else N8 (WW (extend6 w0 w) r) + | N1 wx, N8 wy => + let (w,r) := w1_mul_add_n1 7 wy wx W0 in + if w1_eq0 w then N8 r + else N9 (WW (extend7 w0 w) r) + | N1 wx, N9 wy => + let (w,r) := w1_mul_add_n1 8 wy wx W0 in + if w1_eq0 w then N9 r + else N10 (WW (extend8 w0 w) r) + | N1 wx, N10 wy => + let (w,r) := w1_mul_add_n1 9 wy wx W0 in + if w1_eq0 w then N10 r + else N11 (WW (extend9 w0 w) r) + | N1 wx, N11 wy => + let (w,r) := w1_mul_add_n1 10 wy wx W0 in + if w1_eq0 w then N11 r + else N12 (WW (extend10 w0 w) r) + | N1 wx, N12 wy => + let (w,r) := w1_mul_add_n1 11 wy wx W0 in + if w1_eq0 w then N12 r + else Nn 0 (WW (extend11 w0 w) r) + | N1 wx, Nn n wy => + let (w,r) := + gen_mul_add_mn1 W0 (fun r => extend11 w0 r) + w12_op.(znz_0W) w12_op.(znz_WW) + (w1_mul_add_n1 11) (S n) wy wx W0 in + if w1_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (extend12 w0 w)) r) + | N2 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 2 wx wy w_0 in + if w0_eq0 w then N2 r + else N3 (WW (extend1 w0 (WW w_0 w)) r) + | N2 wx, N1 wy => + let (w,r) := w1_mul_add_n1 1 wx wy W0 in + if w1_eq0 w then N2 r + else N3 (WW (extend1 w0 w) r) + | N2 wx, N2 wy => + N3 (w2_mul_c wx wy) + | N2 wx, N3 wy => + let (w,r) := w2_mul_add_n1 1 wy wx W0 in + if w2_eq0 w then N3 r + else N4 (WW (extend1 w1 w) r) + | N2 wx, N4 wy => + let (w,r) := w2_mul_add_n1 2 wy wx W0 in + if w2_eq0 w then N4 r + else N5 (WW (extend2 w1 w) r) + | N2 wx, N5 wy => + let (w,r) := w2_mul_add_n1 3 wy wx W0 in + if w2_eq0 w then N5 r + else N6 (WW (extend3 w1 w) r) + | N2 wx, N6 wy => + let (w,r) := w2_mul_add_n1 4 wy wx W0 in + if w2_eq0 w then N6 r + else N7 (WW (extend4 w1 w) r) + | N2 wx, N7 wy => + let (w,r) := w2_mul_add_n1 5 wy wx W0 in + if w2_eq0 w then N7 r + else N8 (WW (extend5 w1 w) r) + | N2 wx, N8 wy => + let (w,r) := w2_mul_add_n1 6 wy wx W0 in + if w2_eq0 w then N8 r + else N9 (WW (extend6 w1 w) r) + | N2 wx, N9 wy => + let (w,r) := w2_mul_add_n1 7 wy wx W0 in + if w2_eq0 w then N9 r + else N10 (WW (extend7 w1 w) r) + | N2 wx, N10 wy => + let (w,r) := w2_mul_add_n1 8 wy wx W0 in + if w2_eq0 w then N10 r + else N11 (WW (extend8 w1 w) r) + | N2 wx, N11 wy => + let (w,r) := w2_mul_add_n1 9 wy wx W0 in + if w2_eq0 w then N11 r + else N12 (WW (extend9 w1 w) r) + | N2 wx, N12 wy => + let (w,r) := w2_mul_add_n1 10 wy wx W0 in + if w2_eq0 w then N12 r + else Nn 0 (WW (extend10 w1 w) r) + | N2 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend10 w1 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N3 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 3 wx wy w_0 in + if w0_eq0 w then N3 r + else N4 (WW (extend2 w0 (WW w_0 w)) r) + | N3 wx, N1 wy => + let (w,r) := w1_mul_add_n1 2 wx wy W0 in + if w1_eq0 w then N3 r + else N4 (WW (extend2 w0 w) r) + | N3 wx, N2 wy => + let (w,r) := w2_mul_add_n1 1 wx wy W0 in + if w2_eq0 w then N3 r + else N4 (WW (extend1 w1 w) r) + | N3 wx, N3 wy => + N4 (w3_mul_c wx wy) + | N3 wx, N4 wy => + let (w,r) := w3_mul_add_n1 1 wy wx W0 in + if w3_eq0 w then N4 r + else N5 (WW (extend1 w2 w) r) + | N3 wx, N5 wy => + let (w,r) := w3_mul_add_n1 2 wy wx W0 in + if w3_eq0 w then N5 r + else N6 (WW (extend2 w2 w) r) + | N3 wx, N6 wy => + let (w,r) := w3_mul_add_n1 3 wy wx W0 in + if w3_eq0 w then N6 r + else N7 (WW (extend3 w2 w) r) + | N3 wx, N7 wy => + let (w,r) := w3_mul_add_n1 4 wy wx W0 in + if w3_eq0 w then N7 r + else N8 (WW (extend4 w2 w) r) + | N3 wx, N8 wy => + let (w,r) := w3_mul_add_n1 5 wy wx W0 in + if w3_eq0 w then N8 r + else N9 (WW (extend5 w2 w) r) + | N3 wx, N9 wy => + let (w,r) := w3_mul_add_n1 6 wy wx W0 in + if w3_eq0 w then N9 r + else N10 (WW (extend6 w2 w) r) + | N3 wx, N10 wy => + let (w,r) := w3_mul_add_n1 7 wy wx W0 in + if w3_eq0 w then N10 r + else N11 (WW (extend7 w2 w) r) + | N3 wx, N11 wy => + let (w,r) := w3_mul_add_n1 8 wy wx W0 in + if w3_eq0 w then N11 r + else N12 (WW (extend8 w2 w) r) + | N3 wx, N12 wy => + let (w,r) := w3_mul_add_n1 9 wy wx W0 in + if w3_eq0 w then N12 r + else Nn 0 (WW (extend9 w2 w) r) + | N3 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend9 w2 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N4 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 4 wx wy w_0 in + if w0_eq0 w then N4 r + else N5 (WW (extend3 w0 (WW w_0 w)) r) + | N4 wx, N1 wy => + let (w,r) := w1_mul_add_n1 3 wx wy W0 in + if w1_eq0 w then N4 r + else N5 (WW (extend3 w0 w) r) + | N4 wx, N2 wy => + let (w,r) := w2_mul_add_n1 2 wx wy W0 in + if w2_eq0 w then N4 r + else N5 (WW (extend2 w1 w) r) + | N4 wx, N3 wy => + let (w,r) := w3_mul_add_n1 1 wx wy W0 in + if w3_eq0 w then N4 r + else N5 (WW (extend1 w2 w) r) + | N4 wx, N4 wy => + N5 (w4_mul_c wx wy) + | N4 wx, N5 wy => + let (w,r) := w4_mul_add_n1 1 wy wx W0 in + if w4_eq0 w then N5 r + else N6 (WW (extend1 w3 w) r) + | N4 wx, N6 wy => + let (w,r) := w4_mul_add_n1 2 wy wx W0 in + if w4_eq0 w then N6 r + else N7 (WW (extend2 w3 w) r) + | N4 wx, N7 wy => + let (w,r) := w4_mul_add_n1 3 wy wx W0 in + if w4_eq0 w then N7 r + else N8 (WW (extend3 w3 w) r) + | N4 wx, N8 wy => + let (w,r) := w4_mul_add_n1 4 wy wx W0 in + if w4_eq0 w then N8 r + else N9 (WW (extend4 w3 w) r) + | N4 wx, N9 wy => + let (w,r) := w4_mul_add_n1 5 wy wx W0 in + if w4_eq0 w then N9 r + else N10 (WW (extend5 w3 w) r) + | N4 wx, N10 wy => + let (w,r) := w4_mul_add_n1 6 wy wx W0 in + if w4_eq0 w then N10 r + else N11 (WW (extend6 w3 w) r) + | N4 wx, N11 wy => + let (w,r) := w4_mul_add_n1 7 wy wx W0 in + if w4_eq0 w then N11 r + else N12 (WW (extend7 w3 w) r) + | N4 wx, N12 wy => + let (w,r) := w4_mul_add_n1 8 wy wx W0 in + if w4_eq0 w then N12 r + else Nn 0 (WW (extend8 w3 w) r) + | N4 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend8 w3 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N5 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 5 wx wy w_0 in + if w0_eq0 w then N5 r + else N6 (WW (extend4 w0 (WW w_0 w)) r) + | N5 wx, N1 wy => + let (w,r) := w1_mul_add_n1 4 wx wy W0 in + if w1_eq0 w then N5 r + else N6 (WW (extend4 w0 w) r) + | N5 wx, N2 wy => + let (w,r) := w2_mul_add_n1 3 wx wy W0 in + if w2_eq0 w then N5 r + else N6 (WW (extend3 w1 w) r) + | N5 wx, N3 wy => + let (w,r) := w3_mul_add_n1 2 wx wy W0 in + if w3_eq0 w then N5 r + else N6 (WW (extend2 w2 w) r) + | N5 wx, N4 wy => + let (w,r) := w4_mul_add_n1 1 wx wy W0 in + if w4_eq0 w then N5 r + else N6 (WW (extend1 w3 w) r) + | N5 wx, N5 wy => + N6 (w5_mul_c wx wy) + | N5 wx, N6 wy => + let (w,r) := w5_mul_add_n1 1 wy wx W0 in + if w5_eq0 w then N6 r + else N7 (WW (extend1 w4 w) r) + | N5 wx, N7 wy => + let (w,r) := w5_mul_add_n1 2 wy wx W0 in + if w5_eq0 w then N7 r + else N8 (WW (extend2 w4 w) r) + | N5 wx, N8 wy => + let (w,r) := w5_mul_add_n1 3 wy wx W0 in + if w5_eq0 w then N8 r + else N9 (WW (extend3 w4 w) r) + | N5 wx, N9 wy => + let (w,r) := w5_mul_add_n1 4 wy wx W0 in + if w5_eq0 w then N9 r + else N10 (WW (extend4 w4 w) r) + | N5 wx, N10 wy => + let (w,r) := w5_mul_add_n1 5 wy wx W0 in + if w5_eq0 w then N10 r + else N11 (WW (extend5 w4 w) r) + | N5 wx, N11 wy => + let (w,r) := w5_mul_add_n1 6 wy wx W0 in + if w5_eq0 w then N11 r + else N12 (WW (extend6 w4 w) r) + | N5 wx, N12 wy => + let (w,r) := w5_mul_add_n1 7 wy wx W0 in + if w5_eq0 w then N12 r + else Nn 0 (WW (extend7 w4 w) r) + | N5 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend7 w4 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N6 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 6 wx wy w_0 in + if w0_eq0 w then N6 r + else N7 (WW (extend5 w0 (WW w_0 w)) r) + | N6 wx, N1 wy => + let (w,r) := w1_mul_add_n1 5 wx wy W0 in + if w1_eq0 w then N6 r + else N7 (WW (extend5 w0 w) r) + | N6 wx, N2 wy => + let (w,r) := w2_mul_add_n1 4 wx wy W0 in + if w2_eq0 w then N6 r + else N7 (WW (extend4 w1 w) r) + | N6 wx, N3 wy => + let (w,r) := w3_mul_add_n1 3 wx wy W0 in + if w3_eq0 w then N6 r + else N7 (WW (extend3 w2 w) r) + | N6 wx, N4 wy => + let (w,r) := w4_mul_add_n1 2 wx wy W0 in + if w4_eq0 w then N6 r + else N7 (WW (extend2 w3 w) r) + | N6 wx, N5 wy => + let (w,r) := w5_mul_add_n1 1 wx wy W0 in + if w5_eq0 w then N6 r + else N7 (WW (extend1 w4 w) r) + | N6 wx, N6 wy => + N7 (w6_mul_c wx wy) + | N6 wx, N7 wy => + let (w,r) := w6_mul_add_n1 1 wy wx W0 in + if w6_eq0 w then N7 r + else N8 (WW (extend1 w5 w) r) + | N6 wx, N8 wy => + let (w,r) := w6_mul_add_n1 2 wy wx W0 in + if w6_eq0 w then N8 r + else N9 (WW (extend2 w5 w) r) + | N6 wx, N9 wy => + let (w,r) := w6_mul_add_n1 3 wy wx W0 in + if w6_eq0 w then N9 r + else N10 (WW (extend3 w5 w) r) + | N6 wx, N10 wy => + let (w,r) := w6_mul_add_n1 4 wy wx W0 in + if w6_eq0 w then N10 r + else N11 (WW (extend4 w5 w) r) + | N6 wx, N11 wy => + let (w,r) := w6_mul_add_n1 5 wy wx W0 in + if w6_eq0 w then N11 r + else N12 (WW (extend5 w5 w) r) + | N6 wx, N12 wy => + let (w,r) := w6_mul_add_n1 6 wy wx W0 in + if w6_eq0 w then N12 r + else Nn 0 (WW (extend6 w5 w) r) + | N6 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend6 w5 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N7 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 7 wx wy w_0 in + if w0_eq0 w then N7 r + else N8 (WW (extend6 w0 (WW w_0 w)) r) + | N7 wx, N1 wy => + let (w,r) := w1_mul_add_n1 6 wx wy W0 in + if w1_eq0 w then N7 r + else N8 (WW (extend6 w0 w) r) + | N7 wx, N2 wy => + let (w,r) := w2_mul_add_n1 5 wx wy W0 in + if w2_eq0 w then N7 r + else N8 (WW (extend5 w1 w) r) + | N7 wx, N3 wy => + let (w,r) := w3_mul_add_n1 4 wx wy W0 in + if w3_eq0 w then N7 r + else N8 (WW (extend4 w2 w) r) + | N7 wx, N4 wy => + let (w,r) := w4_mul_add_n1 3 wx wy W0 in + if w4_eq0 w then N7 r + else N8 (WW (extend3 w3 w) r) + | N7 wx, N5 wy => + let (w,r) := w5_mul_add_n1 2 wx wy W0 in + if w5_eq0 w then N7 r + else N8 (WW (extend2 w4 w) r) + | N7 wx, N6 wy => + let (w,r) := w6_mul_add_n1 1 wx wy W0 in + if w6_eq0 w then N7 r + else N8 (WW (extend1 w5 w) r) + | N7 wx, N7 wy => + N8 (w7_mul_c wx wy) + | N7 wx, N8 wy => + let (w,r) := w7_mul_add_n1 1 wy wx W0 in + if w7_eq0 w then N8 r + else N9 (WW (extend1 w6 w) r) + | N7 wx, N9 wy => + let (w,r) := w7_mul_add_n1 2 wy wx W0 in + if w7_eq0 w then N9 r + else N10 (WW (extend2 w6 w) r) + | N7 wx, N10 wy => + let (w,r) := w7_mul_add_n1 3 wy wx W0 in + if w7_eq0 w then N10 r + else N11 (WW (extend3 w6 w) r) + | N7 wx, N11 wy => + let (w,r) := w7_mul_add_n1 4 wy wx W0 in + if w7_eq0 w then N11 r + else N12 (WW (extend4 w6 w) r) + | N7 wx, N12 wy => + let (w,r) := w7_mul_add_n1 5 wy wx W0 in + if w7_eq0 w then N12 r + else Nn 0 (WW (extend5 w6 w) r) + | N7 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend5 w6 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N8 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 8 wx wy w_0 in + if w0_eq0 w then N8 r + else N9 (WW (extend7 w0 (WW w_0 w)) r) + | N8 wx, N1 wy => + let (w,r) := w1_mul_add_n1 7 wx wy W0 in + if w1_eq0 w then N8 r + else N9 (WW (extend7 w0 w) r) + | N8 wx, N2 wy => + let (w,r) := w2_mul_add_n1 6 wx wy W0 in + if w2_eq0 w then N8 r + else N9 (WW (extend6 w1 w) r) + | N8 wx, N3 wy => + let (w,r) := w3_mul_add_n1 5 wx wy W0 in + if w3_eq0 w then N8 r + else N9 (WW (extend5 w2 w) r) + | N8 wx, N4 wy => + let (w,r) := w4_mul_add_n1 4 wx wy W0 in + if w4_eq0 w then N8 r + else N9 (WW (extend4 w3 w) r) + | N8 wx, N5 wy => + let (w,r) := w5_mul_add_n1 3 wx wy W0 in + if w5_eq0 w then N8 r + else N9 (WW (extend3 w4 w) r) + | N8 wx, N6 wy => + let (w,r) := w6_mul_add_n1 2 wx wy W0 in + if w6_eq0 w then N8 r + else N9 (WW (extend2 w5 w) r) + | N8 wx, N7 wy => + let (w,r) := w7_mul_add_n1 1 wx wy W0 in + if w7_eq0 w then N8 r + else N9 (WW (extend1 w6 w) r) + | N8 wx, N8 wy => + N9 (w8_mul_c wx wy) + | N8 wx, N9 wy => + let (w,r) := w8_mul_add_n1 1 wy wx W0 in + if w8_eq0 w then N9 r + else N10 (WW (extend1 w7 w) r) + | N8 wx, N10 wy => + let (w,r) := w8_mul_add_n1 2 wy wx W0 in + if w8_eq0 w then N10 r + else N11 (WW (extend2 w7 w) r) + | N8 wx, N11 wy => + let (w,r) := w8_mul_add_n1 3 wy wx W0 in + if w8_eq0 w then N11 r + else N12 (WW (extend3 w7 w) r) + | N8 wx, N12 wy => + let (w,r) := w8_mul_add_n1 4 wy wx W0 in + if w8_eq0 w then N12 r + else Nn 0 (WW (extend4 w7 w) r) + | N8 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend4 w7 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N9 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 9 wx wy w_0 in + if w0_eq0 w then N9 r + else N10 (WW (extend8 w0 (WW w_0 w)) r) + | N9 wx, N1 wy => + let (w,r) := w1_mul_add_n1 8 wx wy W0 in + if w1_eq0 w then N9 r + else N10 (WW (extend8 w0 w) r) + | N9 wx, N2 wy => + let (w,r) := w2_mul_add_n1 7 wx wy W0 in + if w2_eq0 w then N9 r + else N10 (WW (extend7 w1 w) r) + | N9 wx, N3 wy => + let (w,r) := w3_mul_add_n1 6 wx wy W0 in + if w3_eq0 w then N9 r + else N10 (WW (extend6 w2 w) r) + | N9 wx, N4 wy => + let (w,r) := w4_mul_add_n1 5 wx wy W0 in + if w4_eq0 w then N9 r + else N10 (WW (extend5 w3 w) r) + | N9 wx, N5 wy => + let (w,r) := w5_mul_add_n1 4 wx wy W0 in + if w5_eq0 w then N9 r + else N10 (WW (extend4 w4 w) r) + | N9 wx, N6 wy => + let (w,r) := w6_mul_add_n1 3 wx wy W0 in + if w6_eq0 w then N9 r + else N10 (WW (extend3 w5 w) r) + | N9 wx, N7 wy => + let (w,r) := w7_mul_add_n1 2 wx wy W0 in + if w7_eq0 w then N9 r + else N10 (WW (extend2 w6 w) r) + | N9 wx, N8 wy => + let (w,r) := w8_mul_add_n1 1 wx wy W0 in + if w8_eq0 w then N9 r + else N10 (WW (extend1 w7 w) r) + | N9 wx, N9 wy => + N10 (w9_mul_c wx wy) + | N9 wx, N10 wy => + let (w,r) := w9_mul_add_n1 1 wy wx W0 in + if w9_eq0 w then N10 r + else N11 (WW (extend1 w8 w) r) + | N9 wx, N11 wy => + let (w,r) := w9_mul_add_n1 2 wy wx W0 in + if w9_eq0 w then N11 r + else N12 (WW (extend2 w8 w) r) + | N9 wx, N12 wy => + let (w,r) := w9_mul_add_n1 3 wy wx W0 in + if w9_eq0 w then N12 r + else Nn 0 (WW (extend3 w8 w) r) + | N9 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend3 w8 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N10 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 10 wx wy w_0 in + if w0_eq0 w then N10 r + else N11 (WW (extend9 w0 (WW w_0 w)) r) + | N10 wx, N1 wy => + let (w,r) := w1_mul_add_n1 9 wx wy W0 in + if w1_eq0 w then N10 r + else N11 (WW (extend9 w0 w) r) + | N10 wx, N2 wy => + let (w,r) := w2_mul_add_n1 8 wx wy W0 in + if w2_eq0 w then N10 r + else N11 (WW (extend8 w1 w) r) + | N10 wx, N3 wy => + let (w,r) := w3_mul_add_n1 7 wx wy W0 in + if w3_eq0 w then N10 r + else N11 (WW (extend7 w2 w) r) + | N10 wx, N4 wy => + let (w,r) := w4_mul_add_n1 6 wx wy W0 in + if w4_eq0 w then N10 r + else N11 (WW (extend6 w3 w) r) + | N10 wx, N5 wy => + let (w,r) := w5_mul_add_n1 5 wx wy W0 in + if w5_eq0 w then N10 r + else N11 (WW (extend5 w4 w) r) + | N10 wx, N6 wy => + let (w,r) := w6_mul_add_n1 4 wx wy W0 in + if w6_eq0 w then N10 r + else N11 (WW (extend4 w5 w) r) + | N10 wx, N7 wy => + let (w,r) := w7_mul_add_n1 3 wx wy W0 in + if w7_eq0 w then N10 r + else N11 (WW (extend3 w6 w) r) + | N10 wx, N8 wy => + let (w,r) := w8_mul_add_n1 2 wx wy W0 in + if w8_eq0 w then N10 r + else N11 (WW (extend2 w7 w) r) + | N10 wx, N9 wy => + let (w,r) := w9_mul_add_n1 1 wx wy W0 in + if w9_eq0 w then N10 r + else N11 (WW (extend1 w8 w) r) + | N10 wx, N10 wy => + N11 (w10_mul_c wx wy) + | N10 wx, N11 wy => + let (w,r) := w10_mul_add_n1 1 wy wx W0 in + if w10_eq0 w then N11 r + else N12 (WW (extend1 w9 w) r) + | N10 wx, N12 wy => + let (w,r) := w10_mul_add_n1 2 wy wx W0 in + if w10_eq0 w then N12 r + else Nn 0 (WW (extend2 w9 w) r) + | N10 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend2 w9 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N11 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 11 wx wy w_0 in + if w0_eq0 w then N11 r + else N12 (WW (extend10 w0 (WW w_0 w)) r) + | N11 wx, N1 wy => + let (w,r) := w1_mul_add_n1 10 wx wy W0 in + if w1_eq0 w then N11 r + else N12 (WW (extend10 w0 w) r) + | N11 wx, N2 wy => + let (w,r) := w2_mul_add_n1 9 wx wy W0 in + if w2_eq0 w then N11 r + else N12 (WW (extend9 w1 w) r) + | N11 wx, N3 wy => + let (w,r) := w3_mul_add_n1 8 wx wy W0 in + if w3_eq0 w then N11 r + else N12 (WW (extend8 w2 w) r) + | N11 wx, N4 wy => + let (w,r) := w4_mul_add_n1 7 wx wy W0 in + if w4_eq0 w then N11 r + else N12 (WW (extend7 w3 w) r) + | N11 wx, N5 wy => + let (w,r) := w5_mul_add_n1 6 wx wy W0 in + if w5_eq0 w then N11 r + else N12 (WW (extend6 w4 w) r) + | N11 wx, N6 wy => + let (w,r) := w6_mul_add_n1 5 wx wy W0 in + if w6_eq0 w then N11 r + else N12 (WW (extend5 w5 w) r) + | N11 wx, N7 wy => + let (w,r) := w7_mul_add_n1 4 wx wy W0 in + if w7_eq0 w then N11 r + else N12 (WW (extend4 w6 w) r) + | N11 wx, N8 wy => + let (w,r) := w8_mul_add_n1 3 wx wy W0 in + if w8_eq0 w then N11 r + else N12 (WW (extend3 w7 w) r) + | N11 wx, N9 wy => + let (w,r) := w9_mul_add_n1 2 wx wy W0 in + if w9_eq0 w then N11 r + else N12 (WW (extend2 w8 w) r) + | N11 wx, N10 wy => + let (w,r) := w10_mul_add_n1 1 wx wy W0 in + if w10_eq0 w then N11 r + else N12 (WW (extend1 w9 w) r) + | N11 wx, N11 wy => + N12 (w11_mul_c wx wy) + | N11 wx, N12 wy => + let (w,r) := w11_mul_add_n1 1 wy wx W0 in + if w11_eq0 w then N12 r + else Nn 0 (WW (extend1 w10 w) r) + | N11 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy (extend1 w10 wx) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | N12 wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := w0_mul_add_n1 12 wx wy w_0 in + if w0_eq0 w then N12 r + else Nn 0 (WW (extend11 w0 (WW w_0 w)) r) + | N12 wx, N1 wy => + let (w,r) := w1_mul_add_n1 11 wx wy W0 in + if w1_eq0 w then N12 r + else Nn 0 (WW (extend11 w0 w) r) + | N12 wx, N2 wy => + let (w,r) := w2_mul_add_n1 10 wx wy W0 in + if w2_eq0 w then N12 r + else Nn 0 (WW (extend10 w1 w) r) + | N12 wx, N3 wy => + let (w,r) := w3_mul_add_n1 9 wx wy W0 in + if w3_eq0 w then N12 r + else Nn 0 (WW (extend9 w2 w) r) + | N12 wx, N4 wy => + let (w,r) := w4_mul_add_n1 8 wx wy W0 in + if w4_eq0 w then N12 r + else Nn 0 (WW (extend8 w3 w) r) + | N12 wx, N5 wy => + let (w,r) := w5_mul_add_n1 7 wx wy W0 in + if w5_eq0 w then N12 r + else Nn 0 (WW (extend7 w4 w) r) + | N12 wx, N6 wy => + let (w,r) := w6_mul_add_n1 6 wx wy W0 in + if w6_eq0 w then N12 r + else Nn 0 (WW (extend6 w5 w) r) + | N12 wx, N7 wy => + let (w,r) := w7_mul_add_n1 5 wx wy W0 in + if w7_eq0 w then N12 r + else Nn 0 (WW (extend5 w6 w) r) + | N12 wx, N8 wy => + let (w,r) := w8_mul_add_n1 4 wx wy W0 in + if w8_eq0 w then N12 r + else Nn 0 (WW (extend4 w7 w) r) + | N12 wx, N9 wy => + let (w,r) := w9_mul_add_n1 3 wx wy W0 in + if w9_eq0 w then N12 r + else Nn 0 (WW (extend3 w8 w) r) + | N12 wx, N10 wy => + let (w,r) := w10_mul_add_n1 2 wx wy W0 in + if w10_eq0 w then N12 r + else Nn 0 (WW (extend2 w9 w) r) + | N12 wx, N11 wy => + let (w,r) := w11_mul_add_n1 1 wx wy W0 in + if w11_eq0 w then N12 r + else Nn 0 (WW (extend1 w10 w) r) + | N12 wx, N12 wy => + Nn 0 (w12_mul_c wx wy) + | N12 wx, Nn n wy => + let (w,r) := w12_mul_add_n1 (S n) wy wx W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N0 wy => + if w0_eq0 wy then zero + else + let (w,r) := + gen_mul_add_mn1 w_0 (fun r => extend11 w0 (WW w_0 r)) + w12_op.(znz_0W) w12_op.(znz_WW) + (w0_mul_add_n1 12) (S n) wx wy w_0 in + if w0_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (extend12 w0 (WW w_0 w))) r) + | Nn n wx, N1 wy => + let (w,r) := + gen_mul_add_mn1 W0 (fun r => extend11 w0 r) + w12_op.(znz_0W) w12_op.(znz_WW) + (w1_mul_add_n1 11) (S n) wx wy W0 in + if w1_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (extend12 w0 w)) r) + | Nn n wx, N2 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend10 w1 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N3 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend9 w2 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N4 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend8 w3 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N5 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend7 w4 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N6 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend6 w5 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N7 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend5 w6 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N8 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend4 w7 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N9 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend3 w8 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N10 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend2 w9 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N11 wy => + let (w,r) := w12_mul_add_n1 (S n) wx (extend1 w10 wy) W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, N12 wy => + let (w,r) := w12_mul_add_n1 (S n) wx wy W0 in + if w12_eq0 w then Nn n r + else Nn (S n) (WW (extend n w12 (WW W0 w)) r) + | Nn n wx, Nn m wy => + match extend_to_max w12 n m wx wy with + | inl wx' => + let op := make_op m in + reduce_n (S m) (op.(znz_mul_c) wx' wy) + | inr wy' => + let op := make_op n in + reduce_n (S n) (op.(znz_mul_c) wx wy') + end + end. + + Definition w0_square_c := w0_op.(znz_square_c). + Definition w1_square_c := w1_op.(znz_square_c). + Definition w2_square_c := w2_op.(znz_square_c). + Definition w3_square_c := w3_op.(znz_square_c). + Definition w4_square_c := w4_op.(znz_square_c). + Definition w5_square_c := w5_op.(znz_square_c). + Definition w6_square_c := w6_op.(znz_square_c). + Definition w7_square_c := w7_op.(znz_square_c). + Definition w8_square_c := w8_op.(znz_square_c). + Definition w9_square_c := w9_op.(znz_square_c). + Definition w10_square_c := w10_op.(znz_square_c). + Definition w11_square_c := w11_op.(znz_square_c). + Definition w12_square_c := w12_op.(znz_square_c). + + Definition square x := + match x with + | N0 wx => reduce_1 (w0_square_c wx) + | N1 wx => N2 (w1_square_c wx) + | N2 wx => N3 (w2_square_c wx) + | N3 wx => N4 (w3_square_c wx) + | N4 wx => N5 (w4_square_c wx) + | N5 wx => N6 (w5_square_c wx) + | N6 wx => N7 (w6_square_c wx) + | N7 wx => N8 (w7_square_c wx) + | N8 wx => N9 (w8_square_c wx) + | N9 wx => N10 (w9_square_c wx) + | N10 wx => N11 (w10_square_c wx) + | N11 wx => N12 (w11_square_c wx) + | N12 wx => Nn 0 (w12_square_c wx) + | Nn n wx => + let op := make_op n in + Nn (S n) (op.(znz_square_c) wx) + end. + + Fixpoint power_pos (x:t) (p:positive) {struct p} : t := + match p with + | xH => x + | xO p => square (power_pos x p) + | xI p => mul (square (power_pos x p)) x + end. + + Definition w0_sqrt := w0_op.(znz_sqrt). + Definition w1_sqrt := w1_op.(znz_sqrt). + Definition w2_sqrt := w2_op.(znz_sqrt). + Definition w3_sqrt := w3_op.(znz_sqrt). + Definition w4_sqrt := w4_op.(znz_sqrt). + Definition w5_sqrt := w5_op.(znz_sqrt). + Definition w6_sqrt := w6_op.(znz_sqrt). + Definition w7_sqrt := w7_op.(znz_sqrt). + Definition w8_sqrt := w8_op.(znz_sqrt). + Definition w9_sqrt := w9_op.(znz_sqrt). + Definition w10_sqrt := w10_op.(znz_sqrt). + Definition w11_sqrt := w11_op.(znz_sqrt). + Definition w12_sqrt := w12_op.(znz_sqrt). + + Definition sqrt x := + match x with + | N0 wx => reduce_0 (w0_sqrt wx) + | N1 wx => reduce_1 (w1_sqrt wx) + | N2 wx => reduce_2 (w2_sqrt wx) + | N3 wx => reduce_3 (w3_sqrt wx) + | N4 wx => reduce_4 (w4_sqrt wx) + | N5 wx => reduce_5 (w5_sqrt wx) + | N6 wx => reduce_6 (w6_sqrt wx) + | N7 wx => reduce_7 (w7_sqrt wx) + | N8 wx => reduce_8 (w8_sqrt wx) + | N9 wx => reduce_9 (w9_sqrt wx) + | N10 wx => reduce_10 (w10_sqrt wx) + | N11 wx => reduce_11 (w11_sqrt wx) + | N12 wx => reduce_12 (w12_sqrt wx) + | Nn n wx => + let op := make_op n in + reduce_n n (op.(znz_sqrt) wx) + end. + + Definition w0_div_gt := w0_op.(znz_div_gt). + Definition w1_div_gt := w1_op.(znz_div_gt). + Definition w2_div_gt := w2_op.(znz_div_gt). + Definition w3_div_gt := w3_op.(znz_div_gt). + Definition w4_div_gt := w4_op.(znz_div_gt). + Definition w5_div_gt := w5_op.(znz_div_gt). + Definition w6_div_gt := w6_op.(znz_div_gt). + Definition w7_div_gt := w7_op.(znz_div_gt). + Definition w8_div_gt := w8_op.(znz_div_gt). + Definition w9_div_gt := w9_op.(znz_div_gt). + Definition w10_div_gt := w10_op.(znz_div_gt). + Definition w11_div_gt := w11_op.(znz_div_gt). + Definition w12_div_gt := w12_op.(znz_div_gt). + + Definition w0_divn1 := + gen_divn1 w0_op.(znz_digits) w0_op.(znz_0) + w0_op.(znz_WW) w0_op.(znz_head0) + w0_op.(znz_add_mul_div) w0_op.(znz_div21). + Definition w1_divn1 := + gen_divn1 w1_op.(znz_digits) w1_op.(znz_0) + w1_op.(znz_WW) w1_op.(znz_head0) + w1_op.(znz_add_mul_div) w1_op.(znz_div21). + Definition w2_divn1 := + gen_divn1 w2_op.(znz_digits) w2_op.(znz_0) + w2_op.(znz_WW) w2_op.(znz_head0) + w2_op.(znz_add_mul_div) w2_op.(znz_div21). + Definition w3_divn1 := + gen_divn1 w3_op.(znz_digits) w3_op.(znz_0) + w3_op.(znz_WW) w3_op.(znz_head0) + w3_op.(znz_add_mul_div) w3_op.(znz_div21). + Definition w4_divn1 := + gen_divn1 w4_op.(znz_digits) w4_op.(znz_0) + w4_op.(znz_WW) w4_op.(znz_head0) + w4_op.(znz_add_mul_div) w4_op.(znz_div21). + Definition w5_divn1 := + gen_divn1 w5_op.(znz_digits) w5_op.(znz_0) + w5_op.(znz_WW) w5_op.(znz_head0) + w5_op.(znz_add_mul_div) w5_op.(znz_div21). + Definition w6_divn1 := + gen_divn1 w6_op.(znz_digits) w6_op.(znz_0) + w6_op.(znz_WW) w6_op.(znz_head0) + w6_op.(znz_add_mul_div) w6_op.(znz_div21). + Definition w7_divn1 := + gen_divn1 w7_op.(znz_digits) w7_op.(znz_0) + w7_op.(znz_WW) w7_op.(znz_head0) + w7_op.(znz_add_mul_div) w7_op.(znz_div21). + Definition w8_divn1 := + gen_divn1 w8_op.(znz_digits) w8_op.(znz_0) + w8_op.(znz_WW) w8_op.(znz_head0) + w8_op.(znz_add_mul_div) w8_op.(znz_div21). + Definition w9_divn1 := + gen_divn1 w9_op.(znz_digits) w9_op.(znz_0) + w9_op.(znz_WW) w9_op.(znz_head0) + w9_op.(znz_add_mul_div) w9_op.(znz_div21). + Definition w10_divn1 := + gen_divn1 w10_op.(znz_digits) w10_op.(znz_0) + w10_op.(znz_WW) w10_op.(znz_head0) + w10_op.(znz_add_mul_div) w10_op.(znz_div21). + Definition w11_divn1 := + gen_divn1 w11_op.(znz_digits) w11_op.(znz_0) + w11_op.(znz_WW) w11_op.(znz_head0) + w11_op.(znz_add_mul_div) w11_op.(znz_div21). + Definition w12_divn1 := + gen_divn1 w12_op.(znz_digits) w12_op.(znz_0) + w12_op.(znz_WW) w12_op.(znz_head0) + w12_op.(znz_add_mul_div) w12_op.(znz_div21). + + Definition div_gt x y := + match x, y with + | N0 wx, N0 wy => let (q, r):= w0_div_gt wx wy in (reduce_0 q, reduce_0 r) + | N0 wx, N1 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 0 wx in + let (q, r):= w1_div_gt wx' wy in + (reduce_1 q, reduce_1 r) + | N0 wx, N2 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 1 wx in + let (q, r):= w2_div_gt wx' wy in + (reduce_2 q, reduce_2 r) + | N0 wx, N3 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 2 wx in + let (q, r):= w3_div_gt wx' wy in + (reduce_3 q, reduce_3 r) + | N0 wx, N4 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 3 wx in + let (q, r):= w4_div_gt wx' wy in + (reduce_4 q, reduce_4 r) + | N0 wx, N5 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 4 wx in + let (q, r):= w5_div_gt wx' wy in + (reduce_5 q, reduce_5 r) + | N0 wx, N6 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 5 wx in + let (q, r):= w6_div_gt wx' wy in + (reduce_6 q, reduce_6 r) + | N0 wx, N7 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 6 wx in + let (q, r):= w7_div_gt wx' wy in + (reduce_7 q, reduce_7 r) + | N0 wx, N8 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 7 wx in + let (q, r):= w8_div_gt wx' wy in + (reduce_8 q, reduce_8 r) + | N0 wx, N9 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 8 wx in + let (q, r):= w9_div_gt wx' wy in + (reduce_9 q, reduce_9 r) + | N0 wx, N10 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 9 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N0 wx, N11 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 10 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N0 wx, N12 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 11 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N0 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w0_op.(znz_0W) 12 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N1 wx, N0 wy => let (q, r):= w0_divn1 1 wx wy in (reduce_1 q, reduce_0 r) + | N1 wx, N1 wy => let (q, r):= w1_div_gt wx wy in (reduce_1 q, reduce_1 r) + | N1 wx, N2 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 0 wx in + let (q, r):= w2_div_gt wx' wy in + (reduce_2 q, reduce_2 r) + | N1 wx, N3 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 1 wx in + let (q, r):= w3_div_gt wx' wy in + (reduce_3 q, reduce_3 r) + | N1 wx, N4 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 2 wx in + let (q, r):= w4_div_gt wx' wy in + (reduce_4 q, reduce_4 r) + | N1 wx, N5 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 3 wx in + let (q, r):= w5_div_gt wx' wy in + (reduce_5 q, reduce_5 r) + | N1 wx, N6 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 4 wx in + let (q, r):= w6_div_gt wx' wy in + (reduce_6 q, reduce_6 r) + | N1 wx, N7 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 5 wx in + let (q, r):= w7_div_gt wx' wy in + (reduce_7 q, reduce_7 r) + | N1 wx, N8 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 6 wx in + let (q, r):= w8_div_gt wx' wy in + (reduce_8 q, reduce_8 r) + | N1 wx, N9 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 7 wx in + let (q, r):= w9_div_gt wx' wy in + (reduce_9 q, reduce_9 r) + | N1 wx, N10 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 8 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N1 wx, N11 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 9 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N1 wx, N12 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 10 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N1 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w1_op.(znz_0W) 11 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N2 wx, N0 wy => let (q, r):= w0_divn1 2 wx wy in (reduce_2 q, reduce_0 r) + | N2 wx, N1 wy => let (q, r):= w1_divn1 1 wx wy in (reduce_2 q, reduce_1 r) + | N2 wx, N2 wy => let (q, r):= w2_div_gt wx wy in (reduce_2 q, reduce_2 r) + | N2 wx, N3 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 0 wx in + let (q, r):= w3_div_gt wx' wy in + (reduce_3 q, reduce_3 r) + | N2 wx, N4 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 1 wx in + let (q, r):= w4_div_gt wx' wy in + (reduce_4 q, reduce_4 r) + | N2 wx, N5 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 2 wx in + let (q, r):= w5_div_gt wx' wy in + (reduce_5 q, reduce_5 r) + | N2 wx, N6 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 3 wx in + let (q, r):= w6_div_gt wx' wy in + (reduce_6 q, reduce_6 r) + | N2 wx, N7 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 4 wx in + let (q, r):= w7_div_gt wx' wy in + (reduce_7 q, reduce_7 r) + | N2 wx, N8 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 5 wx in + let (q, r):= w8_div_gt wx' wy in + (reduce_8 q, reduce_8 r) + | N2 wx, N9 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 6 wx in + let (q, r):= w9_div_gt wx' wy in + (reduce_9 q, reduce_9 r) + | N2 wx, N10 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 7 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N2 wx, N11 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 8 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N2 wx, N12 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 9 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N2 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w2_op.(znz_0W) 10 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N3 wx, N0 wy => let (q, r):= w0_divn1 3 wx wy in (reduce_3 q, reduce_0 r) + | N3 wx, N1 wy => let (q, r):= w1_divn1 2 wx wy in (reduce_3 q, reduce_1 r) + | N3 wx, N2 wy => let (q, r):= w2_divn1 1 wx wy in (reduce_3 q, reduce_2 r) + | N3 wx, N3 wy => let (q, r):= w3_div_gt wx wy in (reduce_3 q, reduce_3 r) + | N3 wx, N4 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 0 wx in + let (q, r):= w4_div_gt wx' wy in + (reduce_4 q, reduce_4 r) + | N3 wx, N5 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 1 wx in + let (q, r):= w5_div_gt wx' wy in + (reduce_5 q, reduce_5 r) + | N3 wx, N6 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 2 wx in + let (q, r):= w6_div_gt wx' wy in + (reduce_6 q, reduce_6 r) + | N3 wx, N7 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 3 wx in + let (q, r):= w7_div_gt wx' wy in + (reduce_7 q, reduce_7 r) + | N3 wx, N8 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 4 wx in + let (q, r):= w8_div_gt wx' wy in + (reduce_8 q, reduce_8 r) + | N3 wx, N9 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 5 wx in + let (q, r):= w9_div_gt wx' wy in + (reduce_9 q, reduce_9 r) + | N3 wx, N10 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 6 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N3 wx, N11 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 7 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N3 wx, N12 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 8 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N3 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w3_op.(znz_0W) 9 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N4 wx, N0 wy => let (q, r):= w0_divn1 4 wx wy in (reduce_4 q, reduce_0 r) + | N4 wx, N1 wy => let (q, r):= w1_divn1 3 wx wy in (reduce_4 q, reduce_1 r) + | N4 wx, N2 wy => let (q, r):= w2_divn1 2 wx wy in (reduce_4 q, reduce_2 r) + | N4 wx, N3 wy => let (q, r):= w3_divn1 1 wx wy in (reduce_4 q, reduce_3 r) + | N4 wx, N4 wy => let (q, r):= w4_div_gt wx wy in (reduce_4 q, reduce_4 r) + | N4 wx, N5 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 0 wx in + let (q, r):= w5_div_gt wx' wy in + (reduce_5 q, reduce_5 r) + | N4 wx, N6 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 1 wx in + let (q, r):= w6_div_gt wx' wy in + (reduce_6 q, reduce_6 r) + | N4 wx, N7 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 2 wx in + let (q, r):= w7_div_gt wx' wy in + (reduce_7 q, reduce_7 r) + | N4 wx, N8 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 3 wx in + let (q, r):= w8_div_gt wx' wy in + (reduce_8 q, reduce_8 r) + | N4 wx, N9 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 4 wx in + let (q, r):= w9_div_gt wx' wy in + (reduce_9 q, reduce_9 r) + | N4 wx, N10 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 5 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N4 wx, N11 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 6 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N4 wx, N12 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 7 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N4 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w4_op.(znz_0W) 8 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N5 wx, N0 wy => let (q, r):= w0_divn1 5 wx wy in (reduce_5 q, reduce_0 r) + | N5 wx, N1 wy => let (q, r):= w1_divn1 4 wx wy in (reduce_5 q, reduce_1 r) + | N5 wx, N2 wy => let (q, r):= w2_divn1 3 wx wy in (reduce_5 q, reduce_2 r) + | N5 wx, N3 wy => let (q, r):= w3_divn1 2 wx wy in (reduce_5 q, reduce_3 r) + | N5 wx, N4 wy => let (q, r):= w4_divn1 1 wx wy in (reduce_5 q, reduce_4 r) + | N5 wx, N5 wy => let (q, r):= w5_div_gt wx wy in (reduce_5 q, reduce_5 r) + | N5 wx, N6 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 0 wx in + let (q, r):= w6_div_gt wx' wy in + (reduce_6 q, reduce_6 r) + | N5 wx, N7 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 1 wx in + let (q, r):= w7_div_gt wx' wy in + (reduce_7 q, reduce_7 r) + | N5 wx, N8 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 2 wx in + let (q, r):= w8_div_gt wx' wy in + (reduce_8 q, reduce_8 r) + | N5 wx, N9 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 3 wx in + let (q, r):= w9_div_gt wx' wy in + (reduce_9 q, reduce_9 r) + | N5 wx, N10 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 4 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N5 wx, N11 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 5 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N5 wx, N12 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 6 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N5 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w5_op.(znz_0W) 7 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N6 wx, N0 wy => let (q, r):= w0_divn1 6 wx wy in (reduce_6 q, reduce_0 r) + | N6 wx, N1 wy => let (q, r):= w1_divn1 5 wx wy in (reduce_6 q, reduce_1 r) + | N6 wx, N2 wy => let (q, r):= w2_divn1 4 wx wy in (reduce_6 q, reduce_2 r) + | N6 wx, N3 wy => let (q, r):= w3_divn1 3 wx wy in (reduce_6 q, reduce_3 r) + | N6 wx, N4 wy => let (q, r):= w4_divn1 2 wx wy in (reduce_6 q, reduce_4 r) + | N6 wx, N5 wy => let (q, r):= w5_divn1 1 wx wy in (reduce_6 q, reduce_5 r) + | N6 wx, N6 wy => let (q, r):= w6_div_gt wx wy in (reduce_6 q, reduce_6 r) + | N6 wx, N7 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 0 wx in + let (q, r):= w7_div_gt wx' wy in + (reduce_7 q, reduce_7 r) + | N6 wx, N8 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 1 wx in + let (q, r):= w8_div_gt wx' wy in + (reduce_8 q, reduce_8 r) + | N6 wx, N9 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 2 wx in + let (q, r):= w9_div_gt wx' wy in + (reduce_9 q, reduce_9 r) + | N6 wx, N10 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 3 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N6 wx, N11 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 4 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N6 wx, N12 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 5 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N6 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w6_op.(znz_0W) 6 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N7 wx, N0 wy => let (q, r):= w0_divn1 7 wx wy in (reduce_7 q, reduce_0 r) + | N7 wx, N1 wy => let (q, r):= w1_divn1 6 wx wy in (reduce_7 q, reduce_1 r) + | N7 wx, N2 wy => let (q, r):= w2_divn1 5 wx wy in (reduce_7 q, reduce_2 r) + | N7 wx, N3 wy => let (q, r):= w3_divn1 4 wx wy in (reduce_7 q, reduce_3 r) + | N7 wx, N4 wy => let (q, r):= w4_divn1 3 wx wy in (reduce_7 q, reduce_4 r) + | N7 wx, N5 wy => let (q, r):= w5_divn1 2 wx wy in (reduce_7 q, reduce_5 r) + | N7 wx, N6 wy => let (q, r):= w6_divn1 1 wx wy in (reduce_7 q, reduce_6 r) + | N7 wx, N7 wy => let (q, r):= w7_div_gt wx wy in (reduce_7 q, reduce_7 r) + | N7 wx, N8 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 0 wx in + let (q, r):= w8_div_gt wx' wy in + (reduce_8 q, reduce_8 r) + | N7 wx, N9 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 1 wx in + let (q, r):= w9_div_gt wx' wy in + (reduce_9 q, reduce_9 r) + | N7 wx, N10 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 2 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N7 wx, N11 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 3 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N7 wx, N12 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 4 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N7 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w7_op.(znz_0W) 5 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N8 wx, N0 wy => let (q, r):= w0_divn1 8 wx wy in (reduce_8 q, reduce_0 r) + | N8 wx, N1 wy => let (q, r):= w1_divn1 7 wx wy in (reduce_8 q, reduce_1 r) + | N8 wx, N2 wy => let (q, r):= w2_divn1 6 wx wy in (reduce_8 q, reduce_2 r) + | N8 wx, N3 wy => let (q, r):= w3_divn1 5 wx wy in (reduce_8 q, reduce_3 r) + | N8 wx, N4 wy => let (q, r):= w4_divn1 4 wx wy in (reduce_8 q, reduce_4 r) + | N8 wx, N5 wy => let (q, r):= w5_divn1 3 wx wy in (reduce_8 q, reduce_5 r) + | N8 wx, N6 wy => let (q, r):= w6_divn1 2 wx wy in (reduce_8 q, reduce_6 r) + | N8 wx, N7 wy => let (q, r):= w7_divn1 1 wx wy in (reduce_8 q, reduce_7 r) + | N8 wx, N8 wy => let (q, r):= w8_div_gt wx wy in (reduce_8 q, reduce_8 r) + | N8 wx, N9 wy => + let wx':= GenBase.extend w8_op.(znz_0W) 0 wx in + let (q, r):= w9_div_gt wx' wy in + (reduce_9 q, reduce_9 r) + | N8 wx, N10 wy => + let wx':= GenBase.extend w8_op.(znz_0W) 1 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N8 wx, N11 wy => + let wx':= GenBase.extend w8_op.(znz_0W) 2 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N8 wx, N12 wy => + let wx':= GenBase.extend w8_op.(znz_0W) 3 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N8 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w8_op.(znz_0W) 4 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N9 wx, N0 wy => let (q, r):= w0_divn1 9 wx wy in (reduce_9 q, reduce_0 r) + | N9 wx, N1 wy => let (q, r):= w1_divn1 8 wx wy in (reduce_9 q, reduce_1 r) + | N9 wx, N2 wy => let (q, r):= w2_divn1 7 wx wy in (reduce_9 q, reduce_2 r) + | N9 wx, N3 wy => let (q, r):= w3_divn1 6 wx wy in (reduce_9 q, reduce_3 r) + | N9 wx, N4 wy => let (q, r):= w4_divn1 5 wx wy in (reduce_9 q, reduce_4 r) + | N9 wx, N5 wy => let (q, r):= w5_divn1 4 wx wy in (reduce_9 q, reduce_5 r) + | N9 wx, N6 wy => let (q, r):= w6_divn1 3 wx wy in (reduce_9 q, reduce_6 r) + | N9 wx, N7 wy => let (q, r):= w7_divn1 2 wx wy in (reduce_9 q, reduce_7 r) + | N9 wx, N8 wy => let (q, r):= w8_divn1 1 wx wy in (reduce_9 q, reduce_8 r) + | N9 wx, N9 wy => let (q, r):= w9_div_gt wx wy in (reduce_9 q, reduce_9 r) + | N9 wx, N10 wy => + let wx':= GenBase.extend w9_op.(znz_0W) 0 wx in + let (q, r):= w10_div_gt wx' wy in + (reduce_10 q, reduce_10 r) + | N9 wx, N11 wy => + let wx':= GenBase.extend w9_op.(znz_0W) 1 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N9 wx, N12 wy => + let wx':= GenBase.extend w9_op.(znz_0W) 2 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N9 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w9_op.(znz_0W) 3 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N10 wx, N0 wy => let (q, r):= w0_divn1 10 wx wy in (reduce_10 q, reduce_0 r) + | N10 wx, N1 wy => let (q, r):= w1_divn1 9 wx wy in (reduce_10 q, reduce_1 r) + | N10 wx, N2 wy => let (q, r):= w2_divn1 8 wx wy in (reduce_10 q, reduce_2 r) + | N10 wx, N3 wy => let (q, r):= w3_divn1 7 wx wy in (reduce_10 q, reduce_3 r) + | N10 wx, N4 wy => let (q, r):= w4_divn1 6 wx wy in (reduce_10 q, reduce_4 r) + | N10 wx, N5 wy => let (q, r):= w5_divn1 5 wx wy in (reduce_10 q, reduce_5 r) + | N10 wx, N6 wy => let (q, r):= w6_divn1 4 wx wy in (reduce_10 q, reduce_6 r) + | N10 wx, N7 wy => let (q, r):= w7_divn1 3 wx wy in (reduce_10 q, reduce_7 r) + | N10 wx, N8 wy => let (q, r):= w8_divn1 2 wx wy in (reduce_10 q, reduce_8 r) + | N10 wx, N9 wy => let (q, r):= w9_divn1 1 wx wy in (reduce_10 q, reduce_9 r) + | N10 wx, N10 wy => let (q, r):= w10_div_gt wx wy in (reduce_10 q, reduce_10 r) + | N10 wx, N11 wy => + let wx':= GenBase.extend w10_op.(znz_0W) 0 wx in + let (q, r):= w11_div_gt wx' wy in + (reduce_11 q, reduce_11 r) + | N10 wx, N12 wy => + let wx':= GenBase.extend w10_op.(znz_0W) 1 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N10 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w10_op.(znz_0W) 2 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N11 wx, N0 wy => let (q, r):= w0_divn1 11 wx wy in (reduce_11 q, reduce_0 r) + | N11 wx, N1 wy => let (q, r):= w1_divn1 10 wx wy in (reduce_11 q, reduce_1 r) + | N11 wx, N2 wy => let (q, r):= w2_divn1 9 wx wy in (reduce_11 q, reduce_2 r) + | N11 wx, N3 wy => let (q, r):= w3_divn1 8 wx wy in (reduce_11 q, reduce_3 r) + | N11 wx, N4 wy => let (q, r):= w4_divn1 7 wx wy in (reduce_11 q, reduce_4 r) + | N11 wx, N5 wy => let (q, r):= w5_divn1 6 wx wy in (reduce_11 q, reduce_5 r) + | N11 wx, N6 wy => let (q, r):= w6_divn1 5 wx wy in (reduce_11 q, reduce_6 r) + | N11 wx, N7 wy => let (q, r):= w7_divn1 4 wx wy in (reduce_11 q, reduce_7 r) + | N11 wx, N8 wy => let (q, r):= w8_divn1 3 wx wy in (reduce_11 q, reduce_8 r) + | N11 wx, N9 wy => let (q, r):= w9_divn1 2 wx wy in (reduce_11 q, reduce_9 r) + | N11 wx, N10 wy => let (q, r):= w10_divn1 1 wx wy in (reduce_11 q, reduce_10 r) + | N11 wx, N11 wy => let (q, r):= w11_div_gt wx wy in (reduce_11 q, reduce_11 r) + | N11 wx, N12 wy => + let wx':= GenBase.extend w11_op.(znz_0W) 0 wx in + let (q, r):= w12_div_gt wx' wy in + (reduce_12 q, reduce_12 r) + | N11 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w11_op.(znz_0W) 1 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | N12 wx, N0 wy => let (q, r):= w0_divn1 12 wx wy in (reduce_12 q, reduce_0 r) + | N12 wx, N1 wy => let (q, r):= w1_divn1 11 wx wy in (reduce_12 q, reduce_1 r) + | N12 wx, N2 wy => let (q, r):= w2_divn1 10 wx wy in (reduce_12 q, reduce_2 r) + | N12 wx, N3 wy => let (q, r):= w3_divn1 9 wx wy in (reduce_12 q, reduce_3 r) + | N12 wx, N4 wy => let (q, r):= w4_divn1 8 wx wy in (reduce_12 q, reduce_4 r) + | N12 wx, N5 wy => let (q, r):= w5_divn1 7 wx wy in (reduce_12 q, reduce_5 r) + | N12 wx, N6 wy => let (q, r):= w6_divn1 6 wx wy in (reduce_12 q, reduce_6 r) + | N12 wx, N7 wy => let (q, r):= w7_divn1 5 wx wy in (reduce_12 q, reduce_7 r) + | N12 wx, N8 wy => let (q, r):= w8_divn1 4 wx wy in (reduce_12 q, reduce_8 r) + | N12 wx, N9 wy => let (q, r):= w9_divn1 3 wx wy in (reduce_12 q, reduce_9 r) + | N12 wx, N10 wy => let (q, r):= w10_divn1 2 wx wy in (reduce_12 q, reduce_10 r) + | N12 wx, N11 wy => let (q, r):= w11_divn1 1 wx wy in (reduce_12 q, reduce_11 r) + | N12 wx, N12 wy => let (q, r):= w12_div_gt wx wy in (reduce_12 q, reduce_12 r) + | N12 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w12_op.(znz_0W) 0 wx) in + let (q, r):= (make_op n).(znz_div_gt) wx' wy in + (reduce_n n q, reduce_n n r) + | Nn n wx, N0 wy => + let wy':= GenBase.extend w0_op.(znz_0W) 11 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N1 wy => + let wy':= GenBase.extend w1_op.(znz_0W) 10 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N2 wy => + let wy':= GenBase.extend w2_op.(znz_0W) 9 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N3 wy => + let wy':= GenBase.extend w3_op.(znz_0W) 8 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N4 wy => + let wy':= GenBase.extend w4_op.(znz_0W) 7 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N5 wy => + let wy':= GenBase.extend w5_op.(znz_0W) 6 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N6 wy => + let wy':= GenBase.extend w6_op.(znz_0W) 5 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N7 wy => + let wy':= GenBase.extend w7_op.(znz_0W) 4 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N8 wy => + let wy':= GenBase.extend w8_op.(znz_0W) 3 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N9 wy => + let wy':= GenBase.extend w9_op.(znz_0W) 2 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N10 wy => + let wy':= GenBase.extend w10_op.(znz_0W) 1 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N11 wy => + let wy':= GenBase.extend w11_op.(znz_0W) 0 wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, N12 wy => + let wy':= wy in + let (q, r):= w12_divn1 (S n) wx wy' in + (reduce_n n q, reduce_12 r) + | Nn n wx, Nn m wy => + match extend_to_max w12 n m wx wy with + | inl wx' => + let (q, r):= (make_op m).(znz_div) wx' wy in + (reduce_n m q, reduce_n m r) + | inr wy' => + let (q, r):= (make_op n).(znz_div) wx wy' in + (reduce_n n q, reduce_n n r) + end + end. + + Definition div_eucl x y := + match compare x y with + | Eq => (one, zero) + | Lt => (zero, x) + | Gt => div_gt x y + end. + + Definition div x y := fst (div_eucl x y). + + Definition w0_mod_gt := w0_op.(znz_mod_gt). + Definition w1_mod_gt := w1_op.(znz_mod_gt). + Definition w2_mod_gt := w2_op.(znz_mod_gt). + Definition w3_mod_gt := w3_op.(znz_mod_gt). + Definition w4_mod_gt := w4_op.(znz_mod_gt). + Definition w5_mod_gt := w5_op.(znz_mod_gt). + Definition w6_mod_gt := w6_op.(znz_mod_gt). + Definition w7_mod_gt := w7_op.(znz_mod_gt). + Definition w8_mod_gt := w8_op.(znz_mod_gt). + Definition w9_mod_gt := w9_op.(znz_mod_gt). + Definition w10_mod_gt := w10_op.(znz_mod_gt). + Definition w11_mod_gt := w11_op.(znz_mod_gt). + Definition w12_mod_gt := w12_op.(znz_mod_gt). + + Definition w0_modn1 := + gen_modn1 w0_op.(znz_digits) w0_op.(znz_0) + w0_op.(znz_head0) w0_op.(znz_add_mul_div) w0_op.(znz_div21). + Definition w1_modn1 := + gen_modn1 w1_op.(znz_digits) w1_op.(znz_0) + w1_op.(znz_head0) w1_op.(znz_add_mul_div) w1_op.(znz_div21). + Definition w2_modn1 := + gen_modn1 w2_op.(znz_digits) w2_op.(znz_0) + w2_op.(znz_head0) w2_op.(znz_add_mul_div) w2_op.(znz_div21). + Definition w3_modn1 := + gen_modn1 w3_op.(znz_digits) w3_op.(znz_0) + w3_op.(znz_head0) w3_op.(znz_add_mul_div) w3_op.(znz_div21). + Definition w4_modn1 := + gen_modn1 w4_op.(znz_digits) w4_op.(znz_0) + w4_op.(znz_head0) w4_op.(znz_add_mul_div) w4_op.(znz_div21). + Definition w5_modn1 := + gen_modn1 w5_op.(znz_digits) w5_op.(znz_0) + w5_op.(znz_head0) w5_op.(znz_add_mul_div) w5_op.(znz_div21). + Definition w6_modn1 := + gen_modn1 w6_op.(znz_digits) w6_op.(znz_0) + w6_op.(znz_head0) w6_op.(znz_add_mul_div) w6_op.(znz_div21). + Definition w7_modn1 := + gen_modn1 w7_op.(znz_digits) w7_op.(znz_0) + w7_op.(znz_head0) w7_op.(znz_add_mul_div) w7_op.(znz_div21). + Definition w8_modn1 := + gen_modn1 w8_op.(znz_digits) w8_op.(znz_0) + w8_op.(znz_head0) w8_op.(znz_add_mul_div) w8_op.(znz_div21). + Definition w9_modn1 := + gen_modn1 w9_op.(znz_digits) w9_op.(znz_0) + w9_op.(znz_head0) w9_op.(znz_add_mul_div) w9_op.(znz_div21). + Definition w10_modn1 := + gen_modn1 w10_op.(znz_digits) w10_op.(znz_0) + w10_op.(znz_head0) w10_op.(znz_add_mul_div) w10_op.(znz_div21). + Definition w11_modn1 := + gen_modn1 w11_op.(znz_digits) w11_op.(znz_0) + w11_op.(znz_head0) w11_op.(znz_add_mul_div) w11_op.(znz_div21). + Definition w12_modn1 := + gen_modn1 w12_op.(znz_digits) w12_op.(znz_0) + w12_op.(znz_head0) w12_op.(znz_add_mul_div) w12_op.(znz_div21). + + Definition mod_gt x y := + match x, y with + | N0 wx, N0 wy => reduce_0 (w0_mod_gt wx wy) + | N0 wx, N1 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 0 wx in + reduce_1 (w1_mod_gt wx' wy) + | N0 wx, N2 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 1 wx in + reduce_2 (w2_mod_gt wx' wy) + | N0 wx, N3 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 2 wx in + reduce_3 (w3_mod_gt wx' wy) + | N0 wx, N4 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 3 wx in + reduce_4 (w4_mod_gt wx' wy) + | N0 wx, N5 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 4 wx in + reduce_5 (w5_mod_gt wx' wy) + | N0 wx, N6 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 5 wx in + reduce_6 (w6_mod_gt wx' wy) + | N0 wx, N7 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 6 wx in + reduce_7 (w7_mod_gt wx' wy) + | N0 wx, N8 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 7 wx in + reduce_8 (w8_mod_gt wx' wy) + | N0 wx, N9 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 8 wx in + reduce_9 (w9_mod_gt wx' wy) + | N0 wx, N10 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 9 wx in + reduce_10 (w10_mod_gt wx' wy) + | N0 wx, N11 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 10 wx in + reduce_11 (w11_mod_gt wx' wy) + | N0 wx, N12 wy => + let wx':= GenBase.extend w0_op.(znz_0W) 11 wx in + reduce_12 (w12_mod_gt wx' wy) + | N0 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w0_op.(znz_0W) 12 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N1 wx, N0 wy => reduce_0 (w0_modn1 1 wx wy) + | N1 wx, N1 wy => reduce_1 (w1_mod_gt wx wy) + | N1 wx, N2 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 0 wx in + reduce_2 (w2_mod_gt wx' wy) + | N1 wx, N3 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 1 wx in + reduce_3 (w3_mod_gt wx' wy) + | N1 wx, N4 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 2 wx in + reduce_4 (w4_mod_gt wx' wy) + | N1 wx, N5 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 3 wx in + reduce_5 (w5_mod_gt wx' wy) + | N1 wx, N6 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 4 wx in + reduce_6 (w6_mod_gt wx' wy) + | N1 wx, N7 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 5 wx in + reduce_7 (w7_mod_gt wx' wy) + | N1 wx, N8 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 6 wx in + reduce_8 (w8_mod_gt wx' wy) + | N1 wx, N9 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 7 wx in + reduce_9 (w9_mod_gt wx' wy) + | N1 wx, N10 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 8 wx in + reduce_10 (w10_mod_gt wx' wy) + | N1 wx, N11 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 9 wx in + reduce_11 (w11_mod_gt wx' wy) + | N1 wx, N12 wy => + let wx':= GenBase.extend w1_op.(znz_0W) 10 wx in + reduce_12 (w12_mod_gt wx' wy) + | N1 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w1_op.(znz_0W) 11 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N2 wx, N0 wy => reduce_0 (w0_modn1 2 wx wy) + | N2 wx, N1 wy => reduce_1 (w1_modn1 1 wx wy) + | N2 wx, N2 wy => reduce_2 (w2_mod_gt wx wy) + | N2 wx, N3 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 0 wx in + reduce_3 (w3_mod_gt wx' wy) + | N2 wx, N4 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 1 wx in + reduce_4 (w4_mod_gt wx' wy) + | N2 wx, N5 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 2 wx in + reduce_5 (w5_mod_gt wx' wy) + | N2 wx, N6 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 3 wx in + reduce_6 (w6_mod_gt wx' wy) + | N2 wx, N7 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 4 wx in + reduce_7 (w7_mod_gt wx' wy) + | N2 wx, N8 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 5 wx in + reduce_8 (w8_mod_gt wx' wy) + | N2 wx, N9 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 6 wx in + reduce_9 (w9_mod_gt wx' wy) + | N2 wx, N10 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 7 wx in + reduce_10 (w10_mod_gt wx' wy) + | N2 wx, N11 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 8 wx in + reduce_11 (w11_mod_gt wx' wy) + | N2 wx, N12 wy => + let wx':= GenBase.extend w2_op.(znz_0W) 9 wx in + reduce_12 (w12_mod_gt wx' wy) + | N2 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w2_op.(znz_0W) 10 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N3 wx, N0 wy => reduce_0 (w0_modn1 3 wx wy) + | N3 wx, N1 wy => reduce_1 (w1_modn1 2 wx wy) + | N3 wx, N2 wy => reduce_2 (w2_modn1 1 wx wy) + | N3 wx, N3 wy => reduce_3 (w3_mod_gt wx wy) + | N3 wx, N4 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 0 wx in + reduce_4 (w4_mod_gt wx' wy) + | N3 wx, N5 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 1 wx in + reduce_5 (w5_mod_gt wx' wy) + | N3 wx, N6 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 2 wx in + reduce_6 (w6_mod_gt wx' wy) + | N3 wx, N7 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 3 wx in + reduce_7 (w7_mod_gt wx' wy) + | N3 wx, N8 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 4 wx in + reduce_8 (w8_mod_gt wx' wy) + | N3 wx, N9 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 5 wx in + reduce_9 (w9_mod_gt wx' wy) + | N3 wx, N10 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 6 wx in + reduce_10 (w10_mod_gt wx' wy) + | N3 wx, N11 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 7 wx in + reduce_11 (w11_mod_gt wx' wy) + | N3 wx, N12 wy => + let wx':= GenBase.extend w3_op.(znz_0W) 8 wx in + reduce_12 (w12_mod_gt wx' wy) + | N3 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w3_op.(znz_0W) 9 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N4 wx, N0 wy => reduce_0 (w0_modn1 4 wx wy) + | N4 wx, N1 wy => reduce_1 (w1_modn1 3 wx wy) + | N4 wx, N2 wy => reduce_2 (w2_modn1 2 wx wy) + | N4 wx, N3 wy => reduce_3 (w3_modn1 1 wx wy) + | N4 wx, N4 wy => reduce_4 (w4_mod_gt wx wy) + | N4 wx, N5 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 0 wx in + reduce_5 (w5_mod_gt wx' wy) + | N4 wx, N6 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 1 wx in + reduce_6 (w6_mod_gt wx' wy) + | N4 wx, N7 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 2 wx in + reduce_7 (w7_mod_gt wx' wy) + | N4 wx, N8 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 3 wx in + reduce_8 (w8_mod_gt wx' wy) + | N4 wx, N9 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 4 wx in + reduce_9 (w9_mod_gt wx' wy) + | N4 wx, N10 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 5 wx in + reduce_10 (w10_mod_gt wx' wy) + | N4 wx, N11 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 6 wx in + reduce_11 (w11_mod_gt wx' wy) + | N4 wx, N12 wy => + let wx':= GenBase.extend w4_op.(znz_0W) 7 wx in + reduce_12 (w12_mod_gt wx' wy) + | N4 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w4_op.(znz_0W) 8 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N5 wx, N0 wy => reduce_0 (w0_modn1 5 wx wy) + | N5 wx, N1 wy => reduce_1 (w1_modn1 4 wx wy) + | N5 wx, N2 wy => reduce_2 (w2_modn1 3 wx wy) + | N5 wx, N3 wy => reduce_3 (w3_modn1 2 wx wy) + | N5 wx, N4 wy => reduce_4 (w4_modn1 1 wx wy) + | N5 wx, N5 wy => reduce_5 (w5_mod_gt wx wy) + | N5 wx, N6 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 0 wx in + reduce_6 (w6_mod_gt wx' wy) + | N5 wx, N7 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 1 wx in + reduce_7 (w7_mod_gt wx' wy) + | N5 wx, N8 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 2 wx in + reduce_8 (w8_mod_gt wx' wy) + | N5 wx, N9 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 3 wx in + reduce_9 (w9_mod_gt wx' wy) + | N5 wx, N10 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 4 wx in + reduce_10 (w10_mod_gt wx' wy) + | N5 wx, N11 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 5 wx in + reduce_11 (w11_mod_gt wx' wy) + | N5 wx, N12 wy => + let wx':= GenBase.extend w5_op.(znz_0W) 6 wx in + reduce_12 (w12_mod_gt wx' wy) + | N5 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w5_op.(znz_0W) 7 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N6 wx, N0 wy => reduce_0 (w0_modn1 6 wx wy) + | N6 wx, N1 wy => reduce_1 (w1_modn1 5 wx wy) + | N6 wx, N2 wy => reduce_2 (w2_modn1 4 wx wy) + | N6 wx, N3 wy => reduce_3 (w3_modn1 3 wx wy) + | N6 wx, N4 wy => reduce_4 (w4_modn1 2 wx wy) + | N6 wx, N5 wy => reduce_5 (w5_modn1 1 wx wy) + | N6 wx, N6 wy => reduce_6 (w6_mod_gt wx wy) + | N6 wx, N7 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 0 wx in + reduce_7 (w7_mod_gt wx' wy) + | N6 wx, N8 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 1 wx in + reduce_8 (w8_mod_gt wx' wy) + | N6 wx, N9 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 2 wx in + reduce_9 (w9_mod_gt wx' wy) + | N6 wx, N10 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 3 wx in + reduce_10 (w10_mod_gt wx' wy) + | N6 wx, N11 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 4 wx in + reduce_11 (w11_mod_gt wx' wy) + | N6 wx, N12 wy => + let wx':= GenBase.extend w6_op.(znz_0W) 5 wx in + reduce_12 (w12_mod_gt wx' wy) + | N6 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w6_op.(znz_0W) 6 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N7 wx, N0 wy => reduce_0 (w0_modn1 7 wx wy) + | N7 wx, N1 wy => reduce_1 (w1_modn1 6 wx wy) + | N7 wx, N2 wy => reduce_2 (w2_modn1 5 wx wy) + | N7 wx, N3 wy => reduce_3 (w3_modn1 4 wx wy) + | N7 wx, N4 wy => reduce_4 (w4_modn1 3 wx wy) + | N7 wx, N5 wy => reduce_5 (w5_modn1 2 wx wy) + | N7 wx, N6 wy => reduce_6 (w6_modn1 1 wx wy) + | N7 wx, N7 wy => reduce_7 (w7_mod_gt wx wy) + | N7 wx, N8 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 0 wx in + reduce_8 (w8_mod_gt wx' wy) + | N7 wx, N9 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 1 wx in + reduce_9 (w9_mod_gt wx' wy) + | N7 wx, N10 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 2 wx in + reduce_10 (w10_mod_gt wx' wy) + | N7 wx, N11 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 3 wx in + reduce_11 (w11_mod_gt wx' wy) + | N7 wx, N12 wy => + let wx':= GenBase.extend w7_op.(znz_0W) 4 wx in + reduce_12 (w12_mod_gt wx' wy) + | N7 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w7_op.(znz_0W) 5 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N8 wx, N0 wy => reduce_0 (w0_modn1 8 wx wy) + | N8 wx, N1 wy => reduce_1 (w1_modn1 7 wx wy) + | N8 wx, N2 wy => reduce_2 (w2_modn1 6 wx wy) + | N8 wx, N3 wy => reduce_3 (w3_modn1 5 wx wy) + | N8 wx, N4 wy => reduce_4 (w4_modn1 4 wx wy) + | N8 wx, N5 wy => reduce_5 (w5_modn1 3 wx wy) + | N8 wx, N6 wy => reduce_6 (w6_modn1 2 wx wy) + | N8 wx, N7 wy => reduce_7 (w7_modn1 1 wx wy) + | N8 wx, N8 wy => reduce_8 (w8_mod_gt wx wy) + | N8 wx, N9 wy => + let wx':= GenBase.extend w8_op.(znz_0W) 0 wx in + reduce_9 (w9_mod_gt wx' wy) + | N8 wx, N10 wy => + let wx':= GenBase.extend w8_op.(znz_0W) 1 wx in + reduce_10 (w10_mod_gt wx' wy) + | N8 wx, N11 wy => + let wx':= GenBase.extend w8_op.(znz_0W) 2 wx in + reduce_11 (w11_mod_gt wx' wy) + | N8 wx, N12 wy => + let wx':= GenBase.extend w8_op.(znz_0W) 3 wx in + reduce_12 (w12_mod_gt wx' wy) + | N8 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w8_op.(znz_0W) 4 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N9 wx, N0 wy => reduce_0 (w0_modn1 9 wx wy) + | N9 wx, N1 wy => reduce_1 (w1_modn1 8 wx wy) + | N9 wx, N2 wy => reduce_2 (w2_modn1 7 wx wy) + | N9 wx, N3 wy => reduce_3 (w3_modn1 6 wx wy) + | N9 wx, N4 wy => reduce_4 (w4_modn1 5 wx wy) + | N9 wx, N5 wy => reduce_5 (w5_modn1 4 wx wy) + | N9 wx, N6 wy => reduce_6 (w6_modn1 3 wx wy) + | N9 wx, N7 wy => reduce_7 (w7_modn1 2 wx wy) + | N9 wx, N8 wy => reduce_8 (w8_modn1 1 wx wy) + | N9 wx, N9 wy => reduce_9 (w9_mod_gt wx wy) + | N9 wx, N10 wy => + let wx':= GenBase.extend w9_op.(znz_0W) 0 wx in + reduce_10 (w10_mod_gt wx' wy) + | N9 wx, N11 wy => + let wx':= GenBase.extend w9_op.(znz_0W) 1 wx in + reduce_11 (w11_mod_gt wx' wy) + | N9 wx, N12 wy => + let wx':= GenBase.extend w9_op.(znz_0W) 2 wx in + reduce_12 (w12_mod_gt wx' wy) + | N9 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w9_op.(znz_0W) 3 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N10 wx, N0 wy => reduce_0 (w0_modn1 10 wx wy) + | N10 wx, N1 wy => reduce_1 (w1_modn1 9 wx wy) + | N10 wx, N2 wy => reduce_2 (w2_modn1 8 wx wy) + | N10 wx, N3 wy => reduce_3 (w3_modn1 7 wx wy) + | N10 wx, N4 wy => reduce_4 (w4_modn1 6 wx wy) + | N10 wx, N5 wy => reduce_5 (w5_modn1 5 wx wy) + | N10 wx, N6 wy => reduce_6 (w6_modn1 4 wx wy) + | N10 wx, N7 wy => reduce_7 (w7_modn1 3 wx wy) + | N10 wx, N8 wy => reduce_8 (w8_modn1 2 wx wy) + | N10 wx, N9 wy => reduce_9 (w9_modn1 1 wx wy) + | N10 wx, N10 wy => reduce_10 (w10_mod_gt wx wy) + | N10 wx, N11 wy => + let wx':= GenBase.extend w10_op.(znz_0W) 0 wx in + reduce_11 (w11_mod_gt wx' wy) + | N10 wx, N12 wy => + let wx':= GenBase.extend w10_op.(znz_0W) 1 wx in + reduce_12 (w12_mod_gt wx' wy) + | N10 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w10_op.(znz_0W) 2 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N11 wx, N0 wy => reduce_0 (w0_modn1 11 wx wy) + | N11 wx, N1 wy => reduce_1 (w1_modn1 10 wx wy) + | N11 wx, N2 wy => reduce_2 (w2_modn1 9 wx wy) + | N11 wx, N3 wy => reduce_3 (w3_modn1 8 wx wy) + | N11 wx, N4 wy => reduce_4 (w4_modn1 7 wx wy) + | N11 wx, N5 wy => reduce_5 (w5_modn1 6 wx wy) + | N11 wx, N6 wy => reduce_6 (w6_modn1 5 wx wy) + | N11 wx, N7 wy => reduce_7 (w7_modn1 4 wx wy) + | N11 wx, N8 wy => reduce_8 (w8_modn1 3 wx wy) + | N11 wx, N9 wy => reduce_9 (w9_modn1 2 wx wy) + | N11 wx, N10 wy => reduce_10 (w10_modn1 1 wx wy) + | N11 wx, N11 wy => reduce_11 (w11_mod_gt wx wy) + | N11 wx, N12 wy => + let wx':= GenBase.extend w11_op.(znz_0W) 0 wx in + reduce_12 (w12_mod_gt wx' wy) + | N11 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w11_op.(znz_0W) 1 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | N12 wx, N0 wy => reduce_0 (w0_modn1 12 wx wy) + | N12 wx, N1 wy => reduce_1 (w1_modn1 11 wx wy) + | N12 wx, N2 wy => reduce_2 (w2_modn1 10 wx wy) + | N12 wx, N3 wy => reduce_3 (w3_modn1 9 wx wy) + | N12 wx, N4 wy => reduce_4 (w4_modn1 8 wx wy) + | N12 wx, N5 wy => reduce_5 (w5_modn1 7 wx wy) + | N12 wx, N6 wy => reduce_6 (w6_modn1 6 wx wy) + | N12 wx, N7 wy => reduce_7 (w7_modn1 5 wx wy) + | N12 wx, N8 wy => reduce_8 (w8_modn1 4 wx wy) + | N12 wx, N9 wy => reduce_9 (w9_modn1 3 wx wy) + | N12 wx, N10 wy => reduce_10 (w10_modn1 2 wx wy) + | N12 wx, N11 wy => reduce_11 (w11_modn1 1 wx wy) + | N12 wx, N12 wy => reduce_12 (w12_mod_gt wx wy) + | N12 wx, Nn n wy => + let wx':= extend n w12 (GenBase.extend w12_op.(znz_0W) 0 wx) in + reduce_n n ((make_op n).(znz_mod_gt) wx' wy) + | Nn n wx, N0 wy => + let wy':= GenBase.extend w0_op.(znz_0W) 11 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N1 wy => + let wy':= GenBase.extend w1_op.(znz_0W) 10 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N2 wy => + let wy':= GenBase.extend w2_op.(znz_0W) 9 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N3 wy => + let wy':= GenBase.extend w3_op.(znz_0W) 8 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N4 wy => + let wy':= GenBase.extend w4_op.(znz_0W) 7 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N5 wy => + let wy':= GenBase.extend w5_op.(znz_0W) 6 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N6 wy => + let wy':= GenBase.extend w6_op.(znz_0W) 5 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N7 wy => + let wy':= GenBase.extend w7_op.(znz_0W) 4 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N8 wy => + let wy':= GenBase.extend w8_op.(znz_0W) 3 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N9 wy => + let wy':= GenBase.extend w9_op.(znz_0W) 2 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N10 wy => + let wy':= GenBase.extend w10_op.(znz_0W) 1 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N11 wy => + let wy':= GenBase.extend w11_op.(znz_0W) 0 wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, N12 wy => + let wy':= wy in + reduce_12 (w12_modn1 (S n) wx wy') + | Nn n wx, Nn m wy => + match extend_to_max w12 n m wx wy with + | inl wx' => + reduce_n m ((make_op m).(znz_mod_gt) wx' wy) + | inr wy' => + reduce_n n ((make_op n).(znz_mod_gt) wx wy') + end + end. + + Definition modulo x y := + match compare x y with + | Eq => zero + | Lt => x + | Gt => mod_gt x y + end. + + Definition digits x := + match x with + | N0 _ => w0_op.(znz_digits) + | N1 _ => w1_op.(znz_digits) + | N2 _ => w2_op.(znz_digits) + | N3 _ => w3_op.(znz_digits) + | N4 _ => w4_op.(znz_digits) + | N5 _ => w5_op.(znz_digits) + | N6 _ => w6_op.(znz_digits) + | N7 _ => w7_op.(znz_digits) + | N8 _ => w8_op.(znz_digits) + | N9 _ => w9_op.(znz_digits) + | N10 _ => w10_op.(znz_digits) + | N11 _ => w11_op.(znz_digits) + | N12 _ => w12_op.(znz_digits) + | Nn n _ => (make_op n).(znz_digits) + end. + + Definition gcd_gt_body a b cont := + match compare b zero with + | Gt => + let r := mod_gt a b in + match compare r zero with + | Gt => cont r (mod_gt b r) + | _ => b + end + | _ => a + end. + + Fixpoint gcd_gt (p:positive) (cont:t->t->t) (a b:t) {struct p} : t := + gcd_gt_body a b + (fun a b => + match p with + | xH => cont a b + | xO p => gcd_gt p (gcd_gt p cont) a b + | xI p => gcd_gt p (gcd_gt p cont) a b + end). + + Definition gcd_cont a b := + match compare one b with + | Eq => one + | _ => a + end. + + Definition gcd a b := + match compare a b with + | Eq => a + | Lt => gcd_gt (digits b) gcd_cont b a + | Gt => gcd_gt (digits a) gcd_cont a b + end. + + Definition of_pos x := + let h := nat_of_P (pheight x) in + match h with + | O => reduce_0 (snd (w0_op.(znz_of_pos) x)) + | (S O) => reduce_1 (snd (w1_op.(znz_of_pos) x)) + | (S (S O)) => reduce_2 (snd (w2_op.(znz_of_pos) x)) + | (S (S (S O))) => reduce_3 (snd (w3_op.(znz_of_pos) x)) + | (S (S (S (S O)))) => reduce_4 (snd (w4_op.(znz_of_pos) x)) + | (S (S (S (S (S O))))) => reduce_5 (snd (w5_op.(znz_of_pos) x)) + | (S (S (S (S (S (S O)))))) => reduce_6 (snd (w6_op.(znz_of_pos) x)) + | (S (S (S (S (S (S (S O))))))) => reduce_7 (snd (w7_op.(znz_of_pos) x)) + | (S (S (S (S (S (S (S (S O)))))))) => reduce_8 (snd (w8_op.(znz_of_pos) x)) + | (S (S (S (S (S (S (S (S (S O))))))))) => reduce_9 (snd (w9_op.(znz_of_pos) x)) + | (S (S (S (S (S (S (S (S (S (S O)))))))))) => reduce_10 (snd (w10_op.(znz_of_pos) x)) + | (S (S (S (S (S (S (S (S (S (S (S O))))))))))) => reduce_11 (snd (w11_op.(znz_of_pos) x)) + | (S (S (S (S (S (S (S (S (S (S (S (S O)))))))))))) => reduce_12 (snd (w12_op.(znz_of_pos) x)) + | _ => + let n := minus h 13 in + reduce_n n (snd ((make_op n).(znz_of_pos) x)) + end. + + Definition of_N x := + match x with + | BinNat.N0 => zero + | Npos p => of_pos p + end. + + Definition to_Z x := + match x with + | N0 wx => w0_op.(znz_to_Z) wx + | N1 wx => w1_op.(znz_to_Z) wx + | N2 wx => w2_op.(znz_to_Z) wx + | N3 wx => w3_op.(znz_to_Z) wx + | N4 wx => w4_op.(znz_to_Z) wx + | N5 wx => w5_op.(znz_to_Z) wx + | N6 wx => w6_op.(znz_to_Z) wx + | N7 wx => w7_op.(znz_to_Z) wx + | N8 wx => w8_op.(znz_to_Z) wx + | N9 wx => w9_op.(znz_to_Z) wx + | N10 wx => w10_op.(znz_to_Z) wx + | N11 wx => w11_op.(znz_to_Z) wx + | N12 wx => w12_op.(znz_to_Z) wx + | Nn n wx => (make_op n).(znz_to_Z) wx + end. + +End Make. + diff --git a/theories/Ints/num/Nbasic.v b/theories/Ints/num/Nbasic.v new file mode 100644 index 000000000..23229b52c --- /dev/null +++ b/theories/Ints/num/Nbasic.v @@ -0,0 +1,147 @@ +Require Import ZArith. +Require Import Basic_type. + + +Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n. + fix zn2z_word_comm 2. + intros w n; case n. + reflexivity. + intros n0;simpl. + case (zn2z_word_comm w n0). + reflexivity. +Defined. + +Fixpoint extend (n:nat) {struct n} : forall w:Set, zn2z w -> word w (S n) := + match n return forall w:Set, zn2z w -> word w (S n) with + | O => fun w x => x + | S m => + let aux := extend m in + fun w x => WW W0 (aux w x) + end. + +Section ExtendMax. + + Variable w:Set. + + Definition Tmax n m := + ( {p:nat| word (word w n) p = word w m} + + {p:nat| word (word w m) p = word w n})%type. + + Definition max : forall n m, Tmax n m. + fix max 1;intros n. + case n. + intros m;left;exists m;exact (refl_equal (word w m)). + intros n0 m;case m. + right;exists (S n0);exact (refl_equal (word w (S n0))). + intros m0;case (max n0 m0);intros H;case H;intros p Heq. + left;exists p;simpl. + case (zn2z_word_comm (word w n0) p). + case Heq. + exact (refl_equal (zn2z (word (word w n0) p))). + right;exists p;simpl. + case (zn2z_word_comm (word w m0) p). + case Heq. + exact (refl_equal (zn2z (word (word w m0) p))). + Defined. + + Definition extend_to_max : + forall n m (x:zn2z (word w n)) (y:zn2z (word w m)), + (zn2z (word w m) + zn2z (word w n))%type. + intros n m x y. + case (max n m);intros (p, Heq);case Heq. + left;exact (extend p (word w n) x). + right;exact (extend p (word w m) y). + Defined. + +End ExtendMax. + +Section Reduce. + + Variable w : Set. + Variable nT : Set. + Variable N0 : nT. + Variable eq0 : w -> bool. + Variable reduce_n : w -> nT. + Variable zn2z_to_Nt : zn2z w -> nT. + + Definition reduce_n1 (x:zn2z w) := + match x with + | W0 => N0 + | WW xh xl => + if eq0 xh then reduce_n xl + else zn2z_to_Nt x + end. + +End Reduce. + +Section ReduceRec. + + Variable w : Set. + Variable nT : Set. + Variable N0 : nT. + Variable reduce_1n : zn2z w -> nT. + Variable c : forall n, word w (S n) -> nT. + + Fixpoint reduce_n (n:nat) : word w (S n) -> nT := + match n return word w (S n) -> nT with + | O => reduce_1n + | S m => fun x => + match x with + | W0 => N0 + | WW xh xl => + match xh with + | W0 => @reduce_n m xl + | _ => @c (S m) x + end + end + end. + +End ReduceRec. + +Definition opp_compare cmp := + match cmp with + | Lt => Gt + | Eq => Eq + | Gt => Lt + end. + +Section CompareRec. + + Variable wm w : Set. + Variable w_0 : w. + Variable compare : w -> w -> comparison. + Variable compare0_m : wm -> comparison. + Variable compare_m : wm -> w -> comparison. + + Fixpoint compare0_mn (n:nat) : word wm n -> comparison := + match n return word wm n -> comparison with + | 0 => compare0_m + | S m => fun x => + match x with + | W0 => Eq + | WW xh xl => + match compare0_mn m xh with + | Eq => compare0_mn m xl + | r => Lt + end + end + end. + + Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison := + match n return word wm n -> w -> comparison with + | 0 => compare_m + | S m => fun x y => + match x with + | W0 => compare w_0 y + | WW xh xl => + match compare0_mn m xh with + | Eq => compare_mn_1 m xl y + | r => Gt + end + end + end. + +End CompareRec. + + + diff --git a/theories/Ints/num/QMake.v b/theories/Ints/num/QMake.v new file mode 100644 index 000000000..28f4bd991 --- /dev/null +++ b/theories/Ints/num/QMake.v @@ -0,0 +1,899 @@ +Require Import Bool. +Require Import ZArith. +Require Import Arith. + +Inductive q_type : Set := + | Qz : Z.t -> q_type + | Qq : Z.t -> N.t -> q_type. + +Definition print_type x := + match x with + | Qz _ => Z + | _ => (Z*Z)%type + end. + +Definition print x := + match x return print_type x with + | Qz zx => Z.to_Z zx + | Qq nx dx => (Z.to_Z nx, N.to_Z dx) + end. + +Module Qp. + + Definition t := q_type. + + Definition zero := Qz Z.zero. + Definition one := Qz Z.one. + Definition minus_one := Qz Z.minus_one. + + Definition of_Z x := Qz (Z.of_Z x). + + Definition d_to_Z d := Z.Pos (N.succ d). + + Definition compare x y := + match x, y with + | Qz zx, Qz zy => Z.compare zx zy + | Qz zx, Qq ny dy => Z.compare (Z.mul zx (d_to_Z dy)) ny + | Qq nx dy, Qz zy => Z.compare nx (Z.mul zy (d_to_Z dy)) + | Qq nx dx, Qq ny dy => + Z.compare (Z.mul nx (d_to_Z dy)) (Z.mul ny (d_to_Z dx)) + end. + + Definition opp x := + match x with + | Qz zx => Qz (Z.opp zx) + | Qq nx dx => Qq (Z.opp nx) dx + end. + +(* Inv d > 0, Pour la forme normal unique on veut d > 1 *) + Definition norm n d := + if Z.eq_bool n Z.zero then zero + else + let gcd := N.gcd (Z.to_N n) d in + if N.eq_bool gcd N.one then Qq n (N.pred d) + else + let n := Z.div n (Z.Pos gcd) in + let d := N.div d gcd in + if N.eq_bool d N.one then Qz n + else Qq n (N.pred d). + + Definition add x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.add zx zy) + | Qz zx, Qq ny dy => Qq (Z.add (Z.mul zx (d_to_Z dy)) ny) dy + | Qq nx dx, Qz zy => Qq (Z.add nx (Z.mul zy (d_to_Z dx))) dx + | Qq nx dx, Qq ny dy => + let dx' := N.succ dx in + let dy' := N.succ dy in + let n := Z.add (Z.mul nx (Z.Pos dy')) (Z.mul ny (Z.Pos dx')) in + let d := N.pred (N.mul dx' dy') in + Qq n d + end. + + Definition add_norm x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.add zx zy) + | Qz zx, Qq ny dy => + let d := N.succ dy in + norm (Z.add (Z.mul zx (Z.Pos d)) ny) d + | Qq nx dx, Qz zy => + let d := N.succ dx in + norm (Z.add (Z.mul zy (Z.Pos d)) nx) d + | Qq nx dx, Qq ny dy => + let dx' := N.succ dx in + let dy' := N.succ dy in + let n := Z.add (Z.mul nx (Z.Pos dy')) (Z.mul ny (Z.Pos dx')) in + let d := N.mul dx' dy' in + norm n d + end. + + Definition sub x y := add x (opp y). + + Definition sub_norm x y := add_norm x (opp y). + + Definition mul x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => Qq (Z.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (Z.mul nx zy) dx + | Qq nx dx, Qq ny dy => + Qq (Z.mul nx ny) (N.pred (N.mul (N.succ dx) (N.succ dy))) + end. + + Definition mul_norm x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => + if Z.eq_bool zx Z.zero then zero + else + let d := N.succ dy in + let gcd := N.gcd (Z.to_N zx) d in + if N.eq_bool gcd N.one then Qq (Z.mul zx ny) dy + else + let zx := Z.div zx (Z.Pos gcd) in + let d := N.div d gcd in + if N.eq_bool d N.one then Qz (Z.mul zx ny) + else Qq (Z.mul zx ny) (N.pred d) + | Qq nx dx, Qz zy => + if Z.eq_bool zy Z.zero then zero + else + let d := N.succ dx in + let gcd := N.gcd (Z.to_N zy) d in + if N.eq_bool gcd N.one then Qq (Z.mul zy nx) dx + else + let zy := Z.div zy (Z.Pos gcd) in + let d := N.div d gcd in + if N.eq_bool d N.one then Qz (Z.mul zy nx) + else Qq (Z.mul zy nx) (N.pred d) + | Qq nx dx, Qq ny dy => + norm (Z.mul nx ny) (N.mul (N.succ dx) (N.succ dy)) + end. + + Definition inv x := + match x with + | Qz (Z.Pos n) => + if N.eq_bool n N.zero then zero else Qq Z.one (N.pred n) + | Qz (Z.Neg n) => + if N.eq_bool n N.zero then zero else Qq Z.minus_one (N.pred n) + | Qq (Z.Pos n) d => + if N.eq_bool n N.zero then zero else Qq (Z.Pos (N.succ d)) (N.pred n) + | Qq (Z.Neg n) d => + if N.eq_bool n N.zero then zero else Qq (Z.Neg (N.succ d)) (N.pred n) + end. + +Definition inv_norm x := + match x with + | Qz (Z.Pos n) => + if N.eq_bool n N.zero then zero else + if N.eq_bool n N.one then x else Qq Z.one (N.pred n) + | Qz (Z.Neg n) => + if N.eq_bool n N.zero then zero else + if N.eq_bool n N.one then x else Qq Z.minus_one n + | Qq (Z.Pos n) d => let d := N.succ d in + if N.eq_bool n N.one then Qz (Z.Pos d) + else Qq (Z.Pos d) (N.pred n) + | Qq (Z.Neg n) d => let d := N.succ d in + if N.eq_bool n N.one then Qz (Z.Neg d) + else Qq (Z.Pos d) (N.pred n) + end. + + + Definition square x := + match x with + | Qz zx => Qz (Z.square zx) + | Qq nx dx => Qq (Z.square nx) (N.pred (N.square (N.succ dx))) + end. + + Definition power_pos x p := + match x with + | Qz zx => Qz (Z.power_pos zx p) + | Qq nx dx => Qq (Z.power_pos nx p) (N.pred (N.power_pos (N.succ dx) p)) + end. + +End Qp. + + +Module Qv. + + (* /!\ Invariant maintenu par les fonctions : + - le denominateur n'est jamais nul *) + + Definition t := q_type. + + Definition zero := Qz Z.zero. + Definition one := Qz Z.one. + Definition minus_one := Qz Z.minus_one. + + Definition of_Z x := Qz (Z.of_Z x). + + Definition is_valid x := + match x with + | Qz _ => True + | Qq n d => if N.eq_bool d N.zero then False else True + end. + (* Les fonctions doivent assurer que si leur arguments sont valides alors + le resultat est correct et valide (si c'est un Q) + *) + + Definition compare x y := + match x, y with + | Qz zx, Qz zy => Z.compare zx zy + | Qz zx, Qq ny dy => Z.compare (Z.mul zx (Z.Pos dy)) ny + | Qq nx dx, Qz zy => Z.compare Z.zero zy + | Qq nx dx, Qq ny dy => Z.compare (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) + end. + + Definition opp x := + match x with + | Qz zx => Qz (Z.opp zx) + | Qq nx dx => Qq (Z.opp nx) dx + end. + + Definition norm n d := + if Z.eq_bool n Z.zero then zero + else + let gcd := N.gcd (Z.to_N n) d in + if N.eq_bool gcd N.one then Qq n d + else + let n := Z.div n (Z.Pos gcd) in + let d := N.div d gcd in + if N.eq_bool d N.one then Qz n + else Qq n d. + + Definition add x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.add zx zy) + | Qz zx, Qq ny dy => Qq (Z.add (Z.mul zx (Z.Pos dy)) ny) dy + | Qq nx dx, Qz zy => Qq (Z.add nx (Z.mul zy (Z.Pos dx))) dx + | Qq nx dx, Qq ny dy => + let n := Z.add (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) in + let d := N.mul dx dy in + Qq n d + end. + + Definition add_norm x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.add zx zy) + | Qz zx, Qq ny dy => + norm (Z.add (Z.mul zx (Z.Pos dy)) ny) dy + | Qq nx dx, Qz zy => + norm (Z.add (Z.mul zy (Z.Pos dx)) nx) dx + | Qq nx dx, Qq ny dy => + let n := Z.add (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) in + let d := N.mul dx dy in + norm n d + end. + + Definition sub x y := add x (opp y). + + Definition sub_norm x y := add_norm x (opp y). + + Definition mul x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => Qq (Z.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (Z.mul nx zy) dx + | Qq nx dx, Qq ny dy => + Qq (Z.mul nx ny) (N.mul dx dy) + end. + + Definition mul_norm x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => + if Z.eq_bool zx Z.zero then zero + else + let gcd := N.gcd (Z.to_N zx) dy in + if N.eq_bool gcd N.one then Qq (Z.mul zx ny) dy + else + let zx := Z.div zx (Z.Pos gcd) in + let d := N.div dy gcd in + if N.eq_bool d N.one then Qz (Z.mul zx ny) + else Qq (Z.mul zx ny) d + | Qq nx dx, Qz zy => + if Z.eq_bool zy Z.zero then zero + else + let gcd := N.gcd (Z.to_N zy) dx in + if N.eq_bool gcd N.one then Qq (Z.mul zy nx) dx + else + let zy := Z.div zy (Z.Pos gcd) in + let d := N.div dx gcd in + if N.eq_bool d N.one then Qz (Z.mul zy nx) + else Qq (Z.mul zy nx) d + | Qq nx dx, Qq ny dy => norm (Z.mul nx ny) (N.mul dx dy) + end. + + Definition inv x := + match x with + | Qz (Z.Pos n) => + if N.eq_bool n N.zero then zero else Qq Z.one n + | Qz (Z.Neg n) => + if N.eq_bool n N.zero then zero else Qq Z.minus_one n + | Qq (Z.Pos n) d => + if N.eq_bool n N.zero then zero else Qq (Z.Pos d) n + | Qq (Z.Neg n) d => + if N.eq_bool n N.zero then zero else Qq (Z.Neg d) n + end. + + Definition square x := + match x with + | Qz zx => Qz (Z.square zx) + | Qq nx dx => Qq (Z.square nx) (N.square dx) + end. + + Definition power_pos x p := + match x with + | Qz zx => Qz (Z.power_pos zx p) + | Qq nx dx => Qq (Z.power_pos nx p) (N.power_pos dx p) + end. + +End Qv. + +Module Q. + + (* Troisieme solution : + 0 a de nombreuse representation : + 0, -0, 1/0, ... n/0, + il faut alors faire attention avec la comparaison et l'addition + *) + + Definition t := q_type. + + Definition zero := Qz Z.zero. + Definition one := Qz Z.one. + Definition minus_one := Qz Z.minus_one. + + Definition of_Z x := Qz (Z.of_Z x). + + Definition compare x y := + match x, y with + | Qz zx, Qz zy => Z.compare zx zy + | Qz zx, Qq ny dy => + if N.eq_bool dy N.zero then Z.compare zx Z.zero + else Z.compare (Z.mul zx (Z.Pos dy)) ny + | Qq nx dx, Qz zy => + if N.eq_bool dx N.zero then Z.compare Z.zero zy + else Z.compare nx (Z.mul zy (Z.Pos dx)) + | Qq nx dx, Qq ny dy => + match N.eq_bool dx N.zero, N.eq_bool dy N.zero with + | true, true => Eq + | true, false => Z.compare Z.zero ny + | false, true => Z.compare nx Z.zero + | false, false => Z.compare (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) + end + end. + + Definition opp x := + match x with + | Qz zx => Qz (Z.opp zx) + | Qq nx dx => Qq (Z.opp nx) dx + end. + +(* Je pense que cette fonction normalise bien ... *) + Definition norm n d := + let gcd := N.gcd (Z.to_N n) d in + match N.compare N.one gcd with + | Lt => + let n := Z.div n (Z.Pos gcd) in + let d := N.div d gcd in + match N.compare d N.one with + | Gt => Qq n d + | Eq => Qz n + | Lt => zero + end + | Eq => Qq n d + | Gt => zero (* gcd = 0 => both numbers are 0 *) + end. + + Definition add x y := + match x with + | Qz zx => + match y with + | Qz zy => Qz (Z.add zx zy) + | Qq ny dy => + if N.eq_bool dy N.zero then x + else Qq (Z.add (Z.mul zx (Z.Pos dy)) ny) dy + end + | Qq nx dx => + if N.eq_bool dx N.zero then y + else match y with + | Qz zy => Qq (Z.add nx (Z.mul zy (Z.Pos dx))) dx + | Qq ny dy => + if N.eq_bool dy N.zero then x + else + let n := Z.add (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) in + let d := N.mul dx dy in + Qq n d + end + end. + + Definition add_norm x y := + match x with + | Qz zx => + match y with + | Qz zy => Qz (Z.add zx zy) + | Qq ny dy => + if N.eq_bool dy N.zero then x + else norm (Z.add (Z.mul zx (Z.Pos dy)) ny) dy + end + | Qq nx dx => + if N.eq_bool dx N.zero then y + else match y with + | Qz zy => norm (Z.add nx (Z.mul zy (Z.Pos dx))) dx + | Qq ny dy => + if N.eq_bool dy N.zero then x + else + let n := Z.add (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) in + let d := N.mul dx dy in + norm n d + end + end. + + Definition sub x y := add x (opp y). + + Definition sub_norm x y := add_norm x (opp y). + + Definition mul x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => Qq (Z.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (Z.mul nx zy) dx + | Qq nx dx, Qq ny dy => Qq (Z.mul nx ny) (N.mul dx dy) + end. + +Definition mul_norm x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => + if Z.eq_bool zx Z.zero then zero + else + let d := N.succ dy in + let gcd := N.gcd (Z.to_N zx) d in + if N.eq_bool gcd N.one then Qq (Z.mul zx ny) dy + else + let zx := Z.div zx (Z.Pos gcd) in + let d := N.div d gcd in + if N.eq_bool d N.one then Qz (Z.mul zx ny) + else Qq (Z.mul zx ny) (N.pred d) + | Qq nx dx, Qz zy => + if Z.eq_bool zy Z.zero then zero + else + let d := N.succ dx in + let gcd := N.gcd (Z.to_N zy) d in + if N.eq_bool gcd N.one then Qq (Z.mul zy nx) dx + else + let zy := Z.div zy (Z.Pos gcd) in + let d := N.div d gcd in + if N.eq_bool d N.one then Qz (Z.mul zy nx) + else Qq (Z.mul zy nx) (N.pred d) + | Qq nx dx, Qq ny dy => + let dx := N.succ dx in + let dy := N.succ dy in + let (nx, dy) := + let gcd := N.gcd (Z.to_N nx) dy in + if N.eq_bool gcd N.one then (nx, dy) + else (Z.div nx (Z.Pos gcd), N.div dy gcd) in + let (ny, dx) := + let gcd := N.gcd (Z.to_N ny) dx in + if N.eq_bool gcd N.one then (ny, dx) + else (Z.div ny (Z.Pos gcd), N.div dx gcd) in + let d := (N.mul dx dy) in + if N.eq_bool d N.one then Qz (Z.mul ny nx) + else Qq (Z.mul ny nx) (N.pred d) + end. + + +Definition inv x := + match x with + | Qz (Z.Pos n) => Qq Z.one (N.pred n) + | Qz (Z.Neg n) => Qq Z.minus_one (N.pred n) + | Qq (Z.Pos n) d => Qq (Z.Pos (N.succ d)) (N.pred n) + | Qq (Z.Neg n) d => Qq (Z.Neg (N.succ d)) (N.pred n) + end. + + +Definition inv_norm x := + match x with + | Qz (Z.Pos n) => if N.eq_bool n N.one then x else Qq Z.one (N.pred n) + | Qz (Z.Neg n) => if N.eq_bool n N.one then x else Qq Z.minus_one n + | Qq (Z.Pos n) d => let d := N.succ d in + if N.eq_bool n N.one then Qz (Z.Pos d) + else Qq (Z.Pos d) (N.pred n) + | Qq (Z.Neg n) d => let d := N.succ d in + if N.eq_bool n N.one then Qz (Z.Neg d) + else Qq (Z.Pos d) (N.pred n) + end. + + Definition square x := + match x with + | Qz zx => Qz (Z.square zx) + | Qq nx dx => Qq (Z.square nx) (N.square dx) + end. + + Definition power_pos x p := + match x with + | Qz zx => Qz (Z.power_pos zx p) + | Qq nx dx => Qq (Z.power_pos nx p) (N.power_pos dx p) + end. + +End Q. + +Module Qif. + + (* Troisieme solution : + 0 a de nombreuse representation : + 0, -0, 1/0, ... n/0, + il faut alors faire attention avec la comparaison et l'addition + + Les fonctions de normalization s'effectue seulement si les + nombres sont grands. + *) + + Definition t := q_type. + + Definition zero := Qz Z.zero. + Definition one := Qz Z.one. + Definition minus_one := Qz Z.minus_one. + + Definition of_Z x := Qz (Z.of_Z x). + + Definition compare x y := + match x, y with + | Qz zx, Qz zy => Z.compare zx zy + | Qz zx, Qq ny dy => + if N.eq_bool dy N.zero then Z.compare zx Z.zero + else Z.compare (Z.mul zx (Z.Pos dy)) ny + | Qq nx dx, Qz zy => + if N.eq_bool dx N.zero then Z.compare Z.zero zy + else Z.compare nx (Z.mul zy (Z.Pos dx)) + | Qq nx dx, Qq ny dy => + match N.eq_bool dx N.zero, N.eq_bool dy N.zero with + | true, true => Eq + | true, false => Z.compare Z.zero ny + | false, true => Z.compare nx Z.zero + | false, false => Z.compare (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) + end + end. + + Definition opp x := + match x with + | Qz zx => Qz (Z.opp zx) + | Qq nx dx => Qq (Z.opp nx) dx + end. + + + Definition do_norm_n n := + match n with + | N.N0 _ => false + | N.N1 _ => false + | N.N2 _ => false + | N.N3 _ => false + | N.N4 _ => false + | N.N5 _ => false + | N.N6 _ => false + | N.N7 _ => false + | N.N8 _ => false + | N.N9 _ => true + | N.N10 _ => true + | N.N11 _ => true + | N.N12 _ => true + | N.Nn n _ => true + end. + + Definition do_norm_z z := + match z with + | Z.Pos n => do_norm_n n + | Z.Neg n => do_norm_n n + end. + +Require Import Bool. +(* Je pense que cette fonction normalise bien ... *) + Definition norm n d := + if andb (do_norm_z n) (do_norm_n d) then + let gcd := N.gcd (Z.to_N n) d in + match N.compare N.one gcd with + | Lt => + let n := Z.div n (Z.Pos gcd) in + let d := N.div d gcd in + match N.compare d N.one with + | Gt => Qq n d + | Eq => Qz n + | Lt => zero + end + | Eq => Qq n d + | Gt => zero (* gcd = 0 => both numbers are 0 *) + end + else Qq n d. + + + + Definition add x y := + match x with + | Qz zx => + match y with + | Qz zy => Qz (Z.add zx zy) + | Qq ny dy => + if N.eq_bool dy N.zero then x + else Qq (Z.add (Z.mul zx (Z.Pos dy)) ny) dy + end + | Qq nx dx => + if N.eq_bool dx N.zero then y + else match y with + | Qz zy => Qq (Z.add nx (Z.mul zy (Z.Pos dx))) dx + | Qq ny dy => + if N.eq_bool dy N.zero then x + else + let n := Z.add (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) in + let d := N.mul dx dy in + Qq n d + end + end. + + Definition add_norm x y := + match x with + | Qz zx => + match y with + | Qz zy => Qz (Z.add zx zy) + | Qq ny dy => + if N.eq_bool dy N.zero then x + else norm (Z.add (Z.mul zx (Z.Pos dy)) ny) dy + end + | Qq nx dx => + if N.eq_bool dx N.zero then y + else match y with + | Qz zy => norm (Z.add nx (Z.mul zy (Z.Pos dx))) dx + | Qq ny dy => + if N.eq_bool dy N.zero then x + else + let n := Z.add (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) in + let d := N.mul dx dy in + norm n d + end + end. + + Definition sub x y := add x (opp y). + + Definition sub_norm x y := add_norm x (opp y). + + Definition mul x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => Qq (Z.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (Z.mul nx zy) dx + | Qq nx dx, Qq ny dy => Qq (Z.mul nx ny) (N.mul dx dy) + end. + + Definition mul_norm x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => norm (Z.mul zx ny) dy + | Qq nx dx, Qz zy => norm (Z.mul nx zy) dx + | Qq nx dx, Qq ny dy => norm (Z.mul nx ny) (N.mul dx dy) + end. + + Definition inv x := + match x with + | Qz (Z.Pos n) => Qq Z.one n + | Qz (Z.Neg n) => Qq Z.minus_one n + | Qq (Z.Pos n) d => Qq (Z.Pos d) n + | Qq (Z.Neg n) d => Qq (Z.Neg d) n + end. + + Definition inv_norm x := + match x with + | Qz (Z.Pos n) => + if N.eq_bool n N.zero then zero else Qq Z.one n + | Qz (Z.Neg n) => + if N.eq_bool n N.zero then zero else Qq Z.minus_one n + | Qq (Z.Pos n) d => + if N.eq_bool n N.zero then zero else Qq (Z.Pos d) n + | Qq (Z.Neg n) d => + if N.eq_bool n N.zero then zero else Qq (Z.Neg d) n + end. + + Definition square x := + match x with + | Qz zx => Qz (Z.square zx) + | Qq nx dx => Qq (Z.square nx) (N.square dx) + end. + + Definition power_pos x p := + match x with + | Qz zx => Qz (Z.power_pos zx p) + | Qq nx dx => Qq (Z.power_pos nx p) (N.power_pos dx p) + end. + +End Qif. + +Module Qbi. + + (* Troisieme solution : + 0 a de nombreuse representation : + 0, -0, 1/0, ... n/0, + il faut alors faire attention avec la comparaison et l'addition + + Les fonctions de normalization s'effectue seulement si les + nombres sont grands. + *) + + Definition t := q_type. + + Definition zero := Qz Z.zero. + Definition one := Qz Z.one. + Definition minus_one := Qz Z.minus_one. + + Definition of_Z x := Qz (Z.of_Z x). + + Definition compare x y := + match x, y with + | Qz zx, Qz zy => Z.compare zx zy + | Qz zx, Qq ny dy => + if N.eq_bool dy N.zero then Z.compare zx Z.zero + else + match Z.cmp_sign zx ny with + | Lt => Lt + | Gt => Gt + | Eq => Z.compare (Z.mul zx (Z.Pos dy)) ny + end + | Qq nx dx, Qz zy => + if N.eq_bool dx N.zero then Z.compare Z.zero zy + else + match Z.cmp_sign nx zy with + | Lt => Lt + | Gt => Gt + | Eq => Z.compare nx (Z.mul zy (Z.Pos dx)) + end + | Qq nx dx, Qq ny dy => + match N.eq_bool dx N.zero, N.eq_bool dy N.zero with + | true, true => Eq + | true, false => Z.compare Z.zero ny + | false, true => Z.compare nx Z.zero + | false, false => + match Z.cmp_sign nx ny with + | Lt => Lt + | Gt => Gt + | Eq => Z.compare (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) + end + end + end. + + Definition opp x := + match x with + | Qz zx => Qz (Z.opp zx) + | Qq nx dx => Qq (Z.opp nx) dx + end. + + + Definition do_norm_n n := + match n with + | N.N0 _ => false + | N.N1 _ => false + | N.N2 _ => false + | N.N3 _ => false + | N.N4 _ => false + | N.N5 _ => false + | N.N6 _ => false + | N.N7 _ => false + | N.N8 _ => false + | N.N9 _ => true + | N.N10 _ => true + | N.N11 _ => true + | N.N12 _ => true + | N.Nn n _ => true + end. + + Definition do_norm_z z := + match z with + | Z.Pos n => do_norm_n n + | Z.Neg n => do_norm_n n + end. + +(* Je pense que cette fonction normalise bien ... *) + Definition norm n d := + if andb (do_norm_z n) (do_norm_n d) then + let gcd := N.gcd (Z.to_N n) d in + match N.compare N.one gcd with + | Lt => + let n := Z.div n (Z.Pos gcd) in + let d := N.div d gcd in + match N.compare d N.one with + | Gt => Qq n d + | Eq => Qz n + | Lt => zero + end + | Eq => Qq n d + | Gt => zero (* gcd = 0 => both numbers are 0 *) + end + else Qq n d. + + + Definition add x y := + match x with + | Qz zx => + match y with + | Qz zy => Qz (Z.add zx zy) + | Qq ny dy => + if N.eq_bool dy N.zero then x + else Qq (Z.add (Z.mul zx (Z.Pos dy)) ny) dy + end + | Qq nx dx => + if N.eq_bool dx N.zero then y + else match y with + | Qz zy => Qq (Z.add nx (Z.mul zy (Z.Pos dx))) dx + | Qq ny dy => + if N.eq_bool dy N.zero then x + else + if N.eq_bool dx dy then + let n := Z.add nx ny in + Qq n dx + else + let n := Z.add (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) in + let d := N.mul dx dy in + Qq n d + end + end. + + Definition add_norm x y := + match x with + | Qz zx => + match y with + | Qz zy => Qz (Z.add zx zy) + | Qq ny dy => + if N.eq_bool dy N.zero then x + else + norm (Z.add (Z.mul zx (Z.Pos dy)) ny) dy + end + | Qq nx dx => + if N.eq_bool dx N.zero then y + else match y with + | Qz zy => norm (Z.add nx (Z.mul zy (Z.Pos dx))) dx + | Qq ny dy => + if N.eq_bool dy N.zero then x + else + if N.eq_bool dx dy then + let n := Z.add nx ny in + norm n dx + else + let n := Z.add (Z.mul nx (Z.Pos dy)) (Z.mul ny (Z.Pos dx)) in + let d := N.mul dx dy in + norm n d + end + end. + + Definition sub x y := add x (opp y). + + Definition sub_norm x y := add_norm x (opp y). + + Definition mul x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => Qq (Z.mul zx ny) dy + | Qq nx dx, Qz zy => Qq (Z.mul nx zy) dx + | Qq nx dx, Qq ny dy => Qq (Z.mul nx ny) (N.mul dx dy) + end. + + Definition mul_norm x y := + match x, y with + | Qz zx, Qz zy => Qz (Z.mul zx zy) + | Qz zx, Qq ny dy => mul (Qz ny) (norm zx dy) + | Qq nx dx, Qz zy => mul (Qz nx) (norm zy dx) + | Qq nx dx, Qq ny dy => mul (norm nx dy) (norm ny dx) + end. + + Definition inv x := + match x with + | Qz (Z.Pos n) => Qq Z.one n + | Qz (Z.Neg n) => Qq Z.minus_one n + | Qq (Z.Pos n) d => Qq (Z.Pos d) n + | Qq (Z.Neg n) d => Qq (Z.Neg d) n + end. + + Definition inv_norm x := + match x with + | Qz (Z.Pos n) => + if N.eq_bool n N.zero then zero else Qq Z.one n + | Qz (Z.Neg n) => + if N.eq_bool n N.zero then zero else Qq Z.minus_one n + | Qq (Z.Pos n) d => + if N.eq_bool n N.zero then zero else Qq (Z.Pos d) n + | Qq (Z.Neg n) d => + if N.eq_bool n N.zero then zero else Qq (Z.Neg d) n + end. + + Definition square x := + match x with + | Qz zx => Qz (Z.square zx) + | Qq nx dx => Qq (Z.square nx) (N.square dx) + end. + + Definition power_pos x p := + match x with + | Qz zx => Qz (Z.power_pos zx p) + | Qq nx dx => Qq (Z.power_pos nx p) (N.power_pos dx p) + end. + +End Qbi. + + + + diff --git a/theories/Ints/num/ZMake.v b/theories/Ints/num/ZMake.v new file mode 100644 index 000000000..f79b5478b --- /dev/null +++ b/theories/Ints/num/ZMake.v @@ -0,0 +1,224 @@ +Require Import ZArith. + +Module Type NType. + + Parameter t : Set. + + Parameter zero : t. + Parameter one : t. + + Parameter of_N : N -> t. + Parameter to_Z : t -> Z. + + Parameter compare : t -> t -> comparison. + Parameter eq_bool : t -> t -> bool. + + Parameter succ : t -> t. + Parameter add : t -> t -> t. + Parameter pred : t -> t. + Parameter sub : t -> t -> t. + + Parameter mul : t -> t -> t. + Parameter square : t -> t. + Parameter power_pos : t -> positive -> t. + Parameter sqrt : t -> t. + + Parameter div_eucl : t -> t -> t * t. + Parameter div : t -> t -> t. + Parameter modulo : t -> t -> t. + Parameter gcd : t -> t -> t. + +End NType. + +Module Make (N:NType). + + Inductive t_ : Set := + | Pos : N.t -> t_ + | Neg : N.t -> t_. + + Definition t := t_. + + Definition zero := Pos N.zero. + Definition one := Pos N.one. + Definition minus_one := Neg N.one. + + Definition of_Z x := + match x with + | Zpos x => Pos (N.of_N (Npos x)) + | Z0 => zero + | Zneg x => Neg (N.of_N (Npos x)) + end. + + Definition to_Z x := + match x with + | Pos nx => N.to_Z nx + | Neg nx => Zopp (N.to_Z nx) + end. + + Definition compare x y := + match x, y with + | Pos nx, Pos ny => N.compare nx ny + | Pos nx, Neg ny => + match N.compare nx N.zero with + | Gt => Gt + | _ => N.compare ny N.zero + end + | Neg nx, Pos ny => + match N.compare N.zero nx with + | Lt => Lt + | _ => N.compare N.zero ny + end + | Neg nx, Neg ny => N.compare ny nx + end. + + Definition eq_bool x y := + match compare x y with + | Eq => true + | _ => false + end. + + Definition cmp_sign x y := + match x, y with + | Pos nx, Neg ny => + if N.eq_bool ny N.zero then Eq else Gt + | Neg nx, Pos ny => + if N.eq_bool nx N.zero then Eq else Lt + | _, _ => Eq + end. + + Definition to_N x := + match x with + | Pos nx => nx + | Neg nx => nx + end. + + Definition abs x := Pos (to_N x). + + Definition opp x := + match x with + | Pos nx => Neg nx + | Neg nx => Pos nx + end. + + Definition succ x := + match x with + | Pos n => Pos (N.succ n) + | Neg n => + match N.compare N.zero n with + | Lt => Neg (N.pred n) + | _ => one + end + end. + + Definition add x y := + match x, y with + | Pos nx, Pos ny => Pos (N.add nx ny) + | Pos nx, Neg ny => + match N.compare nx ny with + | Gt => Pos (N.sub nx ny) + | Eq => zero + | Lt => Neg (N.sub ny nx) + end + | Neg nx, Pos ny => + match N.compare nx ny with + | Gt => Neg (N.sub nx ny) + | Eq => zero + | Lt => Pos (N.sub ny nx) + end + | Neg nx, Neg ny => Neg (N.add nx ny) + end. + + Definition pred x := + match x with + | Pos nx => + match N.compare N.zero nx with + | Lt => Pos (N.pred nx) + | _ => minus_one + end + | Neg nx => Neg (N.succ nx) + end. + + Definition sub x y := + match x, y with + | Pos nx, Pos ny => + match N.compare nx ny with + | Gt => Pos (N.sub nx ny) + | Eq => zero + | Lt => Neg (N.sub ny nx) + end + | Pos nx, Neg ny => Pos (N.add nx ny) + | Neg nx, Pos ny => Neg (N.add nx ny) + | Neg nx, Neg ny => + match N.compare nx ny with + | Gt => Neg (N.sub nx ny) + | Eq => zero + | Lt => Pos (N.sub ny nx) + end + end. + + Definition mul x y := + match x, y with + | Pos nx, Pos ny => Pos (N.mul nx ny) + | Pos nx, Neg ny => Neg (N.mul nx ny) + | Neg nx, Pos ny => Neg (N.mul nx ny) + | Neg nx, Neg ny => Pos (N.mul nx ny) + end. + + Definition square x := + match x with + | Pos nx => Pos (N.square nx) + | Neg nx => Pos (N.square nx) + end. + + Definition power_pos x p := + match x with + | Pos nx => Pos (N.power_pos nx p) + | Neg nx => + match p with + | xH => x + | xO _ => Pos (N.power_pos nx p) + | xI _ => Neg (N.power_pos nx p) + end + end. + + Definition sqrt x := + match x with + | Pos nx => Pos (N.sqrt nx) + | Neg nx => Neg N.zero + end. + + Definition div_eucl x y := + match x, y with + | Pos nx, Pos ny => + let (q, r) := N.div_eucl nx ny in + (Pos q, Pos r) + | Pos nx, Neg ny => + let (q, r) := N.div_eucl nx ny in + (Neg q, Pos r) + | Neg nx, Pos ny => + let (q, r) := N.div_eucl nx ny in + match N.compare N.zero r with + | Eq => (Neg q, zero) + | _ => (Neg (N.succ q), Pos (N.sub ny r)) + end + | Neg nx, Neg ny => + let (q, r) := N.div_eucl nx ny in + match N.compare N.zero r with + | Eq => (Pos q, zero) + | _ => (Pos (N.succ q), Pos (N.sub ny r)) + end + end. + + Definition div x y := fst (div_eucl x y). + + Definition modulo x y := snd (div_eucl x y). + + Definition gcd x y := + match x, y with + | Pos nx, Pos ny => Pos (N.gcd nx ny) + | Pos nx, Neg ny => Pos (N.gcd nx ny) + | Neg nx, Pos ny => Pos (N.gcd nx ny) + | Neg nx, Neg ny => Pos (N.gcd nx ny) + end. + +End Make. diff --git a/theories/Ints/num/Zn2Z.v b/theories/Ints/num/Zn2Z.v new file mode 100644 index 000000000..b5c646658 --- /dev/null +++ b/theories/Ints/num/Zn2Z.v @@ -0,0 +1,735 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import ZArith. +Require Import ZAux. +Require Import ZDivModAux. +Require Import Basic_type. +Require Import GenBase. +Require Import GenAdd. +Require Import GenSub. +Require Import GenMul. +Require Import GenSqrt. +Require Import GenLift. +Require Import GenDivn1. +Require Import GenDiv. +Require Import ZnZ. + +Open Local Scope Z_scope. + + +Section Zn2Z. + + Variable w : Set. + Variable w_op : znz_op w. + Let w_digits := w_op.(znz_digits). + + Variable more_than_one_digit: 1 < Zpos w_digits. + + Let w_to_Z := w_op.(znz_to_Z). + Let w_of_pos := w_op.(znz_of_pos). + Let w_head0 := w_op.(znz_head0). + + Let w_0 := w_op.(znz_0). + Let w_1 := w_op.(znz_1). + Let w_Bm1 := w_op.(znz_Bm1). + + Let w_WW := w_op.(znz_WW). + Let w_W0 := w_op.(znz_W0). + Let w_0W := w_op.(znz_0W). + + Let w_compare := w_op.(znz_compare). + Let w_eq0 := w_op.(znz_eq0). + + Let w_opp_c := w_op.(znz_opp_c). + Let w_opp := w_op.(znz_opp). + Let w_opp_carry := w_op.(znz_opp_carry). + + Let w_succ_c := w_op.(znz_succ_c). + Let w_add_c := w_op.(znz_add_c). + Let w_add_carry_c := w_op.(znz_add_carry_c). + Let w_succ := w_op.(znz_succ). + Let w_add := w_op.(znz_add). + Let w_add_carry := w_op.(znz_add_carry). + + Let w_pred_c := w_op.(znz_pred_c). + Let w_sub_c := w_op.(znz_sub_c). + Let w_sub_carry_c := w_op.(znz_sub_carry_c). + Let w_pred := w_op.(znz_pred). + Let w_sub := w_op.(znz_sub). + Let w_sub_carry := w_op.(znz_sub_carry). + + + Let w_mul_c := w_op.(znz_mul_c). + Let w_mul := w_op.(znz_mul). + Let w_square_c := w_op.(znz_square_c). + + Let w_div21 := w_op.(znz_div21). + Let w_div_gt := w_op.(znz_div_gt). + Let w_div := w_op.(znz_div). + + Let w_mod_gt := w_op.(znz_mod_gt). + Let w_mod := w_op.(znz_mod). + + Let w_gcd_gt := w_op.(znz_gcd_gt). + Let w_gcd := w_op.(znz_gcd). + + Let w_add_mul_div := w_op.(znz_add_mul_div). + + Let w_pos_mod := w_op.(znz_pos_mod). + + Let w_is_even := w_op.(znz_is_even). + Let w_sqrt2 := w_op.(znz_sqrt2). + Let w_sqrt := w_op.(znz_sqrt). + + Let _zn2z := zn2z w. + + Let wB := base w_digits. + + Let w_Bm2 := w_pred w_Bm1. + + Let ww_1 := ww_1 w_0 w_1. + Let ww_Bm1 := ww_Bm1 w_Bm1. + + Let _ww_digits := xO w_digits. + + Let to_Z := zn2z_to_Z wB w_to_Z. + + Let ww_of_pos p := + match w_of_pos p with + | (N0, l) => (N0, WW w_0 l) + | (Npos ph,l) => + let (n,h) := w_of_pos ph in (n, w_WW h l) + end. + + Let head0 := + Eval lazy beta delta [ww_head0] in + ww_head0 w_0 w_compare w_head0 w_digits _ww_digits. + + Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW w). + Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W w). + Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 w). + + (* ** Comparison ** *) + Let compare := + Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare. + + Let eq0 (x:zn2z w) := + match x with + | W0 => true + | _ => false + end. + + (* ** Opposites ** *) + Let opp_c := + Eval lazy beta delta [ww_opp_c] in ww_opp_c w_0 w_opp_c w_opp_carry. + + Let opp := + Eval lazy beta delta [ww_opp] in ww_opp w_0 w_opp_c w_opp_carry w_opp. + + Let opp_carry := + Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry. + + (* ** Additions ** *) + + Let succ_c := + Eval lazy beta delta [ww_succ_c] in ww_succ_c w_0 ww_1 w_succ_c. + + Let add_c := + Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c. + + Let add_carry_c := + Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in + ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c. + + Let succ := + Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ. + + Let add := + Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry. + + Let add_carry := + Eval lazy beta iota delta [ww_add_carry ww_succ] in + ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry. + + (* ** Subtractions ** *) + + Let pred_c := + Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c. + + Let sub_c := + Eval lazy beta iota delta [ww_sub_c ww_opp_c] in + ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c. + + Let sub_carry_c := + Eval lazy beta iota delta [ww_sub_carry_c ww_pred_c ww_opp_carry] in + ww_sub_carry_c w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c. + + Let pred := + Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred. + + Let sub := + Eval lazy beta iota delta [ww_sub ww_opp] in + ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry. + + Let sub_carry := + Eval lazy beta iota delta [ww_sub_carry ww_pred ww_opp_carry] in + ww_sub_carry w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_carry_c w_pred + w_sub w_sub_carry. + + + (* ** Multiplication ** *) + + Let mul_c := + Eval lazy beta iota delta [ww_mul_c gen_mul_c] in + ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry. + + Let karatsuba_c := + Eval lazy beta iota delta [ww_karatsuba_c gen_mul_c kara_prod] in + ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c + add_c add add_carry sub_c sub. + + Let mul := + Eval lazy beta delta [ww_mul] in + ww_mul w_W0 w_add w_mul_c w_mul add. + + Let square_c := + Eval lazy beta delta [ww_square_c] in + ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry. + + (* Division operation *) + + Let div32 := + Eval lazy beta iota delta [w_div32] in + w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c + w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c. + + Let div21 := + Eval lazy beta iota delta [ww_div21] in + ww_div21 w_0 w_0W div32 ww_1 compare sub. + + Let add_mul_div := + Eval lazy beta delta [ww_add_mul_div] in + ww_add_mul_div w_0 w_WW w_W0 w_0W w_add_mul_div w_digits. + + Let div_gt := + Eval lazy beta delta [ww_div_gt] in + ww_div_gt w_digits w_0 w_WW w_0W w_compare w_eq0 w_sub_c w_sub w_sub_carry + w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_digits ww_1 add_mul_div. + + Let div := + Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt. + + Let mod_gt := + Eval lazy beta delta [ww_mod_gt] in + ww_mod_gt w_digits w_0 w_WW w_0W w_compare w_eq0 w_sub_c w_sub w_sub_carry + w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_digits add_mul_div. + + Let mod_ := + Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt. + + Let pos_mod := + Eval lazy beta delta [ww_pos_mod] in ww_pos_mod w_0 w_digits w_WW w_pos_mod. + + Let is_even := + Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even. + + Let sqrt2 := + Eval lazy beta delta [ww_sqrt2] in + ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_sub w_square_c + w_div21 w_add_mul_div w_digits w_add_c w_sqrt2 pred_c + pred add_c add sub_c add_mul_div. + + Let sqrt := + Eval lazy beta delta [ww_sqrt] in + ww_sqrt w_0 w_add_mul_div w_digits w_sqrt2 + add_mul_div head0 compare. + + Let gcd_gt_fix := + Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in + ww_gcd_gt_aux w_digits w_0 w_WW w_compare w_sub_c w_sub w_sub_carry w_gcd_gt + w_add_mul_div w_head0 w_div21 div32 _ww_digits add_mul_div. + + Let gcd_cont := + Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare. + + Let gcd_gt := + Eval lazy beta delta [ww_gcd_gt] in + ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. + + Let gcd := + Eval lazy beta delta [ww_gcd] in + ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. + + (* ** Record of operators on 2 words *) + + Definition mk_zn2z_op := + mk_znz_op _ww_digits + to_Z ww_of_pos head0 + W0 ww_1 ww_Bm1 + ww_WW ww_W0 ww_0W + compare eq0 + opp_c opp opp_carry + succ_c add_c add_carry_c + succ add add_carry + pred_c sub_c sub_carry_c + pred sub sub_carry + mul_c mul square_c + div21 div_gt div + mod_gt mod_ + gcd_gt gcd + add_mul_div + pos_mod + is_even + sqrt2 + sqrt. + + Definition mk_zn2z_op_karatsuba := + mk_znz_op _ww_digits + to_Z ww_of_pos head0 + W0 ww_1 ww_Bm1 + ww_WW ww_W0 ww_0W + compare eq0 + opp_c opp opp_carry + succ_c add_c add_carry_c + succ add add_carry + pred_c sub_c sub_carry_c + pred sub sub_carry + karatsuba_c mul square_c + div21 div_gt div + mod_gt mod_ + gcd_gt gcd + add_mul_div + pos_mod + is_even + sqrt2 + sqrt. + + (* Proof *) + Variable op_spec : znz_spec w_op. + + Hint Resolve + (spec_to_Z op_spec) + (spec_of_pos op_spec) + (spec_0 op_spec) + (spec_1 op_spec) + (spec_Bm1 op_spec) + (spec_WW op_spec) + (spec_0W op_spec) + (spec_W0 op_spec) + (spec_compare op_spec) + (spec_eq0 op_spec) + (spec_opp_c op_spec) + (spec_opp op_spec) + (spec_opp_carry op_spec) + (spec_succ_c op_spec) + (spec_add_c op_spec) + (spec_add_carry_c op_spec) + (spec_succ op_spec) + (spec_add op_spec) + (spec_add_carry op_spec) + (spec_pred_c op_spec) + (spec_sub_c op_spec) + (spec_sub_carry_c op_spec) + (spec_pred op_spec) + (spec_sub op_spec) + (spec_sub_carry op_spec) + (spec_mul_c op_spec) + (spec_mul op_spec) + (spec_square_c op_spec) + (spec_div21 op_spec) + (spec_div_gt op_spec) + (spec_div op_spec) + (spec_mod_gt op_spec) + (spec_mod op_spec) + (spec_gcd_gt op_spec) + (spec_gcd op_spec) + (spec_head0 op_spec) + (spec_add_mul_div op_spec) + (spec_pos_mod) + (spec_is_even) + (spec_sqrt2) + (spec_sqrt). + + Let wwB := base _ww_digits. + + Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). + + Notation "[+| c |]" := + (interp_carry 1 wwB to_Z c) (at level 0, x at level 99). + + Notation "[-| c |]" := + (interp_carry (-1) wwB to_Z c) (at level 0, x at level 99). + + Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x) (at level 0, x at level 99). + + Let spec_ww_to_Z : forall x, 0 <= [| x |] < wwB. + Proof. refine (spec_ww_to_Z w_digits w_to_Z _);auto. Qed. + + Let spec_ww_of_pos : forall p, + Zpos p = (Z_of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|]. + Proof. + unfold ww_of_pos;intros. + assert (H:= spec_of_pos op_spec p);unfold w_of_pos; + destruct (znz_of_pos w_op p). simpl in H. + rewrite H;clear H;destruct n;simpl to_Z. + simpl;unfold w_to_Z,w_0;rewrite (spec_0 op_spec);trivial. + unfold Z_of_N; assert (H:= spec_of_pos op_spec p0); + destruct (znz_of_pos w_op p0). simpl in H. + rewrite H;unfold fst, snd,Z_of_N, w_WW, to_Z. + rewrite (spec_WW op_spec). replace wwB with (wB*wB). + unfold wB,w_digits;clear H;destruct n;ring. + symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits). + Qed. + + Let spec_ww_0 : [|W0|] = 0. + Proof. reflexivity. Qed. + + Let spec_ww_1 : [|ww_1|] = 1. + Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);auto. Qed. + + Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1. + Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. + + Let spec_ww_WW : forall h l, [[ww_WW h l]] = [|h|] * wwB + [|l|]. + Proof. + intros h l. replace wwB with (wB*wB). destruct h;simpl. + destruct l;simpl;ring. ring. + symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits). + Qed. + + Let spec_ww_0W : forall l, [[ww_0W l]] = [|l|]. + Proof. + intros l. replace wwB with (wB*wB). + destruct l;simpl;ring. + symmetry. ring_simplify; exact (wwB_wBwB w_digits). + Qed. + + Let spec_ww_W0 : forall h, [[ww_W0 h]] = [|h|]*wwB. + Proof. + intros h. replace wwB with (wB*wB). + destruct h;simpl;ring. + symmetry. ring_simplify; exact (wwB_wBwB w_digits). + Qed. + + Let spec_ww_compare : + forall x y, + match compare x y with + | Eq => [|x|] = [|y|] + | Lt => [|x|] < [|y|] + | Gt => [|x|] > [|y|] + end. + Proof. + refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto. + exact (spec_compare op_spec). + Qed. + + Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0. + Proof. destruct x;simpl;intros;trivial;discriminate. Qed. + + Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|]. + Proof. + refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _); + auto. + Qed. + + Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB. + Proof. + refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp + w_digits w_to_Z _ _ _ _ _); + auto. + Qed. + + Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1. + Proof. + refine (spec_ww_opp_carry w_WW ww_Bm1 w_opp_carry w_digits w_to_Z _ _ _); + auto. exact (spec_WW op_spec). + Qed. + + Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1. + Proof. + refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);auto. + Qed. + + Let spec_ww_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. + Proof. + refine (spec_ww_add_c w_WW w_add_c w_add_carry_c w_digits w_to_Z _ _ _);auto. + exact (spec_WW op_spec). + Qed. + + Let spec_ww_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|]+[|y|]+1. + Proof. + refine (spec_ww_add_carry_c w_0 w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c + w_digits w_to_Z _ _ _ _ _ _ _);auto. exact (spec_WW op_spec). + Qed. + + Let spec_ww_succ : forall x, [|succ x|] = ([|x|] + 1) mod wwB. + Proof. + refine (spec_ww_succ w_W0 ww_1 w_succ_c w_succ w_digits w_to_Z _ _ _ _ _); + auto. exact (spec_W0 op_spec). + Qed. + + Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB. + Proof. + refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);auto. + Qed. + + Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB. + Proof. + refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ + w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);auto. + exact (spec_W0 op_spec). + Qed. + + Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. + Proof. + refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z + _ _ _ _ _);auto. exact (spec_WW op_spec). + Qed. + + Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. + Proof. + refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c + w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);auto. exact (spec_WW op_spec). + Qed. + + Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1. + Proof. + refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c + w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);auto. + exact (spec_WW op_spec). + Qed. + + Let spec_ww_pred : forall x, [|pred x|] = ([|x|] - 1) mod wwB. + Proof. + refine (spec_ww_pred w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_pred w_digits w_to_Z + _ _ _ _ _ _);auto. exact (spec_WW op_spec). + Qed. + + Let spec_ww_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wwB. + Proof. + refine (spec_ww_sub w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_opp + w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _);auto. + exact (spec_WW op_spec). + Qed. + + Let spec_ww_sub_carry : forall x y, [|sub_carry x y|]=([|x|]-[|y|]-1) mod wwB. + Proof. + refine (spec_ww_sub_carry w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c + w_sub_carry_c w_pred w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _); + auto. exact (spec_WW op_spec). + Qed. + + Let spec_ww_mul_c : forall x y, [[mul_c x y ]] = [|x|] * [|y|]. + Proof. + refine (spec_ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry w_digits + w_to_Z _ _ _ _ _ _ _ _ _);auto. exact (spec_WW op_spec). + exact (spec_W0 op_spec). exact (spec_mul_c op_spec). + Qed. + + Let spec_ww_karatsuba_c : forall x y, [[karatsuba_c x y ]] = [|x|] * [|y|]. + Proof. + refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ + _ _ _ _ _ _ _ _ _ _ _ _); auto. + exact (spec_WW op_spec). + exact (spec_W0 op_spec). + exact (spec_compare op_spec). + exact (spec_mul_c op_spec). + Qed. + + Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB. + Proof. + refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _); + auto. exact (spec_W0 op_spec). exact (spec_mul_c op_spec). + Qed. + + Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|]. + Proof. + refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add + add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);auto. + exact (spec_WW op_spec). exact (spec_W0 op_spec). + exact (spec_mul_c op_spec). exact (spec_square_c op_spec). + Qed. + + Let spec_w_div32 : forall a1 a2 a3 b1 b2, + wB / 2 <= (w_to_Z b1) -> + [|WW a1 a2|] < [|WW b1 b2|] -> + let (q, r) := div32 a1 a2 a3 b1 b2 in + (w_to_Z a1) * wwB + (w_to_Z a2) * wB + (w_to_Z a3) = + (w_to_Z q) * ((w_to_Z b1)*wB + (w_to_Z b2)) + [|r|] /\ + 0 <= [|r|] < (w_to_Z b1)*wB + w_to_Z b2. + Proof. + refine (spec_w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c + w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c w_digits w_to_Z + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);auto. + unfold w_Bm2, w_to_Z, w_pred, w_Bm1. + rewrite (spec_pred op_spec);rewrite (spec_Bm1 op_spec). + unfold w_digits;rewrite Zmod_def_small. ring. + assert (H:= wB_pos(znz_digits w_op)). omega. + exact (spec_WW op_spec). exact (spec_compare op_spec). + exact (spec_mul_c op_spec). exact (spec_div21 op_spec). + Qed. + + Let spec_ww_div21 : forall a1 a2 b, + wwB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := div21 a1 a2 b in + [|a1|] *wwB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z + _ _ _ _ _ _ _);auto. exact (spec_0W op_spec). + Qed. + + Let spec_ww_head0 : forall x, 0 < [|x|] -> + wwB/ 2 <= 2 ^ (Z_of_N (head0 x)) * [|x|] < wwB. + Proof. + refine (spec_ww_head0 w_0 w_compare w_head0 w_digits _ww_digits + w_to_Z _ _ _ _);auto. exact (spec_compare op_spec). + Qed. + + Lemma spec_ww_add_mul_div : forall x y p, + Zpos p < Zpos _ww_digits -> + [| add_mul_div p x y |] = + ([|x|] * (Zpower 2 (Zpos p)) + + [|y|] / (Zpower 2 ((Zpos _ww_digits) - (Zpos p)))) mod wwB. + Proof. + refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W w_add_mul_div w_digits + w_to_Z _ _ _ _ _ _);auto. exact (spec_WW op_spec). + exact (spec_W0 op_spec). exact (spec_0W op_spec). + Qed. + + Let spec_ww_div_gt : forall a b, + [|a|] > [|b|] -> 0 < [|b|] -> + let (q,r) := div_gt a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. + Proof. + refine (@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 + w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt + w_add_mul_div w_head0 w_div21 div32 _ww_digits ww_1 add_mul_div w_to_Z + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);auto. + exact (spec_WW op_spec). exact (spec_0W op_spec). + exact (spec_compare op_spec). exact (spec_div_gt op_spec). + exact (spec_div21 op_spec). exact spec_ww_add_mul_div. + Qed. + + Let spec_ww_div : forall a b, 0 < [|b|] -> + let (q,r) := div a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. + Proof. + refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto. + Qed. + + Let spec_ww_mod_gt : forall a b, + [|a|] > [|b|] -> 0 < [|b|] -> + [|mod_gt a b|] = [|a|] mod [|b|]. + Proof. + refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 + w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt + w_add_mul_div w_head0 w_div21 div32 _ww_digits ww_1 add_mul_div w_to_Z + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);auto. + exact (spec_WW op_spec). exact (spec_0W op_spec). + exact (spec_compare op_spec). exact (spec_div_gt op_spec). + exact (spec_div21 op_spec). exact spec_ww_add_mul_div. + Qed. + + Let spec_ww_mod : forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|]. + Proof. + refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);auto. + Qed. + + Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] -> + Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. + Proof. + refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _ + w_0 w_0 w_eq0 w_gcd_gt _ww_digits + _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. + refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_compare w_opp_c w_opp + w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 + w_div21 div32 _ww_digits ww_1 add_mul_div w_to_Z + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);auto. + exact (spec_WW op_spec). exact (spec_compare op_spec). + exact (spec_div21 op_spec). exact spec_ww_add_mul_div. + refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare + _ _);auto. exact (spec_compare op_spec). + Qed. + + Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. + Proof. + refine (@spec_ww_gcd w w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt + _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. + refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_compare w_opp_c w_opp + w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 + w_div21 div32 _ww_digits ww_1 add_mul_div w_to_Z + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);auto. + exact (spec_WW op_spec). exact (spec_compare op_spec). + exact (spec_div21 op_spec). exact spec_ww_add_mul_div. + refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare + _ _);auto. exact (spec_compare op_spec). + Qed. + + Let spec_ww_is_even : forall x, + match is_even x with + true => [|x|] mod 2 = 0 + | false => [|x|] mod 2 = 1 + end. + Proof. + refine (@spec_ww_is_even w w_is_even w_0 w_1 w_Bm1 w_digits _ _ _); auto. + exact (spec_is_even op_spec). + Qed. + + Let spec_ww_sqrt2 : forall x y, + wwB/ 4 <= [|x|] -> + let (s,r) := sqrt2 x y in + [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]. + Proof. + intros x y H. + refine (@spec_ww_sqrt2 w w_is_even w_compare w_0 w_1 w_Bm1 + w_sub w_square_c w_div21 w_add_mul_div w_digits + w_add_c w_sqrt2 pred_c pred add_c add sub_c add_mul_div + _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); auto. + exact (spec_is_even op_spec). + exact (spec_compare op_spec). + exact (spec_square_c op_spec). + exact (spec_div21 op_spec). + exact (spec_ww_add_mul_div). + exact (spec_sqrt2 op_spec). + Qed. + + Let spec_ww_sqrt : forall x, + [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. + Proof. + refine (@spec_ww_sqrt w w_0 w_1 w_Bm1 w_add_mul_div w_digits + w_sqrt2 add_mul_div head0 compare + _ _ _ _ _ _ _ _ _ _); auto. + exact (spec_ww_add_mul_div). + exact (spec_sqrt2 op_spec). + Qed. + + Lemma mk_znz2_spec : znz_spec mk_zn2z_op. + Proof. + apply mk_znz_spec;auto. + exact spec_ww_add_mul_div. + refine (@spec_ww_pos_mod w w_0 w_digits w_WW w_pos_mod w_to_Z + _ _ _ _);auto. exact (spec_WW op_spec). exact (spec_pos_mod op_spec). + Qed. + + Lemma mk_znz2_karatsuba_spec : znz_spec mk_zn2z_op_karatsuba. + Proof. + apply mk_znz_spec;auto. + exact spec_ww_add_mul_div. + refine (@spec_ww_pos_mod w w_0 w_digits w_WW w_pos_mod w_to_Z + _ _ _ _);auto. exact (spec_WW op_spec). exact (spec_pos_mod op_spec). + Qed. + +End Zn2Z. + diff --git a/theories/Ints/num/ZnZ.v b/theories/Ints/num/ZnZ.v new file mode 100644 index 000000000..5efcad2d0 --- /dev/null +++ b/theories/Ints/num/ZnZ.v @@ -0,0 +1,300 @@ + +(*************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(*************************************************************) +(* Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr *) +(*************************************************************) + +Set Implicit Arguments. + +Require Import Tactic. +Require Import ZArith. +Require Import Znumtheory. +Require Import Basic_type. +Require Import GenBase. + +Open Local Scope Z_scope. + +Section ZnZ_Op. + + Variable znz : Set. + + Record znz_op : Set := mk_znz_op { + (* Conversion functions with Z *) + znz_digits : positive; + znz_to_Z : znz -> Z; + znz_of_pos : positive -> N * znz; + znz_head0 : znz -> N; + (* Basic constructors *) + znz_0 : znz; + znz_1 : znz; + znz_Bm1 : znz; + znz_WW : znz -> znz -> zn2z znz; + znz_W0 : znz -> zn2z znz; + znz_0W : znz -> zn2z znz; + + (* Comparison *) + znz_compare : znz -> znz -> comparison; + znz_eq0 : znz -> bool; + + (* Basic arithmetic operations *) + znz_opp_c : znz -> carry znz; + znz_opp : znz -> znz; + znz_opp_carry : znz -> znz; (* the carry is know to be -1 *) + + znz_succ_c : znz -> carry znz; + znz_add_c : znz -> znz -> carry znz; + znz_add_carry_c : znz -> znz -> carry znz; + znz_succ : znz -> znz; + znz_add : znz -> znz -> znz; + znz_add_carry : znz -> znz -> znz; + + znz_pred_c : znz -> carry znz; + znz_sub_c : znz -> znz -> carry znz; + znz_sub_carry_c : znz -> znz -> carry znz; + znz_pred : znz -> znz; + znz_sub : znz -> znz -> znz; + znz_sub_carry : znz -> znz -> znz; + + znz_mul_c : znz -> znz -> zn2z znz; + znz_mul : znz -> znz -> znz; + znz_square_c : znz -> zn2z znz; + + (* Special divisions operations *) + znz_div21 : znz -> znz -> znz -> znz*znz; + znz_div_gt : znz -> znz -> znz * znz; + znz_div : znz -> znz -> znz * znz; + + znz_mod_gt : znz -> znz -> znz; + znz_mod : znz -> znz -> znz; + + znz_gcd_gt : znz -> znz -> znz; + znz_gcd : znz -> znz -> znz; + znz_add_mul_div : positive -> znz -> znz -> znz; + znz_pos_mod : positive -> znz -> znz; + + (* square root *) + znz_is_even : znz -> bool; + znz_sqrt2 : znz -> znz -> znz * carry znz; + znz_sqrt : znz -> znz }. + +End ZnZ_Op. + +Section Spec. + Variable w : Set. + Variable w_op : znz_op w. + + Let w_digits := w_op.(znz_digits). + Let w_to_Z := w_op.(znz_to_Z). + Let w_of_pos := w_op.(znz_of_pos). + Let w_head0 := w_op.(znz_head0). + + Let w0 := w_op.(znz_0). + Let w1 := w_op.(znz_1). + Let wBm1 := w_op.(znz_Bm1). + + Let wWW := w_op.(znz_WW). + Let w0W := w_op.(znz_0W). + Let wW0 := w_op.(znz_W0). + + Let w_compare := w_op.(znz_compare). + Let w_eq0 := w_op.(znz_eq0). + + Let w_opp_c := w_op.(znz_opp_c). + Let w_opp := w_op.(znz_opp). + Let w_opp_carry := w_op.(znz_opp_carry). + + Let w_succ_c := w_op.(znz_succ_c). + Let w_add_c := w_op.(znz_add_c). + Let w_add_carry_c := w_op.(znz_add_carry_c). + Let w_succ := w_op.(znz_succ). + Let w_add := w_op.(znz_add). + Let w_add_carry := w_op.(znz_add_carry). + + Let w_pred_c := w_op.(znz_pred_c). + Let w_sub_c := w_op.(znz_sub_c). + Let w_sub_carry_c := w_op.(znz_sub_carry_c). + Let w_pred := w_op.(znz_pred). + Let w_sub := w_op.(znz_sub). + Let w_sub_carry := w_op.(znz_sub_carry). + + Let w_mul_c := w_op.(znz_mul_c). + Let w_mul := w_op.(znz_mul). + Let w_square_c := w_op.(znz_square_c). + + Let w_div21 := w_op.(znz_div21). + Let w_div_gt := w_op.(znz_div_gt). + Let w_div := w_op.(znz_div). + + Let w_mod_gt := w_op.(znz_mod_gt). + Let w_mod := w_op.(znz_mod). + + Let w_gcd_gt := w_op.(znz_gcd_gt). + Let w_gcd := w_op.(znz_gcd). + + Let w_add_mul_div := w_op.(znz_add_mul_div). + + Let w_pos_mod := w_op.(znz_pos_mod). + + Let w_is_even := w_op.(znz_is_even). + Let w_sqrt2 := w_op.(znz_sqrt2). + Let w_sqrt := w_op.(znz_sqrt). + + Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). + + Let wB := base w_digits. + + Notation "[+| c |]" := + (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99). + + Notation "[-| c |]" := + (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). + + Notation "[|| x ||]" := + (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). + + Notation "[! n | x !]" := (gen_to_Z w_digits w_to_Z n x) + (at level 0, x at level 99). + + Record znz_spec : Set := mk_znz_spec { + + (* Conversion functions with Z *) + spec_to_Z : forall x, 0 <= [| x |] < wB; + spec_of_pos : forall p, + Zpos p = (Z_of_N (fst (w_of_pos p)))*wB + [|(snd (w_of_pos p))|]; + + (* Basic constructors *) + spec_0 : [|w0|] = 0; + spec_1 : [|w1|] = 1; + spec_Bm1 : [|wBm1|] = wB - 1; + spec_WW : forall h l, [||wWW h l||] = [|h|] * wB + [|l|]; + spec_0W : forall l, [||w0W l||] = [|l|]; + spec_W0 : forall h, [||wW0 h||] = [|h|]*wB; + + (* Comparison *) + spec_compare : + forall x y, + match w_compare x y with + | Eq => [|x|] = [|y|] + | Lt => [|x|] < [|y|] + | Gt => [|x|] > [|y|] + end; + spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0; + (* Basic arithmetic operations *) + spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]; + spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB; + spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1; + + spec_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1; + spec_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]; + spec_add_carry_c : forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1; + spec_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB; + spec_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB; + spec_add_carry : + forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB; + + spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1; + spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]; + spec_sub_carry_c : forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1; + spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB; + spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB; + spec_sub_carry : + forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB; + + spec_mul_c : forall x y, [|| w_mul_c x y ||] = [|x|] * [|y|]; + spec_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB; + spec_square_c : forall x, [|| w_square_c x||] = [|x|] * [|x|]; + + (* Special divisions operations *) + spec_div21 : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := w_div21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + let (q,r) := w_div_gt a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + spec_div : forall a b, 0 < [|b|] -> + let (q,r) := w_div a b in + [|a|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]; + + spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> + [|w_mod_gt a b|] = [|a|] mod [|b|]; + spec_mod : forall a b, 0 < [|b|] -> + [|w_mod a b|] = [|a|] mod [|b|]; + + spec_gcd_gt : forall a b, [|a|] > [|b|] -> + Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]; + spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|w_gcd a b|]; + + + (* shift operations *) + spec_head0 : forall x, 0 < [|x|] -> + wB/ 2 <= 2 ^ (Z_of_N (w_head0 x)) * [|x|] < wB; + spec_add_mul_div : forall x y p, + Zpos p < Zpos w_digits -> + [| w_add_mul_div p x y |] = + ([|x|] * (Zpower 2 (Zpos p)) + + [|y|] / (Zpower 2 ((Zpos w_digits) - (Zpos p)))) mod wB; + spec_pos_mod : forall w p, + [|w_pos_mod p w|] = [|w|] mod (2 ^ Zpos p); + (* sqrt *) + spec_is_even : forall x, + if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1; + spec_sqrt2 : forall x y, + wB/ 4 <= [|x|] -> + let (s,r) := w_sqrt2 x y in + [||WW x y||] = [|s|] ^ 2 + [+|r|] /\ + [+|r|] <= 2 * [|s|]; + spec_sqrt : forall x, + [|w_sqrt x|] ^ 2 <= [|x|] < ([|w_sqrt x|] + 1) ^ 2 + }. + +End Spec. + + +Section znz_of_pos. + + Variable w : Set. + Variable w_op : znz_op w. + Variable op_spec : znz_spec w_op. + + Notation "[| x |]" := (znz_to_Z w_op x) (at level 0, x at level 99). + + Definition znz_of_Z (w:Set) (op:znz_op w) z := + match z with + | Zpos p => snd (op.(znz_of_pos) p) + | _ => op.(znz_0) + end. + + Theorem znz_of_pos_correct: + forall p, Zpos p < base (znz_digits w_op) -> [|(snd (znz_of_pos w_op p))|] = Zpos p. + intros p Hp. + generalize (spec_of_pos op_spec p). + case (znz_of_pos w_op p); intros n w1; simpl. + case n; simpl Npos; auto with zarith. + intros p1 Hp1; contradict Hp; apply Zle_not_lt. + rewrite Hp1; auto with zarith. + match goal with |- _ <= ?X + ?Y => + apply Zle_trans with X; auto with zarith + end. + match goal with |- ?X <= _ => + pattern X at 1; rewrite <- (Zmult_1_l); + apply Zmult_le_compat_r; auto with zarith + end. + case p1; simpl; intros; red; simpl; intros; discriminate. + unfold base; auto with zarith. + case (spec_to_Z op_spec w1); auto with zarith. + Qed. + + Theorem znz_of_Z_correct: + forall p, 0 <= p < base (znz_digits w_op) -> [|znz_of_Z w_op p|] = p. + intros p; case p; simpl; try rewrite spec_0; auto. + intros; rewrite znz_of_pos_correct; auto with zarith. + intros p1 (H1, _); contradict H1; apply Zlt_not_le; red; simpl; auto. + Qed. +End znz_of_pos. diff --git a/theories/Ints/num/genN.ml b/theories/Ints/num/genN.ml new file mode 100644 index 000000000..bf6bf6535 --- /dev/null +++ b/theories/Ints/num/genN.ml @@ -0,0 +1,816 @@ +open Format + +let size = 3 +let sizeaux = 1 + +let t = "t" +let c = "N" + +(******* Start Printing ********) +let basename = "N" + + +let print_header fmt l = + let l = "ZArith"::"Basic_type"::"ZnZ"::"Zn2Z"::"Nbasic"::"GenMul":: + "GenDivn1"::"Lucas"::l in + List.iter (fun s -> fprintf fmt "Require Import %s.\n" s) l; + fprintf fmt "\n" + +let start_file post l = + let outname = basename^post^".v" in + let fd = + try + Unix.openfile outname [Unix.O_WRONLY;Unix.O_CREAT;Unix.O_TRUNC] 0o640 + with _ -> + print_string ("can not open file "^outname^"\n"); + exit 1 in + let out = Unix.out_channel_of_descr fd in + set_binary_mode_out out false; + let fmt = formatter_of_out_channel out in + print_header fmt l; + fmt + + + +(****** Print types *******) + +let print_Make () = + let fmt = start_file "Make" [] in + + fprintf fmt "Module Type W0Type.\n"; + fprintf fmt " Parameter w : Set.\n"; + fprintf fmt " Parameter w_op : znz_op w.\n"; + fprintf fmt " Parameter w_spec : znz_spec w_op.\n"; + fprintf fmt "End W0Type.\n"; + fprintf fmt "\n"; + + fprintf fmt "Module Make (W0:W0Type).\n"; + fprintf fmt " Import W0.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition w0 := W0.w.\n"; + for i = 1 to size do + fprintf fmt " Definition w%i := zn2z w%i.\n" i (i-1) + done; + fprintf fmt "\n"; + + fprintf fmt " Definition w0_op := W0.w_op.\n"; + for i = 1 to 3 do + fprintf fmt " Definition w%i_op := mk_zn2z_op w%i_op.\n" i (i-1) + done; + for i = 4 to size + 3 do + fprintf fmt " Definition w%i_op := mk_zn2z_op_karatsuba w%i_op.\n" i (i-1) + done; + fprintf fmt "\n"; + + fprintf fmt " Section Make_op.\n"; + fprintf fmt " Variable mk : forall w', znz_op w' -> znz_op (zn2z w').\n"; + fprintf fmt "\n"; + fprintf fmt + " Fixpoint make_op_aux (n:nat) : znz_op (word w%i (S n)):=\n" size; + fprintf fmt " match n return znz_op (word w%i (S n)) with\n" size; + fprintf fmt " | O => w%i_op\n" (size+1); + fprintf fmt " | S n1 =>\n"; + fprintf fmt " match n1 return znz_op (word w%i (S (S n1))) with\n" size; + fprintf fmt " | O => w%i_op\n" (size+2); + fprintf fmt " | S n2 =>\n"; + fprintf fmt " match n2 return znz_op (word w%i (S (S (S n2)))) with\n" + size; + fprintf fmt " | O => w%i_op\n" (size+3); + fprintf fmt " | S n3 => mk _ (mk _ (mk _ (make_op_aux n3)))\n"; + fprintf fmt " end\n"; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + fprintf fmt " End Make_op.\n"; + fprintf fmt "\n"; + fprintf fmt " Definition make_op := make_op_aux mk_zn2z_op_karatsuba.\n"; + fprintf fmt "\n"; + + fprintf fmt " Inductive %s_ : Set :=\n" t; + for i = 0 to size do + fprintf fmt " | %s%i : w%i -> %s_\n" c i i t + done; + fprintf fmt " | %sn : forall n, word w%i (S n) -> %s_.\n" c size t; + fprintf fmt "\n"; + fprintf fmt " Definition %s := %s_.\n" t t; + fprintf fmt "\n"; + + fprintf fmt " Definition w_0 := w0_op.(znz_0).\n"; + fprintf fmt "\n"; + + for i = 0 to size do + fprintf fmt " Definition one%i := w%i_op.(znz_1).\n" i i + done; + fprintf fmt "\n"; + + fprintf fmt " Definition zero := %s0 w_0.\n" c; + fprintf fmt " Definition one := %s0 one0.\n" c; + fprintf fmt "\n"; + + (* Successor function *) + for i = 0 to size do + fprintf fmt " Definition w%i_succ_c := w%i_op.(znz_succ_c).\n" i i + done; + fprintf fmt "\n"; + + for i = 0 to size do + fprintf fmt " Definition w%i_succ := w%i_op.(znz_succ).\n" i i + done; + fprintf fmt "\n"; + + fprintf fmt " Definition succ x :=\n"; + fprintf fmt " match x with\n"; + for i = 0 to size-1 do + fprintf fmt " | %s%i wx =>\n" c i; + fprintf fmt " match w%i_succ_c wx with\n" i; + fprintf fmt " | C0 r => %s%i r\n" c i; + fprintf fmt " | C1 r => %s%i (WW one%i r)\n" c (i+1) i; + fprintf fmt " end\n"; + done; + fprintf fmt " | %s%i wx =>\n" c size; + fprintf fmt " match w%i_succ_c wx with\n" size; + fprintf fmt " | C0 r => %s%i r\n" c size; + fprintf fmt " | C1 r => %sn 0 (WW one%i r)\n" c size ; + fprintf fmt " end\n"; + fprintf fmt " | %sn n wx =>\n" c; + fprintf fmt " let op := make_op n in\n"; + fprintf fmt " match op.(znz_succ_c) wx with\n"; + fprintf fmt " | C0 r => %sn n r\n" c; + fprintf fmt " | C1 r => %sn (S n) (WW op.(znz_1) r)\n" c; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + for i = 1 to size do + fprintf fmt " Definition extend%i :=\n" i; + fprintf fmt " Eval lazy beta zeta iota delta [extend]in extend %i.\n" i + done; + fprintf fmt "\n"; + + for i = 0 to size do + fprintf fmt " Definition w%i_eq0 := w%i_op.(znz_eq0).\n" i i + done; + fprintf fmt "\n"; + + for i = 0 to size do + fprintf fmt " Definition w%i_0W := w%i_op.(znz_0W).\n" i i + done; + fprintf fmt "\n"; + fprintf fmt " Definition w0_WW := w0_op.(znz_WW).\n"; + fprintf fmt "\n"; + + (* Addition *) + for i = 0 to size do + fprintf fmt " Definition w%i_add_c := w%i_op.(znz_add_c).\n" i i + done; + fprintf fmt "\n"; +(* + fprintf fmt " Definition add_c_1_0 x y :=\n"; + fprintf fmt " match x with\n"; + fprintf fmt " | W0 => C0 (w0_0W y)\n"; + fprintf fmt " | WW xh xl => + fprintf fmt " match w1_add_c xl y with\n"; + fprintf fmt " | C0 rl => C0 (WW xh rl)\n"; + fprintf fmt " | C1 rl =>\n"; + fprintf fmt " match w1_succ_c xh with\n"; + fprintf fmt " | C0 rh => C0 (WW rh rl)\n"; + fprintf fmt " | C1 rh => C1 (w0_WW rh rl)\n"; + fprintf fmt " end\n"; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + for i = 1 to size do + fprintf fmt " Definition add_c_n_%i :=\n" i; + fprintf fmt " add_c_smn1 w%i +*) + + for i = 0 to size do + fprintf fmt " Definition w%i_add x y :=\n" i; + fprintf fmt " match w%i_add_c x y with\n" i; + fprintf fmt " | C0 r => %s%i r\n" c i; + fprintf fmt " | C1 r => "; + if i < size then fprintf fmt "%s%i (WW one%i r)\n" c (i+1) i + else fprintf fmt "%sn 0 (WW one%i r)\n" c size; + fprintf fmt " end.\n" + done; + fprintf fmt " Definition addn n (x y : word w%i (S n)) :=\n" size; + fprintf fmt " let op := make_op n in\n"; + fprintf fmt " match op.(znz_add_c) x y with\n"; + fprintf fmt " | C0 r => %sn n r\n" c; + fprintf fmt " | C1 r => %sn (S n) (WW op.(znz_1) r)" c; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition add x y :=\n"; + fprintf fmt " match x, y with\n"; + fprintf fmt " | %s0 wx, %s0 wy => w0_add wx wy \n" c c; + for j = 1 to size do + fprintf fmt " | %s0 wx, %s%i wy =>\n" c c j; + fprintf fmt " if w0_eq0 wx then y else w%i_add " j; + if j = 1 then fprintf fmt "(WW w_0 wx) wy\n" + else fprintf fmt "(extend%i w0 (WW w_0 wx)) wy\n" (j-1) + done; + fprintf fmt " | %s0 wx, %sn n wy =>\n" c c; + fprintf fmt " if w0_eq0 wx then y\n"; + fprintf fmt " else addn n (extend n w%i (extend%i w0 (WW w_0 wx))) wy\n" + size size; + for i = 1 to size do + fprintf fmt " | %s%i wx, %s0 wy =>\n" c i c; + fprintf fmt + " if w0_eq0 wy then x else w%i_add wx " i; + if i = 1 then fprintf fmt "(WW w_0 wy)\n" + else fprintf fmt "(extend%i w0 (WW w_0 wy))\n" (i-1); + for j = 1 to size do + fprintf fmt " | %s%i wx, %s%i wy => " c i c j; + if i < j then fprintf fmt "w%i_add (extend%i w%i wx) wy\n" j (j-i) (i-1) + else if i = j then fprintf fmt "w%i_add wx wy\n" j + else fprintf fmt "w%i_add wx (extend%i w%i wy)\n" i (i-j) (j-1) + done; + fprintf fmt + " | %s%i wx, %sn n wy => addn n (extend n w%i (extend%i w%i wx)) wy\n" + c i c size (size-i+1) (i-1) + done; + fprintf fmt " | %sn n wx, %s0 wy =>\n" c c; + fprintf fmt " if w0_eq0 wy then x\n"; + fprintf fmt " else addn n wx (extend n w%i (extend%i w0 (WW w_0 wy)))\n" + size size; + for j = 1 to size do + fprintf fmt + " | %sn n wx, %s%i wy => addn n wx (extend n w%i (extend%i w%i wy))\n" + c c j size (size-j+1) (j-1); + done; + fprintf fmt " | %sn n wx, %sn m wy =>\n" c c; + fprintf fmt " match extend_to_max w%i n m wx wy with\n" size; + fprintf fmt " | inl wx' => addn m wx' wy\n"; + fprintf fmt " | inr wy' => addn n wx wy'\n"; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition reduce_0 (x:w) := %s0 x.\n" c; + fprintf fmt " Definition reduce_1 :=\n"; + fprintf fmt " Eval lazy beta iota delta[reduce_n1] in\n"; + fprintf fmt " reduce_n1 _ _ zero w0_eq0 %s0 %s1.\n" c c; + for i = 2 to size do + fprintf fmt " Definition reduce_%i :=\n" i; + fprintf fmt " Eval lazy beta iota delta[reduce_n1] in\n"; + fprintf fmt " reduce_n1 _ _ zero w%i_eq0 reduce_%i %s%i.\n" + (i-1) (i-1) c i + done; + fprintf fmt " Definition reduce_%i :=\n" (size+1); + fprintf fmt " Eval lazy beta iota delta[reduce_n1] in\n"; + fprintf fmt " reduce_n1 _ _ zero w%i_eq0 reduce_%i (%sn 0).\n" + size size c; + + fprintf fmt " Definition reduce_n n := \n"; + fprintf fmt " Eval lazy beta iota delta[reduce_n] in\n"; + fprintf fmt " reduce_n _ _ zero reduce_%i %sn n.\n" (size + 1) c; + fprintf fmt "\n"; + + (* Predecessor *) + for i = 0 to size do + fprintf fmt " Definition w%i_pred_c := w%i_op.(znz_pred_c).\n" i i + done; + fprintf fmt "\n"; + + fprintf fmt " Definition pred x :=\n"; + fprintf fmt " match x with\n"; + for i = 0 to size do + fprintf fmt " | %s%i wx =>\n" c i; + fprintf fmt " match w%i_pred_c wx with\n" i; + fprintf fmt " | C0 r => reduce_%i r\n" i; + fprintf fmt " | C1 r => zero\n"; + fprintf fmt " end\n"; + done; + fprintf fmt " | %sn n wx =>\n" c; + fprintf fmt " let op := make_op n in\n"; + fprintf fmt " match op.(znz_pred_c) wx with\n"; + fprintf fmt " | C0 r => reduce_n n r\n"; + fprintf fmt " | C1 r => zero\n"; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + (* Substraction *) + fprintf fmt "\n"; + for i = 0 to size do + fprintf fmt " Definition w%i_sub_c := w%i_op.(znz_sub_c).\n" i i + done; + fprintf fmt "\n"; + + for i = 0 to size do + fprintf fmt " Definition w%i_sub x y :=\n" i; + fprintf fmt " match w%i_sub_c x y with\n" i; + fprintf fmt " | C0 r => reduce_%i r\n" i; + fprintf fmt " | C1 r => zero\n"; + fprintf fmt " end.\n" + done; + fprintf fmt "\n"; + + fprintf fmt " Definition subn n (x y : word w%i (S n)) :=\n" size; + fprintf fmt " let op := make_op n in\n"; + fprintf fmt " match op.(znz_sub_c) x y with\n"; + fprintf fmt " | C0 r => %sn n r\n" c; + fprintf fmt " | C1 r => %sn (S n) (WW op.(znz_1) r)" c; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition sub x y :=\n"; + fprintf fmt " match x, y with\n"; + fprintf fmt " | %s0 wx, %s0 wy => w0_sub wx wy \n" c c; + for j = 1 to size do + fprintf fmt " | %s0 wx, %s%i wy =>\n" c c j; + fprintf fmt " if w0_eq0 wx then zero else w%i_sub " j; + if j = 1 then fprintf fmt "(WW w_0 wx) wy\n" + else fprintf fmt "(extend%i w0 (WW w_0 wx)) wy\n" (j-1) + done; + fprintf fmt " | %s0 wx, %sn n wy =>\n" c c; + fprintf fmt " if w0_eq0 wx then zero\n"; + fprintf fmt " else subn n (extend n w%i (extend%i w0 (WW w_0 wx))) wy\n" + size size; + for i = 1 to size do + fprintf fmt " | %s%i wx, %s0 wy =>" c i c; + fprintf fmt "\n if w0_eq0 wy then x\n"; + fprintf fmt " else w%i_sub wx " i; + if i = 1 then fprintf fmt "(WW w_0 wy)\n" + else fprintf fmt "(extend%i w0 (WW w_0 wy))\n" (i-1); + for j = 1 to size do + fprintf fmt " | %s%i wx, %s%i wy => " c i c j; + if i < j then fprintf fmt "w%i_sub (extend%i w%i wx) wy\n" j (j-i) (i-1) + else if i = j then fprintf fmt "w%i_sub wx wy\n" j + else fprintf fmt "w%i_sub wx (extend%i w%i wy)\n" i (i-j) (j-1) + done; + fprintf fmt + " | %s%i wx, %sn n wy => subn n (extend n w%i (extend%i w%i wx)) wy\n" + c i c size (size-i+1) (i-1) + done; + fprintf fmt " | %sn n wx, %s0 wy =>\n" c c; + fprintf fmt " if w0_eq0 wy then x\n"; + fprintf fmt " else subn n wx (extend n w%i (extend%i w0 (WW w_0 wy)))\n" + size size; + for j = 1 to size do + fprintf fmt + " | %sn n wx, %s%i wy => subn n wx (extend n w%i (extend%i w%i wy))\n" + c c j size (size-j+1) (j-1); + done; + fprintf fmt " | %sn n wx, %sn m wy =>\n" c c; + fprintf fmt " match extend_to_max w%i n m wx wy with\n" size; + fprintf fmt " | inl wx' => subn m wx' wy\n"; + fprintf fmt " | inr wy' => subn n wx wy'\n"; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + for i = 0 to size do + fprintf fmt " Definition compare_%i := w%i_op.(znz_compare).\n" i i; + fprintf fmt " Definition comparen_%i :=\n" i; + let s0 = if i = 0 then "w_0" else "W0" in + fprintf fmt + " compare_mn_1 w%i w%i %s compare_%i (compare_%i %s) compare_%i.\n" + i i s0 i i s0 i + done; + fprintf fmt "\n"; + + (* Comparison *) + fprintf fmt " Definition compare x y :=\n"; + fprintf fmt " match x, y with\n"; + for i = 0 to size do + for j = 0 to size do + fprintf fmt " | %s%i wx, %s%i wy => " c i c j; + if i < j then fprintf fmt "opp_compare (comparen_%i %i wy wx)\n" i (j-i) + else if i = j then fprintf fmt "compare_%i wx wy\n" i + else fprintf fmt "comparen_%i %i wx wy\n" j (i-j) + done; + let s0 = if i = 0 then "w_0" else "W0" in + fprintf fmt " | %s%i wx, %sn n wy =>\n" c i c; + fprintf fmt " opp_compare (compare_mn_1 w%i w%i %s " size i s0; + fprintf fmt "compare_%i (compare_%i W0) (comparen_%i %i) (S n) wy wx)\n" + i size i (size - i) + done; + for j = 0 to size do + let s0 = if j = 0 then "w_0" else "W0" in + fprintf fmt " | %sn n wx, %s%i wy =>\n" c c j; + fprintf fmt " compare_mn_1 w%i w%i %s " size j s0; + fprintf fmt "compare_%i (compare_%i W0) (comparen_%i %i) (S n) wx wy\n" + j size j (size - j) + done; + fprintf fmt " | %sn n wx, %sn m wy =>\n" c c; + fprintf fmt " match extend_to_max w%i n m wx wy with\n" size; + fprintf fmt + " | inl wx' => let op := make_op m in op.(znz_compare) wx' wy \n"; + fprintf fmt + " | inr wy' => let op := make_op n in op.(znz_compare) wx wy' \n"; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition eq_bool x y :=\n"; + fprintf fmt " match compare x y with\n"; + fprintf fmt " | Eq => true\n"; + fprintf fmt " | _ => false\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + + (* Multiplication *) + for i = 0 to size do + fprintf fmt " Definition w%i_mul_c := w%i_op.(znz_mul_c).\n" i i + done; + fprintf fmt "\n"; + + for i = 0 to size do + let s0 = if i = 0 then "w_0" else "W0" in + fprintf fmt " Definition w%i_mul_add :=\n" i; + fprintf fmt " Eval lazy beta delta [w_mul_add] in\n"; + fprintf fmt " %sw_mul_add w%i %s w%i_succ w%i_add_c w%i_mul_c.\n" + "@" i s0 i i i + done; + fprintf fmt "\n"; + + for i = 0 to size do + let s0 = if i = 0 then "w_0" else "W0" in + fprintf fmt " Definition w%i_mul_add_n1 :=\n" i; + fprintf fmt + " %sgen_mul_add_n1 w%i %s w%i_op.(znz_WW) w%i_0W w%i_mul_add.\n" + "@" i s0 i i i + done; + fprintf fmt "\n"; + + fprintf fmt " Definition mul x y :=\n"; + fprintf fmt " match x, y with\n"; + fprintf fmt " | %s0 wx, %s0 wy =>\n" c c; + fprintf fmt " reduce_1 (w0_mul_c wx wy)\n"; + for j = 1 to size do + fprintf fmt " | %s0 wx, %s%i wy =>\n" c c j; + fprintf fmt " if w0_eq0 wx then zero\n"; + fprintf fmt " else\n"; + fprintf fmt " let (w,r) := w0_mul_add_n1 %i wy wx w_0 in\n" j; + fprintf fmt " if w0_eq0 w then %s%i r\n" c j; + if j = 1 then + fprintf fmt " else %s2 (WW (WW w_0 w) r)\n" c + else if j = size then + fprintf fmt " else %sn 0 (WW (extend%i w0 (WW w_0 w)) r)\n" + c (size-1) + else + fprintf fmt " else %s%i (WW (extend%i w0 (WW w_0 w)) r)\n" + c (j+1) (j-1) + done; + + fprintf fmt " | %s0 wx, %sn n wy =>\n" c c; + fprintf fmt " if w0_eq0 wx then zero\n"; + fprintf fmt " else\n"; + fprintf fmt " let (w,r) := w%i_mul_add_n1 (S n) wy " size; + fprintf fmt "(extend%i w0 (WW w_0 wx)) W0 in\n" (size - 1); + fprintf fmt " if w%i_eq0 w then %sn n r\n" size c; + fprintf fmt " else %sn (S n) (WW (extend n w%i (WW W0 w)) r)\n" c size; + + for i = 1 to size do + fprintf fmt " | %s%i wx, %s0 wy =>\n" c i c; + fprintf fmt " if w0_eq0 wy then zero\n"; + fprintf fmt " else\n"; + fprintf fmt " let (w,r) := w0_mul_add_n1 %i wx wy w_0 in\n" i; + fprintf fmt " if w0_eq0 w then %s%i r\n" c i; + if i = 1 then + fprintf fmt " else %s2 (WW (WW w_0 w) r)\n" c + else if i = size then + fprintf fmt " else %sn 0 (WW (extend%i w0 (WW w_0 w)) r)\n" + c (size-1) + else + fprintf fmt " else %s%i (WW (extend%i w0 (WW w_0 w)) r)\n" + c (i+1) (i-1); + for j = 1 to size do + fprintf fmt " | %s%i wx, %s%i wy =>\n" c i c j; + if i = j then begin + if i = size then fprintf fmt " %sn 0 (w%i_mul_c wx wy)\n" c i + else fprintf fmt " %s%i (w%i_mul_c wx wy)\n" c (i+1) i + end else begin + let min,max, wmin, wmax = + if i < j then i, j, "wx", "wy" else j, i, "wy", "wx" in + fprintf fmt " let (w,r) := w%i_mul_add_n1 %i %s %s W0 in\n" + min (max-min) wmax wmin; + fprintf fmt " if w%i_eq0 w then %s%i r\n" min c max; + fprintf fmt " else "; + if max = size then fprintf fmt "%sn 0 " c + else fprintf fmt "%s%i " c (max+1); + fprintf fmt "(WW (extend%i w%i w) r)\n" (max - min) (min-1); + end + done; + fprintf fmt " | %s%i wx, %sn n wy =>\n" c i c; + fprintf fmt " let (w,r) := w%i_mul_add_n1 (S n) wy " size; + if i = size then fprintf fmt "wx W0 in\n" + else + fprintf fmt "(extend%i w%i wx) W0 in\n" (size - i) (i-1); + fprintf fmt " if w%i_eq0 w then %sn n r\n" size c; + fprintf fmt " else %sn (S n) (WW (extend n w%i (WW W0 w)) r)\n" c size + + done; + fprintf fmt " | %sn n wx, %s0 wy =>\n" c c; + fprintf fmt " if w0_eq0 wy then zero\n"; + fprintf fmt " else\n"; + fprintf fmt " let (w,r) := w%i_mul_add_n1 (S n) wx " size; + fprintf fmt "(extend%i w0 (WW w_0 wy)) W0 in\n" (size - 1); + fprintf fmt " if w%i_eq0 w then %sn n r\n" size c; + fprintf fmt " else %sn (S n) (WW (extend n w%i (WW W0 w)) r)\n" c size; + + for j = 1 to size do + fprintf fmt " | %sn n wx, %s%i wy =>\n" c c j; + fprintf fmt " let (w,r) := w%i_mul_add_n1 (S n) wx " size; + if j = size then fprintf fmt "wy W0 in\n" + else + fprintf fmt "(extend%i w%i wy) W0 in\n" (size - j) (j-1); + fprintf fmt " if w%i_eq0 w then %sn n r\n" size c; + fprintf fmt " else %sn (S n) (WW (extend n w%i (WW W0 w)) r)\n" c size + done; + + fprintf fmt " | %sn n wx, %sn m wy =>\n" c c; + fprintf fmt " match extend_to_max w%i n m wx wy with\n" size; + fprintf fmt " | inl wx' =>\n"; + fprintf fmt " let op := make_op m in\n"; + fprintf fmt " reduce_n (S m) (op.(znz_mul_c) wx' wy)\n"; + fprintf fmt " | inr wy' =>\n"; + fprintf fmt " let op := make_op n in\n"; + fprintf fmt " reduce_n (S n) (op.(znz_mul_c) wx wy')\n"; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + (* Square *) + for i = 0 to size do + fprintf fmt " Definition w%i_square_c := w%i_op.(znz_square_c).\n" i i + done; + fprintf fmt "\n"; + + fprintf fmt " Definition square x :=\n"; + fprintf fmt " match x with\n"; + fprintf fmt " | %s0 wx => reduce_1 (w0_square_c wx)\n" c; + for i = 1 to size - 1 do + fprintf fmt " | %s%i wx => %s%i (w%i_square_c wx)\n" c i c (i+1) i + done; + fprintf fmt " | %s%i wx => %sn 0 (w%i_square_c wx)\n" c size c size; + fprintf fmt " | %sn n wx =>\n" c; + fprintf fmt " let op := make_op n in\n"; + fprintf fmt " %sn (S n) (op.(znz_square_c) wx)\n" c; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Fixpoint power_pos (x:%s) (p:positive) {struct p} : %s :=\n" + t t; + fprintf fmt " match p with\n"; + fprintf fmt " | xH => x\n"; + fprintf fmt " | xO p => square (power_pos x p)\n"; + fprintf fmt " | xI p => mul (square (power_pos x p)) x\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + (* Square root *) + for i = 0 to size do + fprintf fmt " Definition w%i_sqrt := w%i_op.(znz_sqrt).\n" i i + done; + fprintf fmt "\n"; + + fprintf fmt " Definition sqrt x :=\n"; + fprintf fmt " match x with\n"; + for i = 0 to size do + fprintf fmt " | %s%i wx => reduce_%i (w%i_sqrt wx)\n" c i i i; + done; + fprintf fmt " | %sn n wx =>\n" c; + fprintf fmt " let op := make_op n in\n"; + fprintf fmt " reduce_n n (op.(znz_sqrt) wx)\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + + (* Division *) + for i = 0 to size do + fprintf fmt " Definition w%i_div_gt := w%i_op.(znz_div_gt).\n" i i + done; + fprintf fmt "\n"; + + for i = 0 to size do + fprintf fmt " Definition w%i_divn1 :=\n" i; + fprintf fmt " gen_divn1 w%i_op.(znz_digits) w%i_op.(znz_0)\n" i i; + fprintf fmt " w%i_op.(znz_WW) w%i_op.(znz_head0)\n" i i; + fprintf fmt " w%i_op.(znz_add_mul_div) w%i_op.(znz_div21).\n" i i + done; + fprintf fmt "\n"; + + fprintf fmt " Definition div_gt x y :=\n"; + fprintf fmt " match x, y with\n"; + for i = 0 to size do + for j = 0 to size do + fprintf fmt " | %s%i wx, %s%i wy =>" c i c j; + if i = j then + fprintf fmt + " let (q, r):= w%i_div_gt wx wy in (reduce_%i q, reduce_%i r)\n" + i i i + else if i > j then + fprintf fmt + " let (q, r):= w%i_divn1 %i wx wy in (reduce_%i q, reduce_%i r)\n" + j (i-j) i j + else begin (* i < j *) + fprintf fmt + "\n let wx':= GenBase.extend w%i_0W %i wx in\n" + i (j-i-1); + fprintf fmt " let (q, r):= w%i_div_gt wx' wy in\n" j; + fprintf fmt " (reduce_%i q, reduce_%i r)\n" j j; + end + done; + fprintf fmt " | %s%i wx, %sn n wy =>\n" c i c; + fprintf fmt + " let wx':= extend n w%i (GenBase.extend w%i_0W %i wx) in\n" + size i (size-i); + fprintf fmt " let (q, r):= (make_op n).(znz_div_gt) wx' wy in\n"; + fprintf fmt " (reduce_n n q, reduce_n n r)\n"; + done; + for j = 0 to size do + fprintf fmt " | %sn n wx, %s%i wy =>\n" c c j; + if j < size then + fprintf fmt " let wy':= GenBase.extend w%i_0W %i wy in\n" + j (size-j-1) + else + fprintf fmt " let wy':= wy in\n"; + fprintf fmt " let (q, r):= w%i_divn1 (S n) wx wy' in\n" size; + fprintf fmt " (reduce_n n q, reduce_%i r)\n" size + done; + fprintf fmt " | %sn n wx, %sn m wy =>\n" c c; + fprintf fmt " match extend_to_max w%i n m wx wy with\n" size; + fprintf fmt " | inl wx' =>\n"; + fprintf fmt " let (q, r):= (make_op m).(znz_div) wx' wy in\n"; + fprintf fmt " (reduce_n m q, reduce_n m r)\n"; + fprintf fmt " | inr wy' =>\n"; + fprintf fmt " let (q, r):= (make_op n).(znz_div) wx wy' in\n"; + fprintf fmt " (reduce_n n q, reduce_n n r)\n"; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition div_eucl x y :=\n"; + fprintf fmt " match compare x y with\n"; + fprintf fmt " | Eq => (one, zero)\n"; + fprintf fmt " | Lt => (zero, x)\n"; + fprintf fmt " | Gt => div_gt x y\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition div x y := fst (div_eucl x y).\n"; + fprintf fmt "\n"; + + (* Modulo *) + for i = 0 to size do + fprintf fmt " Definition w%i_mod_gt := w%i_op.(znz_mod_gt).\n" i i + done; + fprintf fmt "\n"; + + for i = 0 to size do + fprintf fmt " Definition w%i_modn1 :=\n" i; + fprintf fmt " gen_modn1 w%i_op.(znz_digits) w%i_op.(znz_0)\n" i i; + fprintf fmt + " w%i_op.(znz_head0) w%i_op.(znz_add_mul_div) w%i_op.(znz_div21).\n" + i i i + done; + fprintf fmt "\n"; + + fprintf fmt " Definition mod_gt x y :=\n"; + fprintf fmt " match x, y with\n"; + for i = 0 to size do + for j = 0 to size do + fprintf fmt " | %s%i wx, %s%i wy =>" + c i c j; + if i = j then + fprintf fmt " reduce_%i (w%i_mod_gt wx wy)\n" i i + else if i > j then + fprintf fmt + " reduce_%i (w%i_modn1 %i wx wy)\n" j j (i-j) + else begin (* i < j *) + fprintf fmt + "\n let wx':= GenBase.extend w%i_0W %i wx in\n" + i (j-i-1); + fprintf fmt " reduce_%i (w%i_mod_gt wx' wy)\n" j j; + end + done; + fprintf fmt " | %s%i wx, %sn n wy =>\n" c i c; + fprintf fmt + " let wx':= extend n w%i (GenBase.extend w%i_0W %i wx) in\n" + size i (size-i); + fprintf fmt " reduce_n n ((make_op n).(znz_mod_gt) wx' wy)\n"; + done; + for j = 0 to size do + fprintf fmt " | %sn n wx, %s%i wy =>\n" c c j; + if j < size then + fprintf fmt " let wy':= GenBase.extend w%i_0W %i wy in\n" + j (size-j-1) + else + fprintf fmt " let wy':= wy in\n"; + fprintf fmt " reduce_%i (w%i_modn1 (S n) wx wy')\n" size size; + done; + fprintf fmt " | %sn n wx, %sn m wy =>\n" c c; + fprintf fmt " match extend_to_max w%i n m wx wy with\n" size; + fprintf fmt " | inl wx' =>\n"; + fprintf fmt " reduce_n m ((make_op m).(znz_mod_gt) wx' wy)\n"; + fprintf fmt " | inr wy' =>\n"; + fprintf fmt " reduce_n n ((make_op n).(znz_mod_gt) wx wy')\n"; + fprintf fmt " end\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition modulo x y := \n"; + fprintf fmt " match compare x y with\n"; + fprintf fmt " | Eq => zero\n"; + fprintf fmt " | Lt => x\n"; + fprintf fmt " | Gt => mod_gt x y\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + (* Definition du gcd *) + fprintf fmt " Definition digits x :=\n"; + fprintf fmt " match x with\n"; + for i = 0 to size do + fprintf fmt " | %s%i _ => w%i_op.(znz_digits)\n" c i i; + done; + fprintf fmt " | %sn n _ => (make_op n).(znz_digits)\n" c; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition gcd_gt_body a b cont :=\n"; + fprintf fmt " match compare b zero with\n"; + fprintf fmt " | Gt =>\n"; + fprintf fmt " let r := mod_gt a b in\n"; + fprintf fmt " match compare r zero with\n"; + fprintf fmt " | Gt => cont r (mod_gt b r)\n"; + fprintf fmt " | _ => b\n"; + fprintf fmt " end\n"; + fprintf fmt " | _ => a\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Fixpoint gcd_gt (p:positive) (cont:%s->%s->%s) (a b:%s) {struct p} : %s :=\n" t t t t t; + fprintf fmt " gcd_gt_body a b\n"; + fprintf fmt " (fun a b =>\n"; + fprintf fmt " match p with\n"; + fprintf fmt " | xH => cont a b\n"; + fprintf fmt " | xO p => gcd_gt p (gcd_gt p cont) a b\n"; + fprintf fmt " | xI p => gcd_gt p (gcd_gt p cont) a b\n"; + fprintf fmt " end).\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition gcd_cont a b :=\n"; + fprintf fmt " match compare one b with\n"; + fprintf fmt " | Eq => one\n"; + fprintf fmt " | _ => a\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition gcd a b :=\n"; + fprintf fmt " match compare a b with\n"; + fprintf fmt " | Eq => a\n"; + fprintf fmt " | Lt => gcd_gt (digits b) gcd_cont b a\n"; + fprintf fmt " | Gt => gcd_gt (digits a) gcd_cont a b\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition of_pos x :=\n"; + fprintf fmt " let h := nat_of_P (pheight x) in\n"; + fprintf fmt " match h with\n"; + let rec print_S s fmt i = + if i = 0 then fprintf fmt "%s" s + else fprintf fmt "(S %a)" (print_S s) (i-1) + in + for i = 0 to size do + fprintf fmt " | "; + print_S "O" fmt i; + fprintf fmt " => %s%i (snd (w%i_op.(znz_of_pos) x))\n" "reduce_" i i + done; + fprintf fmt " | _ =>\n"; + fprintf fmt " let n := minus h %i in\n" (size+1); + fprintf fmt " %sn n (snd ((make_op n).(znz_of_pos) x))\n" "reduce_"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition of_N x :=\n"; + fprintf fmt " match x with\n"; + fprintf fmt " | BinNat.N0 => zero\n"; + fprintf fmt " | Npos p => of_pos p\n"; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + fprintf fmt " Definition to_Z x :=\n"; + fprintf fmt " match x with\n"; + for i = 0 to size do + fprintf fmt " | %s%i wx => w%i_op.(znz_to_Z) wx\n" c i i + done; + fprintf fmt " | %sn n wx => (make_op n).(znz_to_Z) wx\n" c; + fprintf fmt " end.\n"; + fprintf fmt "\n"; + + + fprintf fmt "End Make.\n"; + fprintf fmt "\n"; + pp_print_flush fmt () + + + +let _ = print_Make () + + diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 433b561c1..1eb1f8986 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -976,6 +976,18 @@ let vernac_print = function pp (Notation.pr_visibility (Constrextern.without_symbols pr_lrawconstr) s) | PrintAbout qid -> msgnl (print_about qid) | PrintImplicit qid -> msg (print_impargs qid) +(*spiwack: prints all the axioms and section variables used by a term *) + | PrintNeededAssumptions qid -> + let cstr = constr_of_reference (global qid) + in + let nassumptions = Environ.needed_assumptions cstr + (Global.env ()) + in + msg + (try + Printer.pr_assumptionset (Global.env ()) nassumptions + with Not_found -> + pr_reference qid ++ str " is closed under the global context") let global_module r = let (loc,qid) = qualid_of_reference r in diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 5c1b13855..9714ffd6c 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -64,6 +64,7 @@ type printable = | PrintVisibility of string option | PrintAbout of reference | PrintImplicit of reference + | PrintNeededAssumptions of reference type search_about_item = | SearchRef of reference |