From 2d44c8246eccba7c1c452cbfbc6751cd222d0a6a Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sat, 12 Sep 2020 09:10:26 +0200 Subject: Renaming Numeral.v into Number.v --- doc/sphinx/language/core/basic.rst | 2 +- doc/sphinx/user-extensions/syntax-extensions.rst | 50 +++++------ doc/stdlib/hidden-files | 1 + doc/stdlib/index-list.html.template | 2 +- plugins/syntax/numeral.ml | 2 +- test-suite/output/Notations4.v | 4 +- test-suite/output/NumberNotations.out | 12 +-- test-suite/output/NumberNotations.v | 84 +++++++++--------- test-suite/output/Search.out | 104 +++++++++++------------ test-suite/output/SearchHead.out | 6 +- test-suite/output/SearchPattern.out | 8 +- test-suite/output/ZSyntax.v | 2 +- test-suite/output/bug_12159.v | 6 +- test-suite/success/NumberNotationsNoLocal.v | 12 +++ test-suite/success/NumeralNotationsNoLocal.v | 12 --- theories/Init/Nat.v | 20 ++--- theories/Init/Number.v | 33 +++++++ theories/Init/Numeral.v | 67 ++++++++++----- theories/Init/Prelude.v | 9 +- theories/NArith/BinNatDef.v | 16 ++-- theories/Numbers/AltBinNotations.v | 2 +- theories/PArith/BinPosDef.v | 16 ++-- theories/QArith/QArith_base.v | 10 +-- theories/ZArith/BinIntDef.v | 14 +-- 24 files changed, 275 insertions(+), 219 deletions(-) create mode 100644 test-suite/success/NumberNotationsNoLocal.v delete mode 100644 test-suite/success/NumeralNotationsNoLocal.v create mode 100644 theories/Init/Number.v diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 29a2b40162..dfa2aaf8ff 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -113,7 +113,7 @@ Identifiers Numbers Numbers are sequences of digits with an optional fractional part - and exponent, optionally preceded by a minus sign. Hexadecimal numerals + and exponent, optionally preceded by a minus sign. Hexadecimal numbers start with ``0x`` or ``0X``. :n:`@bigint` are integers; numbers without fractional nor exponent parts. :n:`@bignat` are non-negative integers. Underscores embedded in the digits are ignored, for example diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 06018304ab..f982898335 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1571,32 +1571,32 @@ Number notations parsing and printing functions, respectively. The parsing function :n:`@qualid__parse` should have one of the following types: - * :n:`Numeral.int -> @qualid__type` - * :n:`Numeral.int -> option @qualid__type` - * :n:`Numeral.uint -> @qualid__type` - * :n:`Numeral.uint -> option @qualid__type` + * :n:`Number.int -> @qualid__type` + * :n:`Number.int -> option @qualid__type` + * :n:`Number.uint -> @qualid__type` + * :n:`Number.uint -> option @qualid__type` * :n:`Z -> @qualid__type` * :n:`Z -> option @qualid__type` - * :n:`Numeral.numeral -> @qualid__type` - * :n:`Numeral.numeral -> option @qualid__type` + * :n:`Number.number -> @qualid__type` + * :n:`Number.number -> option @qualid__type` And the printing function :n:`@qualid__print` should have one of the following types: - * :n:`@qualid__type -> Numeral.int` - * :n:`@qualid__type -> option Numeral.int` - * :n:`@qualid__type -> Numeral.uint` - * :n:`@qualid__type -> option Numeral.uint` + * :n:`@qualid__type -> Number.int` + * :n:`@qualid__type -> option Number.int` + * :n:`@qualid__type -> Number.uint` + * :n:`@qualid__type -> option Number.uint` * :n:`@qualid__type -> Z` * :n:`@qualid__type -> option Z` - * :n:`@qualid__type -> Numeral.numeral` - * :n:`@qualid__type -> option Numeral.numeral` + * :n:`@qualid__type -> Number.number` + * :n:`@qualid__type -> option Number.number` .. deprecated:: 8.12 - Numeral notations on :g:`Decimal.uint`, :g:`Decimal.int` and - :g:`Decimal.decimal` are replaced respectively by numeral - notations on :g:`Numeral.uint`, :g:`Numeral.int` and - :g:`Numeral.numeral`. + Number notations on :g:`Decimal.uint`, :g:`Decimal.int` and + :g:`Decimal.decimal` are replaced respectively by number + notations on :g:`Number.uint`, :g:`Number.int` and + :g:`Number.number`. When parsing, the application of the parsing function :n:`@qualid__parse` to the number will be fully reduced, and universes @@ -1620,7 +1620,7 @@ Number notations returns :n:`(@qualid__parse m)` when parsing a literal :n:`m` that's greater than :n:`@bignat` rather than reducing it to a normal form. Here :g:`m` will be a - :g:`Numeral.int`, :g:`Numeral.uint`, :g:`Z` or :g:`Numeral.numeral`, depending on the + :g:`Number.int`, :g:`Number.uint`, :g:`Z` or :g:`Number.number`, depending on the type of the parsing function :n:`@qualid__parse`. This allows for a more compact representation of literals in types such as :g:`nat`, and limits parse failures due to stack overflow. Note that a @@ -1644,31 +1644,31 @@ Number notations .. exn:: Cannot interpret this number as a value of type @type - The numeral notation registered for :token:`type` does not support + The number notation registered for :token:`type` does not support the given number. This error is given when the interpretation function returns :g:`None`, or if the interpretation is registered only for integers or non-negative integers, and the given number has a fractional or exponent part or is negative. - .. exn:: @qualid__parse should go from Numeral.int to @type or (option @type). Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first). + .. exn:: @qualid__parse should go from Number.int to @type or (option @type). Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first). The parsing function given to the :cmd:`Number Notation` vernacular is not of the right type. - .. exn:: @qualid__print should go from @type to Numeral.int or (option Numeral.int). Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first). + .. exn:: @qualid__print should go from @type to Number.int or (option Number.int). Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first). The printing function given to the :cmd:`Number Notation` vernacular is not of the right type. - .. exn:: Unexpected term @term while parsing a numeral notation. + .. exn:: Unexpected term @term while parsing a number notation. Parsing functions must always return ground terms, made up of applications of constructors, inductive types, and primitive integers. Parsing functions may not return terms containing axioms, bare (co)fixpoints, lambdas, etc. - .. exn:: Unexpected non-option term @term while parsing a numeral notation. + .. exn:: Unexpected non-option term @term while parsing a number notation. Parsing functions expected to return an :g:`option` must always return a concrete :g:`Some` or :g:`None` when applied to a @@ -1741,16 +1741,16 @@ String notations concrete string expressed as a decimal. They may not return opaque constants. -The following errors apply to both string and numeral notations: +The following errors apply to both string and number notations: .. exn:: @type is not an inductive type. - String and numeral notations can only be declared for inductive types with no + String and number notations can only be declared for inductive types with no arguments. .. exn:: Cannot interpret in @scope_name because @qualid could not be found in the current environment. - The inductive type used to register the string or numeral notation is no + The inductive type used to register the string or number notation is no longer available in the environment. Most likely, this is because the notation was declared inside a functor for an inductive type inside the functor. This use case is not currently diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 4d2972ef8f..e4f0967794 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -1,3 +1,4 @@ +theories/Init/Numeral.v theories/btauto/Algebra.v theories/btauto/Btauto.v theories/btauto/Reflect.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 7c1328916b..e42066d2ce 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -22,7 +22,7 @@ through the Require Import command.

theories/Init/Nat.v theories/Init/Decimal.v theories/Init/Hexadecimal.v - theories/Init/Numeral.v + theories/Init/Number.v theories/Init/Peano.v theories/Init/Specif.v theories/Init/Tactics.v diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 2db76719b8..fbf43be91f 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -64,7 +64,7 @@ let locate_numeral () = let hex = "num.hexadecimal.type" in let int = "num.num_int.type" in let uint = "num.num_uint.type" in - let num = "num.numeral.type" in + let num = "num.number.type" in if Coqlib.has_ref dint && Coqlib.has_ref duint && Coqlib.has_ref dec && Coqlib.has_ref hint && Coqlib.has_ref huint && Coqlib.has_ref hex && Coqlib.has_ref int && Coqlib.has_ref uint && Coqlib.has_ref num diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 6dadd8c7fe..84913abcdc 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -124,7 +124,7 @@ Check r 2 3. End I. Require Import Coq.Numbers.Cyclic.Int63.Int63. -Module NumeralNotations. +Module NumberNotations. Module Test17. (** Test int63 *) Declare Scope test17_scope. @@ -134,7 +134,7 @@ Module NumeralNotations. Number Notation myint63 of_int to_int : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. -End NumeralNotations. +End NumberNotations. Module K. diff --git a/test-suite/output/NumberNotations.out b/test-suite/output/NumberNotations.out index 8065c8d311..b00fd3b485 100644 --- a/test-suite/output/NumberNotations.out +++ b/test-suite/output/NumberNotations.out @@ -1,9 +1,9 @@ The command has indeed failed with message: -Unexpected term (nat -> nat) while parsing a numeral notation. +Unexpected term (nat -> nat) while parsing a number notation. The command has indeed failed with message: -Unexpected non-option term opaque4 while parsing a numeral notation. +Unexpected non-option term opaque4 while parsing a number notation. The command has indeed failed with message: -Unexpected term (fun (A : Type) (x : A) => x) while parsing a numeral +Unexpected term (fun (A : Type) (x : A) => x) while parsing a number notation. let v := 0%ppp in v : punit : punit @@ -32,7 +32,7 @@ Warning: To avoid stack overflow, large numbers in punit are interpreted as applications of pto_punits. [abstract-large-number,numbers] The command has indeed failed with message: In environment -v := pto_punits (Numeral.UIntDec (Decimal.D1 Decimal.Nil)) : punit +v := pto_punits (Number.UIntDec (Decimal.D1 Decimal.Nil)) : punit The term "v" has type "punit@{Set}" while it is expected to have type "punit@{u}". S @@ -61,7 +61,7 @@ The command has indeed failed with message: In environment v := 0 : nat The term "v" has type "nat" while it is expected to have type "wuint". - = {| unwrap := Numeral.UIntDec (Decimal.D0 Decimal.Nil) |} + = {| unwrap := Number.UIntDec (Decimal.D0 Decimal.Nil) |} : wuint let v := 0%wuint8' in v : wuint : wuint @@ -82,7 +82,7 @@ function (of_uint) targets an option type. The command has indeed failed with message: The 'abstract after' directive has no effect when the parsing function (of_uint) targets an option type. [abstract-large-number-no-op,numbers] -let v := of_uint (Numeral.UIntDec (Decimal.D1 Decimal.Nil)) in v : unit +let v := of_uint (Number.UIntDec (Decimal.D1 Decimal.Nil)) in v : unit : unit let v := 0%test13 in v : unit : unit diff --git a/test-suite/output/NumberNotations.v b/test-suite/output/NumberNotations.v index e411005da3..af0aa895d1 100644 --- a/test-suite/output/NumberNotations.v +++ b/test-suite/output/NumberNotations.v @@ -5,17 +5,17 @@ Declare Scope opaque_scope. (* https://github.com/coq/coq/pull/8064#discussion_r202497516 *) Module Test1. Axiom hold : forall {A B C}, A -> B -> C. - Definition opaque3 (x : Numeral.int) : Numeral.int := hold x (fix f (x : nat) : nat := match x with O => O | S n => S (f n) end). - Number Notation Numeral.int opaque3 opaque3 : opaque_scope. + Definition opaque3 (x : Number.int) : Number.int := hold x (fix f (x : nat) : nat := match x with O => O | S n => S (f n) end). + Number Notation Number.int opaque3 opaque3 : opaque_scope. Delimit Scope opaque_scope with opaque. Fail Check 1%opaque. End Test1. (* https://github.com/coq/coq/pull/8064#discussion_r202497990 *) Module Test2. - Axiom opaque4 : option Numeral.int. - Definition opaque6 (x : Numeral.int) : option Numeral.int := opaque4. - Number Notation Numeral.int opaque6 opaque6 : opaque_scope. + Axiom opaque4 : option Number.int. + Definition opaque6 (x : Number.int) : option Number.int := opaque4. + Number Notation Number.int opaque6 opaque6 : opaque_scope. Delimit Scope opaque_scope with opaque. Open Scope opaque_scope. Fail Check 1%opaque. @@ -24,8 +24,8 @@ End Test2. Declare Scope silly_scope. Module Test3. - Inductive silly := SILLY (v : Numeral.uint) (f : forall A, A -> A). - Definition to_silly (v : Numeral.uint) := SILLY v (fun _ x => x). + Inductive silly := SILLY (v : Number.uint) (f : forall A, A -> A). + Definition to_silly (v : Number.uint) := SILLY v (fun _ x => x). Definition of_silly (v : silly) := match v with SILLY v _ => v end. Number Notation silly to_silly of_silly : silly_scope. Delimit Scope silly_scope with silly. @@ -45,15 +45,15 @@ Module Test4. Declare Scope upp. Declare Scope ppps. Polymorphic NonCumulative Inductive punit := ptt. - Polymorphic Definition pto_punit (v : Numeral.uint) : option punit := match Nat.of_num_uint v with O => Some ptt | _ => None end. - Polymorphic Definition pto_punit_all (v : Numeral.uint) : punit := ptt. - Polymorphic Definition pof_punit (v : punit) : Numeral.uint := Nat.to_num_uint 0. - Definition to_punit (v : Numeral.uint) : option punit := match Nat.of_num_uint v with O => Some ptt | _ => None end. - Definition of_punit (v : punit) : Numeral.uint := Nat.to_num_uint 0. - Polymorphic Definition pto_unit (v : Numeral.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. - Polymorphic Definition pof_unit (v : unit) : Numeral.uint := Nat.to_num_uint 0. - Definition to_unit (v : Numeral.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. - Definition of_unit (v : unit) : Numeral.uint := Nat.to_num_uint 0. + Polymorphic Definition pto_punit (v : Number.uint) : option punit := match Nat.of_num_uint v with O => Some ptt | _ => None end. + Polymorphic Definition pto_punit_all (v : Number.uint) : punit := ptt. + Polymorphic Definition pof_punit (v : punit) : Number.uint := Nat.to_num_uint 0. + Definition to_punit (v : Number.uint) : option punit := match Nat.of_num_uint v with O => Some ptt | _ => None end. + Definition of_punit (v : punit) : Number.uint := Nat.to_num_uint 0. + Polymorphic Definition pto_unit (v : Number.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. + Polymorphic Definition pof_unit (v : unit) : Number.uint := Nat.to_num_uint 0. + Definition to_unit (v : Number.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. + Definition of_unit (v : unit) : Number.uint := Nat.to_num_uint 0. Number Notation punit to_punit of_punit : pto. Number Notation punit pto_punit of_punit : ppo. Number Notation punit to_punit pof_punit : ptp. @@ -96,7 +96,7 @@ Module Test5. End Test5. Module Test6. - (* Check that numeral notations on enormous terms don't take forever to print/parse *) + (* Check that number notations on enormous terms don't take forever to print/parse *) (* Ackerman definition from https://stackoverflow.com/a/10303475/377022 *) Fixpoint ack (n m : nat) : nat := match n with @@ -113,8 +113,8 @@ Module Test6. Local Set Primitive Projections. Record > wnat := wrap { unwrap :> nat }. - Definition to_uint (x : wnat) : Numeral.uint := Nat.to_num_uint x. - Definition of_uint (x : Numeral.uint) : wnat := Nat.of_num_uint x. + Definition to_uint (x : wnat) : Number.uint := Nat.to_num_uint x. + Definition of_uint (x : Number.uint) : wnat := Nat.of_num_uint x. Module Export Scopes. Declare Scope wnat_scope. Delimit Scope wnat_scope with wnat. @@ -138,7 +138,7 @@ End Test6_2. Module Test7. Local Set Primitive Projections. - Record wuint := wrap { unwrap : Numeral.uint }. + Record wuint := wrap { unwrap : Number.uint }. Declare Scope wuint_scope. Delimit Scope wuint_scope with wuint. Number Notation wuint wrap unwrap : wuint_scope. @@ -148,7 +148,7 @@ End Test7. Module Test8. Local Set Primitive Projections. - Record wuint := wrap { unwrap : Numeral.uint }. + Record wuint := wrap { unwrap : Number.uint }. Declare Scope wuint8_scope. Declare Scope wuint8'_scope. Delimit Scope wuint8_scope with wuint8. @@ -177,7 +177,7 @@ Module Test9. Delimit Scope wuint9'_scope with wuint9'. Section with_let. Local Set Primitive Projections. - Record wuint := wrap { unwrap : Numeral.uint }. + Record wuint := wrap { unwrap : Number.uint }. Let wrap' := wrap. Let unwrap' := unwrap. Local Notation wrap'' := wrap. @@ -194,8 +194,8 @@ End Test9. Module Test10. (* Test that it is only a warning to add abstract after to an optional parsing function *) Definition to_uint (v : unit) := Nat.to_num_uint 0. - Definition of_uint (v : Numeral.uint) := match Nat.of_num_uint v with O => Some tt | _ => None end. - Definition of_any_uint (v : Numeral.uint) := tt. + Definition of_uint (v : Number.uint) := match Nat.of_num_uint v with O => Some tt | _ => None end. + Definition of_any_uint (v : Number.uint) := tt. Declare Scope unit_scope. Declare Scope unit2_scope. Delimit Scope unit_scope with unit. @@ -209,11 +209,11 @@ Module Test10. End Test10. Module Test12. - (* Test for numeral notations on context variables *) + (* Test for number notations on context variables *) Declare Scope test12_scope. Delimit Scope test12_scope with test12. Section test12. - Context (to_uint : unit -> Numeral.uint) (of_uint : Numeral.uint -> unit). + Context (to_uint : unit -> Number.uint) (of_uint : Number.uint -> unit). Number Notation unit of_uint to_uint : test12_scope. Check let v := 1%test12 in v : unit. @@ -221,15 +221,15 @@ Module Test12. End Test12. Module Test13. - (* Test for numeral notations on notations which do not denote references *) + (* Test for number notations on notations which do not denote references *) Declare Scope test13_scope. Declare Scope test13'_scope. Declare Scope test13''_scope. Delimit Scope test13_scope with test13. Delimit Scope test13'_scope with test13'. Delimit Scope test13''_scope with test13''. - Definition to_uint (x y : unit) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : unit := tt. + Definition to_uint (x y : unit) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : unit := tt. Definition to_uint_good := to_uint tt. Notation to_uint' := (to_uint tt). Notation to_uint'' := (to_uint _). @@ -242,7 +242,7 @@ Module Test13. End Test13. Module Test14. - (* Test that numeral notations follow [Import], not [Require], and + (* Test that number notations follow [Import], not [Require], and also test that [Local Number Notation]s do not escape modules nor sections. *) Declare Scope test14_scope. @@ -254,8 +254,8 @@ Module Test14. Delimit Scope test14''_scope with test14''. Delimit Scope test14'''_scope with test14'''. Module Inner. - Definition to_uint (x : unit) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : unit := tt. + Definition to_uint (x : unit) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : unit := tt. Local Number Notation unit of_uint to_uint : test14_scope. Global Number Notation unit of_uint to_uint : test14'_scope. Check let v := 0%test14 in v : unit. @@ -267,8 +267,8 @@ Module Test14. Fail Check let v := 0%test14 in v : unit. Check let v := 0%test14' in v : unit. Section InnerSection. - Definition to_uint (x : unit) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : unit := tt. + Definition to_uint (x : unit) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : unit := tt. Local Number Notation unit of_uint to_uint : test14''_scope. Fail Global Number Notation unit of_uint to_uint : test14'''_scope. Check let v := 0%test14'' in v : unit. @@ -283,8 +283,8 @@ Module Test15. Declare Scope test15_scope. Delimit Scope test15_scope with test15. Module Inner. - Definition to_uint (x : unit) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : unit := tt. + Definition to_uint (x : unit) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : unit := tt. Number Notation unit of_uint to_uint : test15_scope. Check let v := 0%test15 in v : unit. End Inner. @@ -306,8 +306,8 @@ Module Test16. End A. Module F (a : A). Inductive Foo := foo (_ : a.T). - Definition to_uint (x : Foo) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : Foo := foo a.t. + Definition to_uint (x : Foo) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : Foo := foo a.t. Global Number Notation Foo of_uint to_uint : test16_scope. Check let v := 0%test16 in v : Foo. End F. @@ -352,8 +352,8 @@ Module Test18. Definition Q_of_nat (x : nat) : Q := {| num := x ; den := 1 ; reduced := transparentify (nat_eq_dec _ _) (gcd_good _) |}. Definition nat_of_Q (x : Q) : option nat := if Nat.eqb x.(den) 1 then Some (x.(num)) else None. - Definition Q_of_uint (x : Numeral.uint) : Q := Q_of_nat (Nat.of_num_uint x). - Definition uint_of_Q (x : Q) : option Numeral.uint + Definition Q_of_uint (x : Number.uint) : Q := Q_of_nat (Nat.of_num_uint x). + Definition uint_of_Q (x : Q) : option Number.uint := option_map Nat.to_num_uint (nat_of_Q x). Number Notation Q Q_of_uint uint_of_Q : Q_scope. @@ -411,7 +411,7 @@ Module Test20. Record > ty := { t : Type ; kt : known_type t }. - Definition ty_of_uint (x : Numeral.uint) : option ty + Definition ty_of_uint (x : Number.uint) : option ty := match Nat.of_num_uint x with | 0 => @Some ty zero | 1 => @Some ty one @@ -421,7 +421,7 @@ Module Test20. | 5 => @Some ty type | _ => None end. - Definition uint_of_ty (x : ty) : Numeral.uint + Definition uint_of_ty (x : ty) : Number.uint := Nat.to_num_uint match kt x with | prop => 3 | set => 4 diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 09feca71e7..914e7f88c6 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -30,15 +30,15 @@ implb: bool -> bool -> bool Nat.odd: nat -> bool Nat.even: nat -> bool BoolSpec: Prop -> Prop -> bool -> Prop -Numeral.numeral_beq: Numeral.numeral -> Numeral.numeral -> bool +Number.number_beq: Number.number -> Number.number -> bool Nat.eqb: nat -> nat -> bool Nat.testbit: nat -> nat -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool -Numeral.uint_beq: Numeral.uint -> Numeral.uint -> bool +Number.uint_beq: Number.uint -> Number.uint -> bool Decimal.uint_beq: Decimal.uint -> Decimal.uint -> bool Hexadecimal.hexadecimal_beq: Hexadecimal.hexadecimal -> Hexadecimal.hexadecimal -> bool -Numeral.int_beq: Numeral.int -> Numeral.int -> bool +Number.int_beq: Number.int -> Number.int -> bool Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Nat.ltb: nat -> nat -> bool Nat.leb: nat -> nat -> bool @@ -64,34 +64,34 @@ eq_true_rec: bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b eq_true_sind: forall P : bool -> SProp, P true -> forall b : bool, eq_true b -> P b -Numeral.internal_uint_dec_bl1: - forall x y : Numeral.uint, Numeral.uint_beq x y = true -> x = y +Number.internal_uint_dec_bl1: + forall x y : Number.uint, Number.uint_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_lb: forall x y : Hexadecimal.hexadecimal, x = y -> Hexadecimal.hexadecimal_beq x y = true Hexadecimal.internal_int_dec_lb0: forall x y : Hexadecimal.int, x = y -> Hexadecimal.int_beq x y = true -Numeral.internal_numeral_dec_lb: - forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true +Number.internal_number_dec_lb: + forall x y : Number.number, x = y -> Number.number_beq x y = true Decimal.internal_decimal_dec_lb: forall x y : Decimal.decimal, x = y -> Decimal.decimal_beq x y = true Hexadecimal.internal_int_dec_bl0: forall x y : Hexadecimal.int, Hexadecimal.int_beq x y = true -> x = y -Numeral.internal_int_dec_lb1: - forall x y : Numeral.int, x = y -> Numeral.int_beq x y = true -Numeral.internal_int_dec_bl1: - forall x y : Numeral.int, Numeral.int_beq x y = true -> x = y +Number.internal_int_dec_lb1: + forall x y : Number.int, x = y -> Number.int_beq x y = true +Number.internal_int_dec_bl1: + forall x y : Number.int, Number.int_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_bl: forall x y : Hexadecimal.hexadecimal, Hexadecimal.hexadecimal_beq x y = true -> x = y -Numeral.internal_uint_dec_lb1: - forall x y : Numeral.uint, x = y -> Numeral.uint_beq x y = true +Number.internal_uint_dec_lb1: + forall x y : Number.uint, x = y -> Number.uint_beq x y = true Decimal.internal_int_dec_bl: forall x y : Decimal.int, Decimal.int_beq x y = true -> x = y Decimal.internal_int_dec_lb: forall x y : Decimal.int, x = y -> Decimal.int_beq x y = true -Numeral.internal_numeral_dec_bl: - forall x y : Numeral.numeral, Numeral.numeral_beq x y = true -> x = y +Number.internal_number_dec_bl: + forall x y : Number.number, Number.number_beq x y = true -> x = y Byte.of_bits: bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) -> Byte.byte @@ -160,21 +160,21 @@ f_equal2_mult: f_equal2_nat: forall (B : Type) (f : nat -> nat -> B) (x1 y1 x2 y2 : nat), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2 -Numeral.internal_numeral_dec_lb: - forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true -Numeral.internal_int_dec_lb1: - forall x y : Numeral.int, x = y -> Numeral.int_beq x y = true -Numeral.internal_numeral_dec_bl: - forall x y : Numeral.numeral, Numeral.numeral_beq x y = true -> x = y +Number.internal_number_dec_lb: + forall x y : Number.number, x = y -> Number.number_beq x y = true +Number.internal_int_dec_lb1: + forall x y : Number.int, x = y -> Number.int_beq x y = true +Number.internal_number_dec_bl: + forall x y : Number.number, Number.number_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_lb: forall x y : Hexadecimal.hexadecimal, x = y -> Hexadecimal.hexadecimal_beq x y = true -Numeral.internal_int_dec_bl1: - forall x y : Numeral.int, Numeral.int_beq x y = true -> x = y -Numeral.internal_uint_dec_lb1: - forall x y : Numeral.uint, x = y -> Numeral.uint_beq x y = true -Numeral.internal_uint_dec_bl1: - forall x y : Numeral.uint, Numeral.uint_beq x y = true -> x = y +Number.internal_int_dec_bl1: + forall x y : Number.int, Number.int_beq x y = true -> x = y +Number.internal_uint_dec_lb1: + forall x y : Number.uint, x = y -> Number.uint_beq x y = true +Number.internal_uint_dec_bl1: + forall x y : Number.uint, Number.uint_beq x y = true -> x = y Decimal.internal_decimal_dec_lb: forall x y : Decimal.decimal, x = y -> Decimal.decimal_beq x y = true Hexadecimal.internal_hexadecimal_dec_bl: @@ -213,18 +213,18 @@ bool_choice: forall [S : Set] [R1 R2 : S -> Prop], (forall x : S, {R1 x} + {R2 x}) -> {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} -Numeral.internal_numeral_dec_lb: - forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true -Numeral.internal_numeral_dec_bl: - forall x y : Numeral.numeral, Numeral.numeral_beq x y = true -> x = y -Numeral.internal_int_dec_lb1: - forall x y : Numeral.int, x = y -> Numeral.int_beq x y = true -Numeral.internal_int_dec_bl1: - forall x y : Numeral.int, Numeral.int_beq x y = true -> x = y -Numeral.internal_uint_dec_lb1: - forall x y : Numeral.uint, x = y -> Numeral.uint_beq x y = true -Numeral.internal_uint_dec_bl1: - forall x y : Numeral.uint, Numeral.uint_beq x y = true -> x = y +Number.internal_number_dec_lb: + forall x y : Number.number, x = y -> Number.number_beq x y = true +Number.internal_number_dec_bl: + forall x y : Number.number, Number.number_beq x y = true -> x = y +Number.internal_int_dec_lb1: + forall x y : Number.int, x = y -> Number.int_beq x y = true +Number.internal_int_dec_bl1: + forall x y : Number.int, Number.int_beq x y = true -> x = y +Number.internal_uint_dec_lb1: + forall x y : Number.uint, x = y -> Number.uint_beq x y = true +Number.internal_uint_dec_bl1: + forall x y : Number.uint, Number.uint_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_lb: forall x y : Hexadecimal.hexadecimal, x = y -> Hexadecimal.hexadecimal_beq x y = true @@ -306,12 +306,12 @@ nat_rect_plus: (nat_rect (fun _ : nat => A) x (fun _ : nat => f) m) (fun _ : nat => f) n Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat -Numeral.internal_numeral_dec_bl: - forall x y : Numeral.numeral, Numeral.numeral_beq x y = true -> x = y -Numeral.internal_int_dec_bl1: - forall x y : Numeral.int, Numeral.int_beq x y = true -> x = y -Numeral.internal_uint_dec_bl1: - forall x y : Numeral.uint, Numeral.uint_beq x y = true -> x = y +Number.internal_number_dec_bl: + forall x y : Number.number, Number.number_beq x y = true -> x = y +Number.internal_int_dec_bl1: + forall x y : Number.int, Number.int_beq x y = true -> x = y +Number.internal_uint_dec_bl1: + forall x y : Number.uint, Number.uint_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_bl: forall x y : Hexadecimal.hexadecimal, Hexadecimal.hexadecimal_beq x y = true -> x = y @@ -328,12 +328,12 @@ Byte.to_bits_of_bits: forall b : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))), Byte.to_bits (Byte.of_bits b) = b -Numeral.internal_numeral_dec_lb: - forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true -Numeral.internal_uint_dec_lb1: - forall x y : Numeral.uint, x = y -> Numeral.uint_beq x y = true -Numeral.internal_int_dec_lb1: - forall x y : Numeral.int, x = y -> Numeral.int_beq x y = true +Number.internal_number_dec_lb: + forall x y : Number.number, x = y -> Number.number_beq x y = true +Number.internal_uint_dec_lb1: + forall x y : Number.uint, x = y -> Number.uint_beq x y = true +Number.internal_int_dec_lb1: + forall x y : Number.int, x = y -> Number.int_beq x y = true Decimal.internal_int_dec_lb: forall x y : Decimal.int, x = y -> Decimal.int_beq x y = true Hexadecimal.internal_hexadecimal_dec_lb: @@ -391,7 +391,7 @@ Nat.lor: nat -> nat -> nat Nat.lxor: nat -> nat -> nat Nat.of_hex_uint: Hexadecimal.uint -> nat Nat.of_uint: Decimal.uint -> nat -Nat.of_num_uint: Numeral.uint -> nat +Nat.of_num_uint: Number.uint -> nat length: forall [A : Type], list A -> nat plus_n_O: forall n : nat, n = n + 0 plus_O_n: forall n : nat, 0 + n = n diff --git a/test-suite/output/SearchHead.out b/test-suite/output/SearchHead.out index 9554581ebe..2f0d854ac6 100644 --- a/test-suite/output/SearchHead.out +++ b/test-suite/output/SearchHead.out @@ -21,15 +21,15 @@ orb: bool -> bool -> bool implb: bool -> bool -> bool Nat.odd: nat -> bool Nat.even: nat -> bool -Numeral.uint_beq: Numeral.uint -> Numeral.uint -> bool +Number.uint_beq: Number.uint -> Number.uint -> bool Nat.testbit: nat -> nat -> bool Nat.eqb: nat -> nat -> bool Hexadecimal.hexadecimal_beq: Hexadecimal.hexadecimal -> Hexadecimal.hexadecimal -> bool Nat.ltb: nat -> nat -> bool Nat.leb: nat -> nat -> bool -Numeral.numeral_beq: Numeral.numeral -> Numeral.numeral -> bool -Numeral.int_beq: Numeral.int -> Numeral.int -> bool +Number.number_beq: Number.number -> Number.number -> bool +Number.int_beq: Number.int -> Number.int -> bool Hexadecimal.int_beq: Hexadecimal.int -> Hexadecimal.int -> bool Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out index 80b03e8a0b..d705ec898b 100644 --- a/test-suite/output/SearchPattern.out +++ b/test-suite/output/SearchPattern.out @@ -7,15 +7,15 @@ orb: bool -> bool -> bool implb: bool -> bool -> bool Nat.odd: nat -> bool Nat.even: nat -> bool -Numeral.uint_beq: Numeral.uint -> Numeral.uint -> bool +Number.uint_beq: Number.uint -> Number.uint -> bool Nat.testbit: nat -> nat -> bool Nat.eqb: nat -> nat -> bool Hexadecimal.hexadecimal_beq: Hexadecimal.hexadecimal -> Hexadecimal.hexadecimal -> bool Nat.ltb: nat -> nat -> bool Nat.leb: nat -> nat -> bool -Numeral.numeral_beq: Numeral.numeral -> Numeral.numeral -> bool -Numeral.int_beq: Numeral.int -> Numeral.int -> bool +Number.number_beq: Number.number -> Number.number -> bool +Number.int_beq: Number.int -> Number.int -> bool Hexadecimal.int_beq: Hexadecimal.int -> Hexadecimal.int -> bool Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool @@ -50,7 +50,7 @@ Nat.lor: nat -> nat -> nat Nat.gcd: nat -> nat -> nat Hexadecimal.nb_digits: Hexadecimal.uint -> nat Nat.of_hex_uint: Hexadecimal.uint -> nat -Nat.of_num_uint: Numeral.uint -> nat +Nat.of_num_uint: Number.uint -> nat Nat.of_uint: Decimal.uint -> nat Decimal.nb_digits: Decimal.uint -> nat Nat.tail_addmul: nat -> nat -> nat -> nat diff --git a/test-suite/output/ZSyntax.v b/test-suite/output/ZSyntax.v index 7b2bb00ce0..219d953c97 100644 --- a/test-suite/output/ZSyntax.v +++ b/test-suite/output/ZSyntax.v @@ -18,7 +18,7 @@ Require Import Arith. Check (0 + Z.of_nat 11)%Z. (* Check hexadecimal printing *) -Definition to_num_int n := Numeral.IntHex (Z.to_hex_int n). +Definition to_num_int n := Number.IntHex (Z.to_hex_int n). Number Notation Z Z.of_num_int to_num_int : Z_scope. Check 42%Z. Check (-42)%Z. diff --git a/test-suite/output/bug_12159.v b/test-suite/output/bug_12159.v index 437b4a68e9..a7366f2d35 100644 --- a/test-suite/output/bug_12159.v +++ b/test-suite/output/bug_12159.v @@ -2,10 +2,10 @@ Declare Scope A. Declare Scope B. Delimit Scope A with A. Delimit Scope B with B. -Definition to_unit (v : Numeral.uint) : option unit +Definition to_unit (v : Number.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. -Definition of_unit (v : unit) : Numeral.uint := Nat.to_num_uint 0. -Definition of_unit' (v : unit) : Numeral.uint := Nat.to_num_uint 1. +Definition of_unit (v : unit) : Number.uint := Nat.to_num_uint 0. +Definition of_unit' (v : unit) : Number.uint := Nat.to_num_uint 1. Number Notation unit to_unit of_unit : A. Number Notation unit to_unit of_unit' : B. Definition f x : unit := x. diff --git a/test-suite/success/NumberNotationsNoLocal.v b/test-suite/success/NumberNotationsNoLocal.v new file mode 100644 index 0000000000..e19d06cfa7 --- /dev/null +++ b/test-suite/success/NumberNotationsNoLocal.v @@ -0,0 +1,12 @@ +(* Test that number notations don't work on proof-local variables, especially not ones containing evars *) +Inductive unit11 := tt11. +Declare Scope unit11_scope. +Delimit Scope unit11_scope with unit11. +Goal True. + evar (to_uint : unit11 -> Decimal.uint). + evar (of_uint : Decimal.uint -> unit11). + Fail Number Notation unit11 of_uint to_uint : uint11_scope. + exact I. + Unshelve. + all: solve [ constructor ]. +Qed. diff --git a/test-suite/success/NumeralNotationsNoLocal.v b/test-suite/success/NumeralNotationsNoLocal.v deleted file mode 100644 index fe97f10ddf..0000000000 --- a/test-suite/success/NumeralNotationsNoLocal.v +++ /dev/null @@ -1,12 +0,0 @@ -(* Test that numeral notations don't work on proof-local variables, especially not ones containing evars *) -Inductive unit11 := tt11. -Declare Scope unit11_scope. -Delimit Scope unit11_scope with unit11. -Goal True. - evar (to_uint : unit11 -> Decimal.uint). - evar (of_uint : Decimal.uint -> unit11). - Fail Number Notation unit11 of_uint to_uint : uint11_scope. - exact I. - Unshelve. - all: solve [ constructor ]. -Qed. diff --git a/theories/Init/Nat.v b/theories/Init/Nat.v index 7c8cf0b536..bc48311151 100644 --- a/theories/Init/Nat.v +++ b/theories/Init/Nat.v @@ -9,7 +9,7 @@ (************************************************************************) Require Import Notations Logic Datatypes. -Require Decimal Hexadecimal Numeral. +Require Decimal Hexadecimal Number. Local Open Scope nat_scope. (**********************************************************************) @@ -212,10 +212,10 @@ Fixpoint of_hex_uint_acc (d:Hexadecimal.uint)(acc:nat) := Definition of_hex_uint (d:Hexadecimal.uint) := of_hex_uint_acc d O. -Definition of_num_uint (d:Numeral.uint) := +Definition of_num_uint (d:Number.uint) := match d with - | Numeral.UIntDec d => of_uint d - | Numeral.UIntHex d => of_hex_uint d + | Number.UIntDec d => of_uint d + | Number.UIntHex d => of_hex_uint d end. Fixpoint to_little_uint n acc := @@ -236,9 +236,9 @@ Fixpoint to_little_hex_uint n acc := Definition to_hex_uint n := Hexadecimal.rev (to_little_hex_uint n Hexadecimal.zero). -Definition to_num_uint n := Numeral.UIntDec (to_uint n). +Definition to_num_uint n := Number.UIntDec (to_uint n). -Definition to_num_hex_uint n := Numeral.UIntHex (to_hex_uint n). +Definition to_num_hex_uint n := Number.UIntHex (to_hex_uint n). Definition of_int (d:Decimal.int) : option nat := match Decimal.norm d with @@ -252,17 +252,17 @@ Definition of_hex_int (d:Hexadecimal.int) : option nat := | _ => None end. -Definition of_num_int (d:Numeral.int) : option nat := +Definition of_num_int (d:Number.int) : option nat := match d with - | Numeral.IntDec d => of_int d - | Numeral.IntHex d => of_hex_int d + | Number.IntDec d => of_int d + | Number.IntHex d => of_hex_int d end. Definition to_int n := Decimal.Pos (to_uint n). Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). -Definition to_num_int n := Numeral.IntDec (to_int n). +Definition to_num_int n := Number.IntDec (to_int n). (** ** Euclidean division *) diff --git a/theories/Init/Number.v b/theories/Init/Number.v new file mode 100644 index 0000000000..228f84b179 --- /dev/null +++ b/theories/Init/Number.v @@ -0,0 +1,33 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* of_uint d - | Numeral.UIntHex d => of_hex_uint d + | Number.UIntDec d => of_uint d + | Number.UIntHex d => of_hex_uint d end. Definition of_int (d:Decimal.int) := @@ -408,10 +408,10 @@ Definition of_hex_int (d:Hexadecimal.int) := | Hexadecimal.Neg _ => None end. -Definition of_num_int (d:Numeral.int) := +Definition of_num_int (d:Number.int) := match d with - | Numeral.IntDec d => of_int d - | Numeral.IntHex d => of_hex_int d + | Number.IntDec d => of_int d + | Number.IntHex d => of_hex_int d end. Definition to_uint n := @@ -426,13 +426,13 @@ Definition to_hex_uint n := | pos p => Pos.to_hex_uint p end. -Definition to_num_uint n := Numeral.UIntDec (to_uint n). +Definition to_num_uint n := Number.UIntDec (to_uint n). Definition to_int n := Decimal.Pos (to_uint n). Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). -Definition to_num_int n := Numeral.IntDec (to_int n). +Definition to_num_int n := Number.IntDec (to_int n). Number Notation N of_num_uint to_num_uint : N_scope. diff --git a/theories/Numbers/AltBinNotations.v b/theories/Numbers/AltBinNotations.v index 7c846571a7..c203c178f5 100644 --- a/theories/Numbers/AltBinNotations.v +++ b/theories/Numbers/AltBinNotations.v @@ -17,7 +17,7 @@ the [Decimal.int] representation. When working with numbers with thousands of digits and more, conversion from/to [Decimal.int] can become significantly slow. If that becomes a problem for your - development, this file provides some alternative [Numeral + development, this file provides some alternative [Number Notation] commands that use [Z] as bridge type. To enable these commands, just be sure to [Require] this file after other files defining numeral notations. diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index b41cd571dc..958778762d 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -639,10 +639,10 @@ Fixpoint of_hex_uint (d:Hexadecimal.uint) : N := | Hexadecimal.Df l => Npos (of_hex_uint_acc l 1~1~1~1) end. -Definition of_num_uint (d:Numeral.uint) : N := +Definition of_num_uint (d:Number.uint) : N := match d with - | Numeral.UIntDec d => of_uint d - | Numeral.UIntHex d => of_hex_uint d + | Number.UIntDec d => of_uint d + | Number.UIntHex d => of_hex_uint d end. Definition of_int (d:Decimal.int) : option positive := @@ -665,10 +665,10 @@ Definition of_hex_int (d:Hexadecimal.int) : option positive := | Hexadecimal.Neg _ => None end. -Definition of_num_int (d:Numeral.int) : option positive := +Definition of_num_int (d:Number.int) : option positive := match d with - | Numeral.IntDec d => of_int d - | Numeral.IntHex d => of_hex_int d + | Number.IntDec d => of_int d + | Number.IntHex d => of_hex_int d end. Fixpoint to_little_uint p := @@ -689,13 +689,13 @@ Fixpoint to_little_hex_uint p := Definition to_hex_uint p := Hexadecimal.rev (to_little_hex_uint p). -Definition to_num_uint p := Numeral.UIntDec (to_uint p). +Definition to_num_uint p := Number.UIntDec (to_uint p). Definition to_int n := Decimal.Pos (to_uint n). Definition to_hex_int p := Hexadecimal.Pos (to_hex_uint p). -Definition to_num_int n := Numeral.IntDec (to_int n). +Definition to_num_int n := Number.IntDec (to_int n). Number Notation positive of_num_int to_num_uint : positive_scope. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 192dcd885b..151355519e 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -117,16 +117,16 @@ Definition to_hexadecimal (q:Q) : option Hexadecimal.hexadecimal := | _ => None end. -Definition of_numeral (d:Numeral.numeral) : option Q := +Definition of_numeral (d:Number.number) : option Q := match d with - | Numeral.Dec d => Some (of_decimal d) - | Numeral.Hex d => Some (of_hexadecimal d) + | Number.Dec d => Some (of_decimal d) + | Number.Hex d => Some (of_hexadecimal d) end. -Definition to_numeral (q:Q) : option Numeral.numeral := +Definition to_numeral (q:Q) : option Number.number := match to_decimal q with | None => None - | Some q => Some (Numeral.Dec q) + | Some q => Some (Number.Dec q) end. Number Notation Q of_numeral to_numeral : Q_scope. diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 69ed101f24..9415903fa4 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -311,10 +311,10 @@ Definition of_uint (d:Decimal.uint) := of_N (Pos.of_uint d). Definition of_hex_uint (d:Hexadecimal.uint) := of_N (Pos.of_hex_uint d). -Definition of_num_uint (d:Numeral.uint) := +Definition of_num_uint (d:Number.uint) := match d with - | Numeral.UIntDec d => of_uint d - | Numeral.UIntHex d => of_hex_uint d + | Number.UIntDec d => of_uint d + | Number.UIntHex d => of_hex_uint d end. Definition of_int (d:Decimal.int) := @@ -329,10 +329,10 @@ Definition of_hex_int (d:Hexadecimal.int) := | Hexadecimal.Neg d => opp (of_hex_uint d) end. -Definition of_num_int (d:Numeral.int) := +Definition of_num_int (d:Number.int) := match d with - | Numeral.IntDec d => of_int d - | Numeral.IntHex d => of_hex_int d + | Number.IntDec d => of_int d + | Number.IntHex d => of_hex_int d end. Definition to_int n := @@ -349,7 +349,7 @@ Definition to_hex_int n := | neg p => Hexadecimal.Neg (Pos.to_hex_uint p) end. -Definition to_num_int n := Numeral.IntDec (to_int n). +Definition to_num_int n := Number.IntDec (to_int n). (** ** Iteration of a function -- cgit v1.2.3 From 3a25b967a944fe37e1ad54e54a904d90311ef381 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sat, 12 Sep 2020 09:13:44 +0200 Subject: Renaming numnotoption into number_modifier --- doc/sphinx/user-extensions/syntax-extensions.rst | 8 ++++---- doc/tools/docgram/common.edit_mlg | 10 +++++----- doc/tools/docgram/fullGrammar | 6 +++--- doc/tools/docgram/orderedGrammar | 7 ++++--- plugins/syntax/g_numeral.mlg | 16 ++++++++-------- plugins/syntax/numeral.ml | 22 +++++++++++----------- plugins/syntax/numeral.mli | 8 ++++---- 7 files changed, 39 insertions(+), 38 deletions(-) diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index f982898335..a36772b2d7 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1553,16 +1553,16 @@ numbers (see :ref:`datatypes`). Number notations ~~~~~~~~~~~~~~~~ -.. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print : @scope_name {? @numeral_modifier } +.. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print : @scope_name {? @number_modifier } :name: Number Notation - .. insertprodn numeral_modifier numeral_modifier + .. insertprodn number_modifier number_modifier .. prodn:: - numeral_modifier ::= ( warning after @bignat ) + number_modifier ::= ( warning after @bignat ) | ( abstract after @bignat ) - This command allows the user to customize the way numeral literals + This command allows the user to customize the way number literals are parsed and printed. :n:`@qualid__type` diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index f6a684bbd7..5d0f9208fc 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -1285,10 +1285,10 @@ command: [ | WITH "Declare" "Scope" scope_name (* odd that these are in command while other notation-related ones are in syntax *) -| REPLACE "Numeral" "Notation" reference reference reference ":" ident numeral_modifier -| WITH "Numeral" "Notation" reference reference reference ":" scope_name numeral_modifier -| REPLACE "Number" "Notation" reference reference reference ":" ident numeral_modifier -| WITH "Number" "Notation" reference reference reference ":" scope_name numeral_modifier +| REPLACE "Numeral" "Notation" reference reference reference ":" ident number_modifier +| WITH "Numeral" "Notation" reference reference reference ":" scope_name number_modifier +| REPLACE "Number" "Notation" reference reference reference ":" ident number_modifier +| WITH "Number" "Notation" reference reference reference ":" scope_name number_modifier | REPLACE "String" "Notation" reference reference reference ":" ident | WITH "String" "Notation" reference reference reference ":" scope_name @@ -1358,7 +1358,7 @@ explicit_subentry: [ | DELETE "constr" (* covered by another prod *) ] -numeral_modifier: [ +number_modifier: [ | OPTINREF ] diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index c764cb6f37..914347b4cf 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -686,8 +686,8 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" constr OPT field_mods (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Number" "Notation" reference reference reference ":" ident numeral_modifier -| "Numeral" "Notation" reference reference reference ":" ident numeral_modifier +| "Number" "Notation" reference reference reference ":" ident number_modifier +| "Numeral" "Notation" reference reference reference ":" ident number_modifier | "String" "Notation" reference reference reference ":" ident | "Ltac2" ltac2_entry (* Ltac2 plugin *) | "Ltac2" "Eval" ltac2_expr6 (* Ltac2 plugin *) @@ -2549,7 +2549,7 @@ field_mods: [ | "(" LIST1 field_mod SEP "," ")" (* ring plugin *) ] -numeral_modifier: [ +number_modifier: [ | | "(" "warning" "after" bignat ")" | "(" "abstract" "after" bignat ")" diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 12a7bc684d..a972ad4719 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -884,8 +884,8 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Number" "Notation" qualid qualid qualid ":" scope_name OPT numeral_modifier -| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT numeral_modifier +| "Number" "Notation" qualid qualid qualid ":" scope_name OPT number_modifier +| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT number_modifier | "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) | "Typeclasses" "Transparent" LIST1 qualid | "Typeclasses" "Opaque" LIST1 qualid @@ -910,6 +910,7 @@ command: [ | "Derive" "Dependent" "Inversion_clear" ident "with" one_term "Sort" sort_family | "Declare" "Left" "Step" one_term | "Declare" "Right" "Step" one_term +| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT number_modifier | "String" "Notation" qualid qualid qualid ":" scope_name | "SubClass" ident_decl def_body | thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] @@ -1269,7 +1270,7 @@ field_mod: [ | "completeness" one_term (* ring plugin *) ] -numeral_modifier: [ +number_modifier: [ | "(" "warning" "after" bignat ")" | "(" "abstract" "after" bignat ")" ] diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index 93d91abea3..48e262c3ef 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -19,7 +19,7 @@ open Names open Stdarg open Pcoq.Prim -let pr_numnot_option = function +let pr_number_modifier = function | Nop -> mt () | Warning n -> str "(warning after " ++ NumTok.UnsignedNat.print n ++ str ")" | Abstract n -> str "(abstract after " ++ NumTok.UnsignedNat.print n ++ str ")" @@ -31,21 +31,21 @@ let warn_deprecated_numeral_notation = } -VERNAC ARGUMENT EXTEND numeral_modifier - PRINTED BY { pr_numnot_option } +VERNAC ARGUMENT EXTEND number_modifier + PRINTED BY { pr_number_modifier } | [ ] -> { Nop } | [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } | [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } END -VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF +VERNAC COMMAND EXTEND NumberNotation CLASSIFIED AS SIDEFF | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) numeral_modifier(o) ] -> + ident(sc) number_modifier(o) ] -> - { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } + { vernac_number_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) numeral_modifier(o) ] -> + ident(sc) number_modifier(o) ] -> { warn_deprecated_numeral_notation (); - vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } + vernac_number_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } END diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index fbf43be91f..313798b102 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -16,7 +16,7 @@ open Constrexpr open Constrexpr_ops open Notation -(** * Numeral notation *) +(** * Number notation *) let warn_abstract_large_num_no_op = CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" @@ -55,7 +55,7 @@ let locate_z () = }, mkRefC q_z) else None -let locate_numeral () = +let locate_number () = let dint = "num.int.type" in let duint = "num.uint.type" in let dec = "num.decimal.type" in @@ -111,27 +111,27 @@ let has_type env sigma f ty = let type_error_to f ty = CErrors.user_err - (pr_qualid f ++ str " should go from Numeral.int to " ++ + (pr_qualid f ++ str " should go from Number.int to " ++ pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first).") + fnl () ++ str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") let type_error_of g ty = CErrors.user_err (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ - str " to Numeral.int or (option Numeral.int)." ++ fnl () ++ - str "Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first).") + str " to Number.int or (option Number.int)." ++ fnl () ++ + str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") let warn_deprecated_decimal = CWarnings.create ~name:"decimal-numeral-notation" ~category:"deprecated" (fun () -> - strbrk "Deprecated Numeral Notation for Decimal.uint, \ - Decimal.int or Decimal.decimal. Use Numeral.uint, \ - Numeral.int or Numeral.numeral respectively.") + strbrk "Deprecated Number Notation for Decimal.uint, \ + Decimal.int or Decimal.decimal. Use Number.uint, \ + Number.int or Number.number respectively.") -let vernac_numeral_notation local ty f g scope opts = +let vernac_number_notation local ty f g scope opts = let env = Global.env () in let sigma = Evd.from_env env in - let num_ty = locate_numeral () in + let num_ty = locate_number () in let z_pos_ty = locate_z () in let int63_ty = locate_int63 () in let tyc = Smartlocate.global_inductive_with_alias ty in diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli index 99252484b4..d5fe42b0b4 100644 --- a/plugins/syntax/numeral.mli +++ b/plugins/syntax/numeral.mli @@ -12,8 +12,8 @@ open Libnames open Vernacexpr open Notation -(** * Numeral notation *) +(** * Number notation *) -val vernac_numeral_notation : locality_flag -> - qualid -> qualid -> qualid -> - Notation_term.scope_name -> numnot_option -> unit +val vernac_number_notation : locality_flag -> + qualid -> qualid -> qualid -> + Notation_term.scope_name -> numnot_option -> unit -- cgit v1.2.3 From da72fafac3b5b4b21330cd097f5728cbc127aea4 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sat, 12 Sep 2020 09:15:06 +0200 Subject: Renaming Numeral into Number --- coqpp/coqpp_main.ml | 2 +- interp/constrexpr.ml | 2 +- interp/constrexpr_ops.ml | 6 +-- interp/constrextern.ml | 10 ++-- interp/constrintern.ml | 12 ++--- interp/notation.ml | 112 ++++++++++++++++++++--------------------- interp/notation.mli | 24 ++++----- interp/numTok.mli | 30 +++++------ parsing/cLexer.ml | 8 +-- parsing/cLexer.mli | 4 +- parsing/g_constr.mlg | 16 +++--- plugins/ltac/g_tactic.mlg | 6 +-- plugins/ssr/ssrparser.mlg | 2 +- plugins/syntax/int63_syntax.ml | 2 +- plugins/syntax/numeral.ml | 12 ++--- printing/ppconstr.ml | 6 +-- vernac/egramcoq.ml | 4 +- 17 files changed, 129 insertions(+), 129 deletions(-) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 83929bd030..8affe58824 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -454,7 +454,7 @@ struct let terminal s = let p = - if s <> "" && s.[0] >= '0' && s.[0] <= '9' then "CLexer.terminal_numeral" + if s <> "" && s.[0] >= '0' && s.[0] <= '9' then "CLexer.terminal_number" else "CLexer.terminal" in let c = Printf.sprintf "Pcoq.Symbol.token (%s \"%s\")" p s in SymbQuote c diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index d14d156ffc..235310660b 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -58,7 +58,7 @@ type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) type prim_token = - | Numeral of NumTok.Signed.t + | Number of NumTok.Signed.t | String of string type instance_expr = Glob_term.glob_level list diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 7075d082ee..8cc63c5d03 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -44,13 +44,13 @@ let names_of_local_binders bl = (**********************************************************************) (* Functions on constr_expr *) -(* Note: redundant Numeral representations, such as -0 and +0 (and others), +(* Note: redundant Number representations, such as -0 and +0 (and others), are considered different here. *) let prim_token_eq t1 t2 = match t1, t2 with -| Numeral n1, Numeral n2 -> NumTok.Signed.equal n1 n2 +| Number n1, Number n2 -> NumTok.Signed.equal n1 n2 | String s1, String s2 -> String.equal s1 s2 -| (Numeral _ | String _), _ -> false +| (Number _ | String _), _ -> false let explicitation_eq ex1 ex2 = match ex1, ex2 with | ExplByPos (i1, id1), ExplByPos (i2, id2) -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 7bf1c58148..d1bec16a3f 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -357,18 +357,18 @@ let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None let make_notation_gen loc ntn mknot mkprim destprim l bl = match snd ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) - | "- _", [Some (Numeral p)] when not (NumTok.Signed.is_zero p) -> + | "- _", [Some (Number p)] when not (NumTok.Signed.is_zero p) -> assert (bl=[]); mknot (loc,ntn,([mknot (loc,(InConstrEntry,"( _ )"),l,[])]),[]) | _ -> match decompose_notation_key ntn, l with | (InConstrEntry,[Terminal "-"; Terminal x]), [] -> begin match NumTok.Unsigned.parse_string x with - | Some n -> mkprim (loc, Numeral (NumTok.SMinus,n)) + | Some n -> mkprim (loc, Number (NumTok.SMinus,n)) | None -> mknot (loc,ntn,l,bl) end | (InConstrEntry,[Terminal x]), [] -> begin match NumTok.Unsigned.parse_string x with - | Some n -> mkprim (loc, Numeral (NumTok.SPlus,n)) + | Some n -> mkprim (loc, Number (NumTok.SPlus,n)) | None -> mknot (loc,ntn,l,bl) end | _ -> mknot (loc,ntn,l,bl) @@ -915,7 +915,7 @@ let extern_float f scopes = let hex = !Flags.raw_print || not (get_printing_float ()) in if hex then Float64.to_hex_string f else Float64.to_string f in let n = NumTok.Signed.of_string s in - extern_prim_token_delimiter_if_required (Numeral n) + extern_prim_token_delimiter_if_required (Number n) "float" "float_scope" scopes (**********************************************************************) @@ -1097,7 +1097,7 @@ let rec extern inctx ?impargs scopes vars r = | GInt i -> extern_prim_token_delimiter_if_required - (Numeral (NumTok.Signed.of_int_string (Uint63.to_string i))) + (Number (NumTok.Signed.of_int_string (Uint63.to_string i))) "int63" "int63_scope" (snd scopes) | GFloat f -> extern_float f (snd scopes) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 959b61a3d7..5fb6664dd6 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1570,11 +1570,11 @@ let rec subst_pat_iterator y t = DAst.(map (function | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) let is_non_zero c = match c with -| { CAst.v = CPrim (Numeral p) } -> not (NumTok.Signed.is_zero p) +| { CAst.v = CPrim (Number p) } -> not (NumTok.Signed.is_zero p) | _ -> false let is_non_zero_pat c = match c with -| { CAst.v = CPatPrim (Numeral p) } -> not (NumTok.Signed.is_zero p) +| { CAst.v = CPatPrim (Number p) } -> not (NumTok.Signed.is_zero p) | _ -> false let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref @@ -1689,8 +1689,8 @@ let drop_notations_pattern looked_for genv = let (argscs1,_) = find_remaining_scopes expl_pl pl g in DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) | CPatNotation (_,(InConstrEntry,"- _"),([a],[]),[]) when is_non_zero_pat a -> - let p = match a.CAst.v with CPatPrim (Numeral (_, p)) -> p | _ -> assert false in - let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (SMinus,p)) scopes in + let p = match a.CAst.v with CPatPrim (Number (_, p)) -> p | _ -> assert false in + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Number (SMinus,p)) scopes in rcp_of_glob scopes pat | CPatNotation (_,(InConstrEntry,"( _ )"),([a],[]),[]) -> in_pat top scopes a @@ -2006,8 +2006,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = GLetIn (na.CAst.v, inc1, int, intern_restart_binders (push_name_env ntnvars (impls_term_list 1 inc1) env na) c2) | CNotation (_,(InConstrEntry,"- _"), ([a],[],[],[])) when is_non_zero a -> - let p = match a.CAst.v with CPrim (Numeral (_, p)) -> p | _ -> assert false in - intern env (CAst.make ?loc @@ CPrim (Numeral (SMinus,p))) + let p = match a.CAst.v with CPrim (Number (_, p)) -> p | _ -> assert false in + intern env (CAst.make ?loc @@ CPrim (Number (SMinus,p))) | CNotation (_,(InConstrEntry,"( _ )"),([a],[],[],[])) -> intern env a | CNotation (_,ntn,args) -> let c = intern_notation intern env ntnvars loc ntn args in diff --git a/interp/notation.ml b/interp/notation.ml index 269e20c16e..8a35eeb203 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -32,7 +32,7 @@ open NumTok fail if a number has no interpretation in the scope (e.g. there is no interpretation for negative numbers in [nat]); interpreters both for terms and patterns can be set; these interpreters are in permanent table - [numeral_interpreter_tab] + [number_interpreter_tab] - a set of ML printers for expressions denoting numbers parsable in this scope - a set of interpretations for infix (more generally distfix) notations @@ -446,13 +446,13 @@ module InnerPrimToken = struct let do_interp ?loc interp primtok = match primtok, interp with - | Numeral n, RawNumInterp interp -> interp ?loc n - | Numeral n, BigNumInterp interp -> + | Number n, RawNumInterp interp -> interp ?loc n + | Number n, BigNumInterp interp -> (match NumTok.Signed.to_bigint n with | Some n -> interp ?loc n | None -> raise Not_found) | String s, StringInterp interp -> interp ?loc s - | (Numeral _ | String _), + | (Number _ | String _), (RawNumInterp _ | BigNumInterp _ | StringInterp _) -> raise Not_found type uninterpreter = @@ -466,16 +466,16 @@ module InnerPrimToken = struct | StringUninterp f, StringUninterp f' -> f == f' | _ -> false - let mkNumeral n = - Numeral (NumTok.Signed.of_bigint CDec n) + let mkNumber n = + Number (NumTok.Signed.of_bigint CDec n) let mkString = function | None -> None | Some s -> if Unicode.is_utf8 s then Some (String s) else None let do_uninterp uninterp g = match uninterp with - | RawNumUninterp u -> Option.map (fun (s,n) -> Numeral (s,n)) (u g) - | BigNumUninterp u -> Option.map mkNumeral (u g) + | RawNumUninterp u -> Option.map (fun (s,n) -> Number (s,n)) (u g) + | BigNumUninterp u -> Option.map mkNumber (u g) | StringUninterp u -> mkString (u g) end @@ -495,7 +495,7 @@ let prim_token_uninterpreters = (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.uninterpreter) Hashtbl.t) (*******************************************************) -(* Numeral notation interpretation *) +(* Number notation interpretation *) type prim_token_notation_error = | UnexpectedTerm of Constr.t | UnexpectedNonOptionTerm of Constr.t @@ -519,21 +519,21 @@ type z_pos_ty = { z_ty : Names.inductive; pos_ty : Names.inductive } -type numeral_ty = +type number_ty = { int : int_ty; decimal : Names.inductive; hexadecimal : Names.inductive; - numeral : Names.inductive } + number : Names.inductive } type target_kind = - | Int of int_ty (* Coq.Init.Numeral.int + uint *) - | UInt of int_ty (* Coq.Init.Numeral.uint *) + | Int of int_ty (* Coq.Init.Number.int + uint *) + | UInt of int_ty (* Coq.Init.Number.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) - | Numeral of numeral_ty (* Coq.Init.Numeral.numeral + uint + int *) + | Number of number_ty (* Coq.Init.Number.number + uint + int *) | DecimalInt of int_ty (* Coq.Init.Decimal.int + uint (deprecated) *) | DecimalUInt of int_ty (* Coq.Init.Decimal.uint (deprecated) *) - | Decimal of numeral_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) + | Decimal of number_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) type string_target_kind = | ListByte @@ -550,11 +550,11 @@ type ('target, 'warning) prim_token_notation_obj = ty_name : Libnames.qualid; (* for warnings / error messages *) warning : 'warning } -type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type number_notation_obj = (target_kind, numnot_option) prim_token_notation_obj type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj module PrimTokenNotation = struct -(** * Code shared between Numeral notation and String notation *) +(** * Code shared between Number notation and String notation *) (** Reduction The constr [c] below isn't necessarily well-typed, since we @@ -588,7 +588,7 @@ exception NotAValidPrimToken to [constr] for the subset that concerns us. Note that if you update [constr_of_glob], you should update the - corresponding numeral notation *and* string notation doc in + corresponding number notation *and* string notation doc in doc/sphinx/user-extensions/syntax-extensions.rst that describes what it means for a term to be ground / to be able to be considered for parsing. *) @@ -670,8 +670,8 @@ let rec int63_of_pos_bigint i = (Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo)) else Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo) -module Numeral = struct -(** * Numeral notation *) +module Numbers = struct +(** * Number notation *) open PrimTokenNotation let warn_large_num = @@ -727,7 +727,7 @@ let coqint_of_rawnum inds c (sign,n) = let pos_neg = match sign with SPlus -> 1 | SMinus -> 2 in mkApp (mkConstruct (ind, pos_neg), [|uint|]) -let coqnumeral_of_rawnum inds c n = +let coqnumber_of_rawnum inds c n = let ind = match c with CDec -> inds.decimal | CHex -> inds.hexadecimal in let i, f, e = NumTok.Signed.to_int_frac_and_exponent n in let i = coqint_of_rawnum inds.int c i in @@ -744,14 +744,14 @@ let mkDecHex ind c n = match c with exception NonDecimal -let decimal_coqnumeral_of_rawnum inds n = +let decimal_coqnumber_of_rawnum inds n = if NumTok.Signed.classify n <> CDec then raise NonDecimal; - coqnumeral_of_rawnum inds CDec n + coqnumber_of_rawnum inds CDec n -let coqnumeral_of_rawnum inds n = +let coqnumber_of_rawnum inds n = let c = NumTok.Signed.classify n in - let n = coqnumeral_of_rawnum inds c n in - mkDecHex inds.numeral c n + let n = coqnumber_of_rawnum inds c n in + mkDecHex inds.number c n let decimal_coquint_of_rawnum inds n = if NumTok.UnsignedNat.classify n <> CDec then raise NonDecimal; @@ -801,7 +801,7 @@ let rawnum_of_coqint cl c = | _ -> raise NotAValidPrimToken) | _ -> raise NotAValidPrimToken -let rawnum_of_coqnumeral cl c = +let rawnum_of_coqnumber cl c = let of_ife i f e = let n = rawnum_of_coqint cl i in let f = try Some (rawnum_of_coquint cl f) with NotAValidPrimToken -> None in @@ -820,12 +820,12 @@ let destDecHex c = match Constr.kind c with | _ -> raise NotAValidPrimToken) | _ -> raise NotAValidPrimToken -let decimal_rawnum_of_coqnumeral c = - rawnum_of_coqnumeral CDec c +let decimal_rawnum_of_coqnumber c = + rawnum_of_coqnumber CDec c -let rawnum_of_coqnumeral c = +let rawnum_of_coqnumber c = let cl, c = destDecHex c in - rawnum_of_coqnumeral cl c + rawnum_of_coqnumber cl c let decimal_rawnum_of_coquint c = rawnum_of_coquint CDec c @@ -947,9 +947,9 @@ let interp o ?loc n = interp_int63 ?loc (NumTok.SignedNat.to_bigint n) | (Int _ | UInt _ | DecimalInt _ | DecimalUInt _ | Z _ | Int63), _ -> no_such_prim_token "number" ?loc o.ty_name - | Numeral numeral_ty, _ -> coqnumeral_of_rawnum numeral_ty n - | Decimal numeral_ty, _ -> - (try decimal_coqnumeral_of_rawnum numeral_ty n + | Number number_ty, _ -> coqnumber_of_rawnum number_ty n + | Decimal number_ty, _ -> + (try decimal_coqnumber_of_rawnum number_ty n with NonDecimal -> no_such_prim_token "number" ?loc o.ty_name) in let env = Global.env () in @@ -959,12 +959,12 @@ let interp o ?loc n = match o.warning, snd o.to_kind with | Abstract threshold, Direct when NumTok.Signed.is_bigger_int_than n threshold -> warn_abstract_large_num (o.ty_name,o.to_ty); - glob_of_constr "numeral" ?loc env sigma (mkApp (to_ty,[|c|])) + glob_of_constr "number" ?loc env sigma (mkApp (to_ty,[|c|])) | _ -> let res = eval_constr_app env sigma to_ty c in match snd o.to_kind with - | Direct -> glob_of_constr "numeral" ?loc env sigma res - | Option -> interp_option "number" "numeral" o.ty_name ?loc env sigma res + | Direct -> glob_of_constr "number" ?loc env sigma res + | Option -> interp_option "number" "number" o.ty_name ?loc env sigma res let uninterp o n = PrimTokenNotation.uninterp @@ -973,10 +973,10 @@ let uninterp o n = | (UInt _, c) -> NumTok.Signed.of_nat (rawnum_of_coquint c) | (Z _, c) -> NumTok.Signed.of_bigint CDec (bigint_of_z c) | (Int63, c) -> NumTok.Signed.of_bigint CDec (bigint_of_int63 c) - | (Numeral _, c) -> rawnum_of_coqnumeral c + | (Number _, c) -> rawnum_of_coqnumber c | (DecimalInt _, c) -> NumTok.Signed.of_int (decimal_rawnum_of_coqint c) | (DecimalUInt _, c) -> NumTok.Signed.of_nat (decimal_rawnum_of_coquint c) - | (Decimal _, c) -> decimal_rawnum_of_coqnumeral c + | (Decimal _, c) -> decimal_rawnum_of_coqnumber c end o n end @@ -1081,21 +1081,21 @@ end (* A [prim_token_infos], which is synchronized with the document state, either contains a unique id pointing to an unsynchronized - prim token function, or a numeral notation object describing how to + prim token function, or a number notation object describing how to interpret and uninterpret. We provide [prim_token_infos] because we expect plugins to provide their own interpretation functions, - rather than going through numeral notations, which are available as + rather than going through number notations, which are available as a vernacular. *) type prim_token_interp_info = Uid of prim_token_uid - | NumeralNotation of numeral_notation_obj + | NumberNotation of number_notation_obj | StringNotation of string_notation_obj type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) pt_scope : scope_name; (** Concerned scope *) - pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a number notation object describing (un)interp functions *) pt_required : required_module; (** Module that should be loaded first *) pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) pt_in_match : bool (** Is this prim token legal in match patterns ? *) @@ -1119,7 +1119,7 @@ let hashtbl_check_and_set allow_overwrite uid f h eq = | _ -> user_err ~hdr:"prim_token_interpreter" (str "Unique identifier " ++ str uid ++ - str " already used to register a numeral or string (un)interpreter.") + str " already used to register a number or string (un)interpreter.") let register_gen_interpretation allow_overwrite uid (interp, uninterp) = hashtbl_check_and_set @@ -1220,7 +1220,7 @@ let check_required_module ?loc sc (sp,d) = (str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") -(* Look if some notation or numeral printer in [scope] can be used in +(* Look if some notation or number printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) let find_with_delimiters = function @@ -1237,7 +1237,7 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function | NotationInScope scope' when String.equal scope scope' -> Some (None,None) | _ -> - (* If the most recently open scope has a notation/numeral printer + (* If the most recently open scope has a notation/number printer but not the expected one then we need delimiters *) if find scope then find_with_delimiters ntn_scope @@ -1375,8 +1375,8 @@ let find_notation ntn sc = | _ -> raise Not_found let notation_of_prim_token = function - | Constrexpr.Numeral (SPlus,n) -> InConstrEntry, NumTok.Unsigned.sprint n - | Constrexpr.Numeral (SMinus,n) -> InConstrEntry, "- "^NumTok.Unsigned.sprint n + | Constrexpr.Number (SPlus,n) -> InConstrEntry, NumTok.Unsigned.sprint n + | Constrexpr.Number (SMinus,n) -> InConstrEntry, "- "^NumTok.Unsigned.sprint n | String _ -> raise Not_found let find_prim_token check_allowed ?loc p sc = @@ -1394,7 +1394,7 @@ let find_prim_token check_allowed ?loc p sc = check_required_module ?loc sc spdir; let interp = match info with | Uid uid -> Hashtbl.find prim_token_interpreters uid - | NumeralNotation o -> InnerPrimToken.RawNumInterp (Numeral.interp o) + | NumberNotation o -> InnerPrimToken.RawNumInterp (Numbers.interp o) | StringNotation o -> InnerPrimToken.StringInterp (Strings.interp o) in let pat = InnerPrimToken.do_interp ?loc interp p in @@ -1411,8 +1411,8 @@ let interp_prim_token_gen ?loc g p local_scopes = let _, info = Exninfo.capture exn in user_err ?loc ~info ~hdr:"interp_prim_token" ((match p with - | Numeral _ -> - str "No interpretation for numeral " ++ pr_notation (notation_of_prim_token p) + | Number _ -> + str "No interpretation for number " ++ pr_notation (notation_of_prim_token p) | String s -> str "No interpretation for string " ++ qs s) ++ str ".") let interp_prim_token ?loc = @@ -1659,14 +1659,14 @@ let availability_of_prim_token n printer_scope local_scopes = let uid = snd (String.Map.find scope !prim_token_interp_infos) in let open InnerPrimToken in match n, uid with - | Constrexpr.Numeral _, NumeralNotation _ -> true - | _, NumeralNotation _ -> false + | Constrexpr.Number _, NumberNotation _ -> true + | _, NumberNotation _ -> false | String _, StringNotation _ -> true | _, StringNotation _ -> false | _, Uid uid -> let interp = Hashtbl.find prim_token_interpreters uid in match n, interp with - | Constrexpr.Numeral _, (RawNumInterp _ | BigNumInterp _) -> true + | Constrexpr.Number _, (RawNumInterp _ | BigNumInterp _) -> true | String _, StringInterp _ -> true | _ -> false with Not_found -> false @@ -1681,7 +1681,7 @@ let rec find_uninterpretation need_delim def find = function def | OpenScopeItem scope :: scopes -> (try find need_delim scope - with Not_found -> find_uninterpretation need_delim def find scopes) (* TODO: here we should also update the need_delim list with all regular notations in scope [scope] that could shadow a numeral notation *) + with Not_found -> find_uninterpretation need_delim def find scopes) (* TODO: here we should also update the need_delim list with all regular notations in scope [scope] that could shadow a number notation *) | LonelyNotationItem ntn::scopes -> find_uninterpretation (ntn::need_delim) def find scopes @@ -1693,7 +1693,7 @@ let uninterp_prim_token c local_scopes = try let uninterp = match info with | Uid uid -> Hashtbl.find prim_token_uninterpreters uid - | NumeralNotation o -> InnerPrimToken.RawNumUninterp (Numeral.uninterp o) + | NumberNotation o -> InnerPrimToken.RawNumUninterp (Numbers.uninterp o) | StringNotation o -> InnerPrimToken.StringUninterp (Strings.uninterp o) in match InnerPrimToken.do_uninterp uninterp (AnyGlobConstr c) with diff --git a/interp/notation.mli b/interp/notation.mli index d744ff41d9..918744b66a 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -74,7 +74,7 @@ val find_delimiters_scope : ?loc:Loc.t -> delimiters -> scope_name (** {6 Declare and uses back and forth an interpretation of primitive token } *) -(** A numeral interpreter is the pair of an interpreter for **(hexa)decimal** +(** A number interpreter is the pair of an interpreter for **(hexa)decimal** numbers in terms and an optional interpreter in pattern, if non integer or negative numbers are not supported, the interpreter must fail with an appropriate error message *) @@ -84,7 +84,7 @@ type required_module = full_path * string list type rawnum = NumTok.Signed.t (** The unique id string below will be used to refer to a particular - registered interpreter/uninterpreter of numeral or string notation. + registered interpreter/uninterpreter of number or string notation. Using the same uid for different (un)interpreters will fail. If at most one interpretation of prim token is used per scope, then the scope name could be used as unique id. *) @@ -106,7 +106,7 @@ val register_bignumeral_interpretation : val register_string_interpretation : ?allow_overwrite:bool -> prim_token_uid -> string prim_token_interpretation -> unit -(** * Numeral notation *) +(** * Number notation *) type prim_token_notation_error = | UnexpectedTerm of Constr.t @@ -131,21 +131,21 @@ type z_pos_ty = { z_ty : Names.inductive; pos_ty : Names.inductive } -type numeral_ty = +type number_ty = { int : int_ty; decimal : Names.inductive; hexadecimal : Names.inductive; - numeral : Names.inductive } + number : Names.inductive } type target_kind = - | Int of int_ty (* Coq.Init.Numeral.int + uint *) - | UInt of int_ty (* Coq.Init.Numeral.uint *) + | Int of int_ty (* Coq.Init.Number.int + uint *) + | UInt of int_ty (* Coq.Init.Number.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) - | Numeral of numeral_ty (* Coq.Init.Numeral.numeral + uint + int *) + | Number of number_ty (* Coq.Init.Number.number + uint + int *) | DecimalInt of int_ty (* Coq.Init.Decimal.int + uint (deprecated) *) | DecimalUInt of int_ty (* Coq.Init.Decimal.uint (deprecated) *) - | Decimal of numeral_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) + | Decimal of number_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) type string_target_kind = | ListByte @@ -162,18 +162,18 @@ type ('target, 'warning) prim_token_notation_obj = ty_name : Libnames.qualid; (* for warnings / error messages *) warning : 'warning } -type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type number_notation_obj = (target_kind, numnot_option) prim_token_notation_obj type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj type prim_token_interp_info = Uid of prim_token_uid - | NumeralNotation of numeral_notation_obj + | NumberNotation of number_notation_obj | StringNotation of string_notation_obj type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) pt_scope : scope_name; (** Concerned scope *) - pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a number notation object describing (un)interp functions *) pt_required : required_module; (** Module that should be loaded first *) pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) pt_in_match : bool (** Is this prim token legal in match patterns ? *) diff --git a/interp/numTok.mli b/interp/numTok.mli index bcfe663dd2..386a25f042 100644 --- a/interp/numTok.mli +++ b/interp/numTok.mli @@ -8,20 +8,20 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Numerals in different forms: signed or unsigned, possibly with +(** Numbers in different forms: signed or unsigned, possibly with fractional part and exponent. - Numerals are represented using raw strings of (hexa)decimal + Numbers are represented using raw strings of (hexa)decimal literals and a separate sign flag. Note that this representation is not unique, due to possible multiple leading or trailing zeros, and -0 = +0, for instances. - The reason to keep the numeral exactly as it was parsed is that - specific notations can be declared for specific numerals + The reason to keep the number exactly as it was parsed is that + specific notations can be declared for specific numbers (e.g. [Notation "0" := False], or [Notation "00" := (nil,nil)], or [Notation "2e1" := ...]). Those notations override the generic - interpretation as numeral. So, one has to record the form of the - numeral which exactly matches the notation. *) + interpretation as number. So, one has to record the form of the + number which exactly matches the notation. *) type sign = SPlus | SMinus @@ -44,7 +44,7 @@ sig val sprint : t -> string val print : t -> Pp.t - (** [sprint] and [print] returns the numeral as it was parsed, for printing *) + (** [sprint] and [print] returns the number as it was parsed, for printing *) val classify : t -> num_class @@ -69,7 +69,7 @@ sig val to_bigint : t -> Z.t end -(** {6 Unsigned decimal numerals } *) +(** {6 Unsigned decimal numbers } *) module Unsigned : sig @@ -80,12 +80,12 @@ sig val sprint : t -> string val print : t -> Pp.t - (** [sprint] and [print] returns the numeral as it was parsed, for printing *) + (** [sprint] and [print] returns the number as it was parsed, for printing *) val parse : char Stream.t -> t - (** Parse a positive Coq numeral. + (** Parse a positive Coq number. Precondition: the first char on the stream is already known to be a digit (\[0-9\]). - Precondition: at least two extra chars after the numeral to parse. + Precondition: at least two extra chars after the number to parse. The recognized syntax is: - integer part: \[0-9\]\[0-9_\]* @@ -97,13 +97,13 @@ sig - exponent part: empty or \[pP\]\[+-\]?\[0-9\]\[0-9_\]* *) val parse_string : string -> t option - (** Parse the string as a non negative Coq numeral, if possible *) + (** Parse the string as a non negative Coq number, if possible *) val classify : t -> num_class end -(** {6 Signed decimal numerals } *) +(** {6 Signed decimal numbers } *) module Signed : sig @@ -117,10 +117,10 @@ sig val sprint : t -> string val print : t -> Pp.t - (** [sprint] and [print] returns the numeral as it was parsed, for printing *) + (** [sprint] and [print] returns the number as it was parsed, for printing *) val parse_string : string -> t option - (** Parse the string as a signed Coq numeral, if possible *) + (** Parse the string as a signed Coq number, if possible *) val of_int_string : string -> t (** Convert from a string in the syntax of OCaml's int/int64 *) diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index f485970eec..d8d2f2a2ef 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -823,7 +823,7 @@ let token_text : type c. c Tok.p -> string = function | PKEYWORD t -> "'" ^ t ^ "'" | PIDENT None -> "identifier" | PIDENT (Some t) -> "'" ^ t ^ "'" - | PNUMBER None -> "numeral" + | PNUMBER None -> "number" | PNUMBER (Some n) -> "'" ^ NumTok.Unsigned.sprint n ^ "'" | PSTRING None -> "string" | PSTRING (Some s) -> "STRING \"" ^ s ^ "\"" @@ -916,7 +916,7 @@ let terminal s = if is_ident_not_keyword s then PIDENT (Some s) else PKEYWORD s -(* Precondition: the input is a numeral (c.f. [NumTok.t]) *) -let terminal_numeral s = match NumTok.Unsigned.parse_string s with +(* Precondition: the input is a number (c.f. [NumTok.t]) *) +let terminal_number s = match NumTok.Unsigned.parse_string s with | Some n -> PNUMBER (Some n) - | None -> failwith "numeral token expected." + | None -> failwith "number token expected." diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index ac2c5bcfe2..af4b7ba334 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -49,8 +49,8 @@ val check_keyword : string -> unit (** When string is not an ident, returns a keyword. *) val terminal : string -> string Tok.p -(** Precondition: the input is a numeral (c.f. [NumTok.t]) *) -val terminal_numeral : string -> NumTok.Unsigned.t Tok.p +(** Precondition: the input is a number (c.f. [NumTok.t]) *) +val terminal_number : string -> NumTok.Unsigned.t Tok.p (** The lexer of Coq: *) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 349e14bba3..67a061175a 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -173,10 +173,10 @@ GRAMMAR EXTEND Gram [ c = atomic_constr -> { c } | c = term_match -> { c } | "("; c = term LEVEL "200"; ")" -> - { (* Preserve parentheses around numerals so that constrintern does not - collapse -(3) into the numeral -3. *) + { (* Preserve parentheses around numbers so that constrintern does not + collapse -(3) into the number -3. *) (match c.CAst.v with - | CPrim (Numeral (NumTok.SPlus,n)) -> + | CPrim (Number (NumTok.SPlus,n)) -> CAst.make ~loc @@ CNotation(None,(InConstrEntry,"( _ )"),([c],[],[],[])) | _ -> c) } | "{|"; c = record_declaration; bar_cbrace -> { c } @@ -258,7 +258,7 @@ GRAMMAR EXTEND Gram atomic_constr: [ [ g = global; i = univ_annot -> { CAst.make ~loc @@ CRef (g,i) } | s = sort -> { CAst.make ~loc @@ CSort s } - | n = NUMBER-> { CAst.make ~loc @@ CPrim (Numeral (NumTok.SPlus,n)) } + | n = NUMBER-> { CAst.make ~loc @@ CPrim (Number (NumTok.SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPrim (String s) } | "_" -> { CAst.make ~loc @@ CHole (None, IntroAnonymous, None) } | "?"; "["; id = identref; "]" -> { CAst.make ~loc @@ CHole (None, IntroIdentifier id.CAst.v, None) } @@ -362,15 +362,15 @@ GRAMMAR EXTEND Gram | "{|"; pat = record_patterns; bar_cbrace -> { CAst.make ~loc @@ CPatRecord pat } | "_" -> { CAst.make ~loc @@ CPatAtom None } | "("; p = pattern LEVEL "200"; ")" -> - { (* Preserve parentheses around numerals so that constrintern does not - collapse -(3) into the numeral -3. *) + { (* Preserve parentheses around numbers so that constrintern does not + collapse -(3) into the number -3. *) match p.CAst.v with - | CPatPrim (Numeral (NumTok.SPlus,n)) -> + | CPatPrim (Number (NumTok.SPlus,n)) -> CAst.make ~loc @@ CPatNotation(None,(InConstrEntry,"( _ )"),([p],[]),[]) | _ -> p } | "("; p = pattern LEVEL "200"; "|" ; pl = LIST1 pattern LEVEL "200" SEP "|"; ")" -> { CAst.make ~loc @@ CPatOr (p::pl) } - | n = NUMBER-> { CAst.make ~loc @@ CPatPrim (Numeral (NumTok.SPlus,n)) } + | n = NUMBER-> { CAst.make ~loc @@ CPatPrim (Number (NumTok.SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPatPrim (String s) } ] ] ; fixannot: diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 97d75261c5..ecfe6c1664 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -121,8 +121,8 @@ let destruction_arg_of_constr (c,lbind as clbind) = match lbind with end | _ -> ElimOnConstr clbind -let mkNumeral n = - Numeral (NumTok.Signed.of_int_string (string_of_int n)) +let mkNumber n = + Number (NumTok.Signed.of_int_string (string_of_int n)) let mkTacCase with_evar = function | [(clear,ElimOnConstr cl),(None,None),None],None -> @@ -130,7 +130,7 @@ let mkTacCase with_evar = function (* Reinterpret numbers as a notation for terms *) | [(clear,ElimOnAnonHyp n),(None,None),None],None -> TacCase (with_evar, - (clear,(CAst.make @@ CPrim (mkNumeral n), + (clear,(CAst.make @@ CPrim (mkNumber n), NoBindings))) (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 35fecfb0a5..ccdf5fa68e 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -350,7 +350,7 @@ let interp_index ist gl idx = | Some c -> let rc = Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc (None, []) with - | Constrexpr.Numeral n, _ when NumTok.Signed.is_int n -> + | Constrexpr.Number n, _ when NumTok.Signed.is_int n -> int_of_string (NumTok.Signed.to_string n) | _ -> raise Not_found end diff --git a/plugins/syntax/int63_syntax.ml b/plugins/syntax/int63_syntax.ml index 5f4db8e800..73a9341145 100644 --- a/plugins/syntax/int63_syntax.ml +++ b/plugins/syntax/int63_syntax.ml @@ -50,7 +50,7 @@ let _ = enable_prim_token_interpretation { pt_local = false; pt_scope = int63_scope; - pt_interp_info = NumeralNotation o; + pt_interp_info = NumberNotation o; pt_required = (int63_path, int63_module); pt_refs = []; pt_in_match = false }) diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 313798b102..8635f39f1a 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -90,7 +90,7 @@ let locate_number () = int = int_ty; decimal = unsafe_locate_ind q_dec; hexadecimal = unsafe_locate_ind q_hex; - numeral = unsafe_locate_ind q_num; + number = unsafe_locate_ind q_num; } in Some (int_ty, mkRefC q_int, mkRefC q_uint, mkRefC q_dint, mkRefC q_duint, num_ty, mkRefC q_num, mkRefC q_dec) @@ -151,8 +151,8 @@ let vernac_number_notation local ty f g scope opts = | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint cty) -> UInt int_ty, Direct | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty, Option - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Numeral num_ty, Direct - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Numeral num_ty, Option + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Number num_ty, Direct + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Number num_ty, Option | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint cty) -> DecimalInt int_ty, Direct | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> DecimalInt int_ty, Option | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint cty) -> DecimalUInt int_ty, Direct @@ -176,8 +176,8 @@ let vernac_number_notation local ty f g scope opts = | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty cuint) -> UInt int_ty, Direct | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty, Option - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Numeral num_ty, Direct - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Numeral num_ty, Option + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Number num_ty, Direct + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Number num_ty, Option | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty cint) -> DecimalInt int_ty, Direct | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> DecimalInt int_ty, Option | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty cuint) -> DecimalUInt int_ty, Direct @@ -209,7 +209,7 @@ let vernac_number_notation local ty f g scope opts = let i = { pt_local = local; pt_scope = scope; - pt_interp_info = NumeralNotation o; + pt_interp_info = NumberNotation o; pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; pt_refs = constructors; pt_in_match = true } diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 8da1d636f0..d762959ede 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -77,8 +77,8 @@ let tag_var = tag Tag.variable | LevelSome -> true let prec_of_prim_token = function - | Numeral (NumTok.SPlus,_) -> lposint - | Numeral (NumTok.SMinus,_) -> lnegint + | Number (NumTok.SPlus,_) -> lposint + | Number (NumTok.SMinus,_) -> lnegint | String _ -> latom let print_hunks n pr pr_patt pr_binders (terms, termlists, binders, binderlists) unps = @@ -222,7 +222,7 @@ let tag_var = tag Tag.variable | t -> str " :" ++ pr_sep_com (fun()->brk(1,4)) (pr ltop) t let pr_prim_token = function - | Numeral n -> NumTok.Signed.print n + | Number n -> NumTok.Signed.print n | String s -> qs s let pr_evar pr id l = diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index 123ea2c24e..efe4e17d0b 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -408,8 +408,8 @@ match e with | TTClosedBinderList _ -> { subst with binderlists = List.flatten v :: subst.binderlists } | TTBigint -> begin match forpat with - | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (NumTok.Signed.of_int_string v))) - | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (NumTok.Signed.of_int_string v))) + | ForConstr -> push_constr subst (CAst.make @@ CPrim (Number (NumTok.Signed.of_int_string v))) + | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Number (NumTok.Signed.of_int_string v))) end | TTReference -> begin match forpat with -- cgit v1.2.3 From 814c16e348165cb19f70105dcf5d47e28f02c25e Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Fri, 30 Oct 2020 15:15:09 +0100 Subject: Add kernel/float64.ml to gitignore This is a generated file since #13147 --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index bdd692420f..aab1d1ede7 100644 --- a/.gitignore +++ b/.gitignore @@ -155,6 +155,7 @@ kernel/byterun/coq_jumptbl.h kernel/genOpcodeFiles.exe kernel/vmopcodes.ml kernel/uint63.ml +kernel/float64.ml ide/coqide/default.bindings ide/coqide/default_bindings_src.exe ide/coqide/index_urls.txt -- cgit v1.2.3 From 3f04bd0a74575d93b2a5c1dfff2bd5a364bfac59 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:10:00 +0200 Subject: Add functions Smartlocate.global_{constant,constructor} --- interp/smartlocate.ml | 38 +++++++++++++++++++++++++++++++++----- interp/smartlocate.mli | 12 ++++++++++++ 2 files changed, 45 insertions(+), 5 deletions(-) diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 33d8aa6064..46baa00c74 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -50,6 +50,16 @@ let locate_global_with_alias ?(head=false) qid = user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is bound to a notation that does not denote a reference.") +let global_constant_with_alias qid = + try match locate_global_with_alias qid with + | Names.GlobRef.ConstRef c -> c + | ref -> + user_err ?loc:qid.CAst.loc ~hdr:"global_inductive" + (pr_qualid qid ++ spc () ++ str "is not a reference to a constant.") + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid + let global_inductive_with_alias qid = try match locate_global_with_alias qid with | Names.GlobRef.IndRef ind -> ind @@ -60,6 +70,16 @@ let global_inductive_with_alias qid = let _, info = Exninfo.capture exn in Nametab.error_global_not_found ~info qid +let global_constructor_with_alias qid = + try match locate_global_with_alias qid with + | Names.GlobRef.ConstructRef c -> c + | ref -> + user_err ?loc:qid.CAst.loc ~hdr:"global_inductive" + (pr_qualid qid ++ spc () ++ str "is not a constructor of an inductive type.") + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid + let global_with_alias ?head qid = try locate_global_with_alias ?head qid with Not_found as exn -> @@ -72,9 +92,17 @@ let smart_global ?(head = false) = let open Constrexpr in CAst.with_loc_val (fun | ByNotation (ntn,sc) -> Notation.interp_notation_as_global_reference ?loc ~head (fun _ -> true) ntn sc) -let smart_global_inductive = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function - | AN r -> - global_inductive_with_alias r +let smart_global_kind f dest is = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function + | AN r -> f r | ByNotation (ntn,sc) -> - destIndRef - (Notation.interp_notation_as_global_reference ?loc ~head:false isIndRef ntn sc)) + dest + (Notation.interp_notation_as_global_reference ?loc ~head:false is ntn sc)) + +let smart_global_constant = + smart_global_kind global_constant_with_alias destConstRef isConstRef + +let smart_global_inductive = + smart_global_kind global_inductive_with_alias destIndRef isIndRef + +let smart_global_constructor = + smart_global_kind global_constructor_with_alias destConstructRef isConstructRef diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli index 9b24a62086..26f2a4f36d 100644 --- a/interp/smartlocate.mli +++ b/interp/smartlocate.mli @@ -28,11 +28,23 @@ val global_of_extended_global : extended_global_reference -> GlobRef.t a reference. *) val global_with_alias : ?head:bool -> qualid -> GlobRef.t +(** The same for constants *) +val global_constant_with_alias : qualid -> Constant.t + (** The same for inductive types *) val global_inductive_with_alias : qualid -> inductive +(** The same for constructors of an inductive type *) +val global_constructor_with_alias : qualid -> constructor + (** Locate a reference taking into account notations and "aliases" *) val smart_global : ?head:bool -> qualid Constrexpr.or_by_notation -> GlobRef.t +(** The same for constants *) +val smart_global_constant : qualid Constrexpr.or_by_notation -> Constant.t + (** The same for inductive types *) val smart_global_inductive : qualid Constrexpr.or_by_notation -> inductive + +(** The same for constructors of an inductive type *) +val smart_global_constructor : qualid Constrexpr.or_by_notation -> constructor -- cgit v1.2.3 From dfcb15141a19db4f1cc61c14d1cdad0275009356 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:11:00 +0200 Subject: [numeral notation] Add a pre/postprocessing This will enable to define numeral notation on non inductive by using an inductive type as proxy and those translations to translate to/from the actual type to the inductive type. --- interp/notation.ml | 119 ++++++++++++++++++++++++++++++++------ interp/notation.mli | 13 +++++ plugins/syntax/int63_syntax.ml | 1 + plugins/syntax/numeral.ml | 2 +- plugins/syntax/string_notation.ml | 1 + 5 files changed, 116 insertions(+), 20 deletions(-) diff --git a/interp/notation.ml b/interp/notation.ml index 8a35eeb203..073a1d24fc 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -542,9 +542,22 @@ type string_target_kind = type option_kind = Option | Direct type 'target conversion_kind = 'target * option_kind +(** A postprocessing translation [to_post] can be done after execution + of the [to_ty] interpreter. The reverse translation is performed + before the [of_ty] uninterpreter. + + [to_post] is an array of [n] lists [l_i] of tuples [(f, t, + args)]. When the head symbol of the translated term matches one of + the [f] in the list [l_0] it is replaced by [t] and its arguments + are translated acording to [args] where [ToPostCopy] means that the + argument is kept unchanged and [ToPostAs k] means that the + argument is recursively translated according to [l_k]. + When [n] is null, no translation is performed. *) +type to_post_arg = ToPostCopy | ToPostAs of int type ('target, 'warning) prim_token_notation_obj = { to_kind : 'target conversion_kind; to_ty : GlobRef.t; + to_post : ((GlobRef.t * GlobRef.t * to_post_arg list) list) array; of_kind : 'target conversion_kind; of_ty : GlobRef.t; ty_name : Libnames.qualid; (* for warnings / error messages *) @@ -593,17 +606,55 @@ exception NotAValidPrimToken what it means for a term to be ground / to be able to be considered for parsing. *) -let rec constr_of_glob env sigma g = match DAst.get g with - | Glob_term.GRef (GlobRef.ConstructRef c, _) -> - let sigma,c = Evd.fresh_constructor_instance env sigma c in - sigma,mkConstructU c - | Glob_term.GRef (GlobRef.IndRef c, _) -> - let sigma,c = Evd.fresh_inductive_instance env sigma c in - sigma,mkIndU c +let constr_of_globref allow_constant env sigma = function + | GlobRef.ConstructRef c -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma,mkConstructU c + | GlobRef.IndRef c -> + let sigma,c = Evd.fresh_inductive_instance env sigma c in + sigma,mkIndU c + | GlobRef.ConstRef c when allow_constant -> + let sigma,c = Evd.fresh_constant_instance env sigma c in + sigma,mkConstU c + | _ -> raise NotAValidPrimToken + +let rec constr_of_glob to_post post env sigma g = match DAst.get g with + | Glob_term.GRef (r, _) -> + let o = List.find_opt (fun (_,r',_) -> GlobRef.equal r r') post in + begin match o with + | None -> constr_of_globref false env sigma r + | Some (r, _, a) -> + (* [g] is not a GApp so check that [post] + does not expect any argument (i.e., a = []) *) + if a <> [] then raise NotAValidPrimToken; + constr_of_globref true env sigma r + end | Glob_term.GApp (gc, gcl) -> - let sigma,c = constr_of_glob env sigma gc in - let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in - sigma,mkApp (c, Array.of_list cl) + let o = match DAst.get gc with + | Glob_term.GRef (r, _) -> List.find_opt (fun (_,r',_) -> GlobRef.equal r r') post + | _ -> None in + begin match o with + | None -> + let sigma,c = constr_of_glob to_post post env sigma gc in + let sigma,cl = List.fold_left_map (constr_of_glob to_post post env) sigma gcl in + sigma,mkApp (c, Array.of_list cl) + | Some (r, _, a) -> + let sigma,c = constr_of_globref true env sigma r in + let rec aux sigma a gcl = match a, gcl with + | [], [] -> sigma,[] + | ToPostCopy :: a, gc :: gcl -> + let sigma,c = constr_of_glob [||] [] env sigma gc in + let sigma,cl = aux sigma a gcl in + sigma, c :: cl + | ToPostAs i :: a, gc :: gcl -> + let sigma,c = constr_of_glob to_post to_post.(i) env sigma gc in + let sigma,cl = aux sigma a gcl in + sigma, c :: cl + | [], _ :: _ | _ :: _, [] -> raise NotAValidPrimToken + in + let sigma,cl = aux sigma a gcl in + sigma,mkApp (c, Array.of_list cl) + end | Glob_term.GInt i -> sigma, mkInt i | Glob_term.GSort gs -> let sigma,c = Evd.fresh_sort_in_family sigma (Glob_ops.glob_sort_family gs) in @@ -611,6 +662,10 @@ let rec constr_of_glob env sigma g = match DAst.get g with | _ -> raise NotAValidPrimToken +let constr_of_glob to_post env sigma (Glob_term.AnyGlobConstr g) = + let post = match to_post with [||] -> [] | _ -> to_post.(0) in + constr_of_glob to_post post env sigma g + let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with | App (c, ca) -> let c = glob_of_constr token_kind ?loc env sigma c in @@ -632,9 +687,34 @@ let no_such_prim_token uninterpreted_token_kind ?loc ty = (str ("Cannot interpret this "^uninterpreted_token_kind^" as a value of type ") ++ pr_qualid ty) -let interp_option uninterpreted_token_kind token_kind ty ?loc env sigma c = +let rec postprocess token_kind ?loc ty to_post post g = + let g', gl = match DAst.get g with Glob_term.GApp (g, gl) -> g, gl | _ -> g, [] in + let o = + match DAst.get g' with + | Glob_term.GRef (r, None) -> + List.find_opt (fun (r',_,_) -> GlobRef.equal r r') post + | _ -> None in + match o with None -> g | Some (_, r, a) -> + let rec f a gl = match a, gl with + | [], [] -> [] + | ToPostCopy :: a, g :: gl -> g :: f a gl + | ToPostAs c :: a, g :: gl -> + postprocess token_kind ?loc ty to_post to_post.(c) g :: f a gl + | [], _::_ | _::_, [] -> + no_such_prim_token token_kind ?loc ty + in + let gl = f a gl in + let g = DAst.make ?loc (Glob_term.GRef (r, None)) in + DAst.make ?loc (Glob_term.GApp (g, gl)) + +let glob_of_constr token_kind ty ?loc env sigma to_post c = + let g = glob_of_constr token_kind ?loc env sigma c in + match to_post with [||] -> g | _ -> + postprocess token_kind ?loc ty to_post to_post.(0) g + +let interp_option uninterpreted_token_kind token_kind ty ?loc env sigma to_post c = match Constr.kind c with - | App (_Some, [| _; c |]) -> glob_of_constr token_kind ?loc env sigma c + | App (_Some, [| _; c |]) -> glob_of_constr token_kind ty ?loc env sigma to_post c | App (_None, [| _ |]) -> no_such_prim_token uninterpreted_token_kind ?loc ty | x -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedNonOptionTerm c)) @@ -643,13 +723,13 @@ let uninterp_option c = | App (_Some, [| _; x |]) -> x | _ -> raise NotAValidPrimToken -let uninterp to_raw o (Glob_term.AnyGlobConstr n) = +let uninterp to_raw o n = let env = Global.env () in let sigma = Evd.from_env env in let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in let of_ty = EConstr.Unsafe.to_constr of_ty in try - let sigma,n = constr_of_glob env sigma n in + let sigma,n = constr_of_glob o.to_post env sigma n in let c = eval_constr_app env sigma of_ty n in let c = if snd o.of_kind == Direct then c else uninterp_option c in Some (to_raw (fst o.of_kind, c)) @@ -959,12 +1039,13 @@ let interp o ?loc n = match o.warning, snd o.to_kind with | Abstract threshold, Direct when NumTok.Signed.is_bigger_int_than n threshold -> warn_abstract_large_num (o.ty_name,o.to_ty); - glob_of_constr "number" ?loc env sigma (mkApp (to_ty,[|c|])) + assert (Array.length o.to_post = 0); + glob_of_constr "number" o.ty_name ?loc env sigma o.to_post (mkApp (to_ty,[|c|])) | _ -> let res = eval_constr_app env sigma to_ty c in match snd o.to_kind with - | Direct -> glob_of_constr "number" ?loc env sigma res - | Option -> interp_option "number" "number" o.ty_name ?loc env sigma res + | Direct -> glob_of_constr "number" o.ty_name ?loc env sigma o.to_post res + | Option -> interp_option "number" "number" o.ty_name ?loc env sigma o.to_post res let uninterp o n = PrimTokenNotation.uninterp @@ -1068,8 +1149,8 @@ let interp o ?loc n = let to_ty = EConstr.Unsafe.to_constr to_ty in let res = eval_constr_app env sigma to_ty c in match snd o.to_kind with - | Direct -> glob_of_constr "string" ?loc env sigma res - | Option -> interp_option "string" "string" o.ty_name ?loc env sigma res + | Direct -> glob_of_constr "string" o.ty_name ?loc env sigma o.to_post res + | Option -> interp_option "string" "string" o.ty_name ?loc env sigma o.to_post res let uninterp o n = PrimTokenNotation.uninterp diff --git a/interp/notation.mli b/interp/notation.mli index 918744b66a..44143e392f 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -154,9 +154,22 @@ type string_target_kind = type option_kind = Option | Direct type 'target conversion_kind = 'target * option_kind +(** A postprocessing translation [to_post] can be done after execution + of the [to_ty] interpreter. The reverse translation is performed + before the [of_ty] uninterpreter. + + [to_post] is an array of [n] lists [l_i] of tuples [(f, t, + args)]. When the head symbol of the translated term matches one of + the [f] in the list [l_0] it is replaced by [t] and its arguments + are translated acording to [args] where [ToPostCopy] means that the + argument is kept unchanged and [ToPostAs k] means that the + argument is recursively translated according to [l_k]. + When [n] is null, no translation is performed. *) +type to_post_arg = ToPostCopy | ToPostAs of int type ('target, 'warning) prim_token_notation_obj = { to_kind : 'target conversion_kind; to_ty : GlobRef.t; + to_post : ((GlobRef.t * GlobRef.t * to_post_arg list) list) array; of_kind : 'target conversion_kind; of_ty : GlobRef.t; ty_name : Libnames.qualid; (* for warnings / error messages *) diff --git a/plugins/syntax/int63_syntax.ml b/plugins/syntax/int63_syntax.ml index 73a9341145..b14b02f3bb 100644 --- a/plugins/syntax/int63_syntax.ml +++ b/plugins/syntax/int63_syntax.ml @@ -43,6 +43,7 @@ let _ = let id_int63 = Nametab.locate q_id_int63 in let o = { to_kind = Int63, Direct; to_ty = id_int63; + to_post = [||]; of_kind = Int63, Direct; of_ty = id_int63; ty_name = q_int63; diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 8635f39f1a..ad90a9a982 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -199,7 +199,7 @@ let vernac_number_notation local ty f g scope opts = | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> warn_deprecated_decimal () | _ -> ()); - let o = { to_kind; to_ty; of_kind; of_ty; + let o = { to_kind; to_ty; to_post = [||]; of_kind; of_ty; ty_name = ty; warning = opts } in diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index e7ed0d8061..dbb0e92d5c 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -82,6 +82,7 @@ let vernac_string_notation local ty f g scope = in let o = { to_kind = to_kind; to_ty = to_ty; + to_post = [||]; of_kind = of_kind; of_ty = of_ty; ty_name = ty; -- cgit v1.2.3 From 11a8997dd8fa83537607272692a3baf10dab342a Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:12:00 +0200 Subject: [numeral notation] Adding the via ... using ... option This enables numeral notations for non inductive types by pre/postprocessing them to a given proxy inductive type. For instance, this should enable the use of numeral notations for R. --- doc/tools/docgram/common.edit_mlg | 8 +- doc/tools/docgram/fullGrammar | 12 +- doc/tools/docgram/orderedGrammar | 14 ++- plugins/syntax/g_numeral.mlg | 58 ++++++++-- plugins/syntax/numeral.ml | 233 +++++++++++++++++++++++++++++++++++++- plugins/syntax/numeral.mli | 11 +- theories/Init/Prelude.v | 4 +- 7 files changed, 312 insertions(+), 28 deletions(-) diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 5d0f9208fc..4d615a130a 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -1285,10 +1285,10 @@ command: [ | WITH "Declare" "Scope" scope_name (* odd that these are in command while other notation-related ones are in syntax *) -| REPLACE "Numeral" "Notation" reference reference reference ":" ident number_modifier -| WITH "Numeral" "Notation" reference reference reference ":" scope_name number_modifier -| REPLACE "Number" "Notation" reference reference reference ":" ident number_modifier -| WITH "Number" "Notation" reference reference reference ":" scope_name number_modifier +| REPLACE "Number" "Notation" reference OPT number_via reference reference ":" ident number_modifier +| WITH "Number" "Notation" reference OPT number_via reference reference ":" scope_name number_modifier +| REPLACE "Numeral" "Notation" reference OPT number_via reference reference ":" ident number_modifier +| WITH "Numeral" "Notation" reference OPT number_via reference reference ":" scope_name number_modifier | REPLACE "String" "Notation" reference reference reference ":" ident | WITH "String" "Notation" reference reference reference ":" scope_name diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 914347b4cf..8a0feb0e2f 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -686,8 +686,8 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" constr OPT field_mods (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Number" "Notation" reference reference reference ":" ident number_modifier -| "Numeral" "Notation" reference reference reference ":" ident number_modifier +| "Number" "Notation" reference OPT number_via reference reference ":" ident number_modifier +| "Numeral" "Notation" reference OPT number_via reference reference ":" ident number_modifier | "String" "Notation" reference reference reference ":" ident | "Ltac2" ltac2_entry (* Ltac2 plugin *) | "Ltac2" "Eval" ltac2_expr6 (* Ltac2 plugin *) @@ -2555,6 +2555,14 @@ number_modifier: [ | "(" "abstract" "after" bignat ")" ] +number_using: [ +| reference reference +] + +number_via: [ +| "via" reference "using" "(" LIST1 number_using SEP "," ")" +] + tac2pat1: [ | Prim.qualid LIST1 tac2pat0 (* Ltac2 plugin *) | Prim.qualid (* Ltac2 plugin *) diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index a972ad4719..d12b3bf6cd 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -884,8 +884,8 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Number" "Notation" qualid qualid qualid ":" scope_name OPT number_modifier -| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT number_modifier +| "Number" "Notation" qualid OPT number_via qualid qualid ":" scope_name OPT number_modifier +| "Numeral" "Notation" qualid OPT number_via qualid qualid ":" scope_name OPT number_modifier | "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) | "Typeclasses" "Transparent" LIST1 qualid | "Typeclasses" "Opaque" LIST1 qualid @@ -910,7 +910,7 @@ command: [ | "Derive" "Dependent" "Inversion_clear" ident "with" one_term "Sort" sort_family | "Declare" "Left" "Step" one_term | "Declare" "Right" "Step" one_term -| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT number_modifier +| "Numeral" "Notation" qualid OPT number_via qualid qualid ":" scope_name OPT number_modifier | "String" "Notation" qualid qualid qualid ":" scope_name | "SubClass" ident_decl def_body | thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] @@ -1275,6 +1275,14 @@ number_modifier: [ | "(" "abstract" "after" bignat ")" ] +number_using: [ +| qualid qualid +] + +number_via: [ +| "via" qualid "using" "(" LIST1 number_using SEP "," ")" +] + hints_path: [ | "(" hints_path ")" | hints_path "*" diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index 48e262c3ef..e60ae45b01 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -19,33 +19,71 @@ open Names open Stdarg open Pcoq.Prim -let pr_number_modifier = function +let pr_number_after = function | Nop -> mt () - | Warning n -> str "(warning after " ++ NumTok.UnsignedNat.print n ++ str ")" - | Abstract n -> str "(abstract after " ++ NumTok.UnsignedNat.print n ++ str ")" + | Warning n -> str "warning after " ++ NumTok.UnsignedNat.print n + | Abstract n -> str "abstract after " ++ NumTok.UnsignedNat.print n + +let pr_deprecated_number_modifier m = str "(" ++ pr_number_after m ++ str ")" let warn_deprecated_numeral_notation = CWarnings.create ~name:"numeral-notation" ~category:"deprecated" (fun () -> strbrk "Numeral Notation is deprecated, please use Number Notation instead.") +let pr_number_mapping (n, n') = + Libnames.pr_qualid n ++ spc () ++ str "=>" ++ spc () ++ Libnames.pr_qualid n' + +let pr_number_via (n, l) = + str "via " ++ Libnames.pr_qualid n ++ str " mapping [" + ++ prlist_with_sep pr_comma pr_number_mapping l ++ str "]" + +let pr_number_modifier = function + | After a -> pr_number_after a + | Via nl -> pr_number_via nl + +let pr_number_options l = + str "(" ++ prlist_with_sep pr_comma pr_number_modifier l ++ str ")" + } -VERNAC ARGUMENT EXTEND number_modifier - PRINTED BY { pr_number_modifier } +VERNAC ARGUMENT EXTEND deprecated_number_modifier + PRINTED BY { pr_deprecated_number_modifier } | [ ] -> { Nop } | [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } | [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } END +VERNAC ARGUMENT EXTEND number_mapping + PRINTED BY { pr_number_mapping } +| [ reference(n) "=>" reference(n') ] -> { n, n' } +END + +VERNAC ARGUMENT EXTEND number_via + PRINTED BY { pr_number_via } +| [ "via" reference(n) "mapping" "[" ne_number_mapping_list_sep(l, ",") "]" ] -> { n, l } +END + +VERNAC ARGUMENT EXTEND number_modifier + PRINTED BY { pr_number_modifier } +| [ "warning" "after" bignat(waft) ] -> { After (Warning (NumTok.UnsignedNat.of_string waft)) } +| [ "abstract" "after" bignat(n) ] -> { After (Abstract (NumTok.UnsignedNat.of_string n)) } +| [ number_via(v) ] -> { Via v } +END + +VERNAC ARGUMENT EXTEND number_options + PRINTED BY { pr_number_options } +| [ "(" ne_number_modifier_list_sep(l, ",") ")" ] -> { l } +END + VERNAC COMMAND EXTEND NumberNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) number_modifier(o) ] -> + | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) number_options_opt(nl) ":" + ident(sc) ] -> - { vernac_number_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } + { vernac_number_notation (Locality.make_module_locality locality) ty f g (Option.default [] nl) (Id.to_string sc) } | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) number_modifier(o) ] -> + ident(sc) deprecated_number_modifier(o) ] -> { warn_deprecated_numeral_notation (); - vernac_number_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } + vernac_number_notation (Locality.make_module_locality locality) ty f g [After o] (Id.to_string sc) } END diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index ad90a9a982..316ca456a4 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -16,8 +16,16 @@ open Constrexpr open Constrexpr_ops open Notation +module CSet = CSet.Make (Constr) +module CMap = CMap.Make (Constr) + (** * Number notation *) +type number_string_via = qualid * (qualid * qualid) list +type number_option = + | After of numnot_option + | Via of number_string_via + let warn_abstract_large_num_no_op = CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" (fun f -> @@ -128,12 +136,228 @@ let warn_deprecated_decimal = Decimal.int or Decimal.decimal. Use Number.uint, \ Number.int or Number.number respectively.") -let vernac_number_notation local ty f g scope opts = +let remapping_error ?loc ty ty' ty'' = + CErrors.user_err ?loc + (Printer.pr_global ty + ++ str " was already mapped to" ++ spc () ++ Printer.pr_global ty' + ++ str " and cannot be remapped to" ++ spc () ++ Printer.pr_global ty'' + ++ str ".") + +let error_missing c = + CErrors.user_err + (str "Missing mapping for constructor " ++ Printer.pr_global c ++ str ".") + +let pr_constr env sigma c = + let c = Constrextern.extern_constr env sigma (EConstr.of_constr c) in + Ppconstr.pr_constr_expr env sigma c + +let warn_via_remapping = + CWarnings.create ~name:"via-type-remapping" ~category:"numbers" + (fun (env, sigma, ty, ty', ty'') -> + let constr = pr_constr env sigma in + constr ty ++ str " was already mapped to" ++ spc () ++ constr ty' + ++ str ", mapping it also to" ++ spc () ++ constr ty'' + ++ str " might yield ill typed terms when using the notation.") + +let warn_via_type_mismatch = + CWarnings.create ~name:"via-type-mismatch" ~category:"numbers" + (fun (env, sigma, g, g', exp, actual) -> + let constr = pr_constr env sigma in + str "Type of" ++ spc() ++ Printer.pr_global g + ++ str " seems incompatible with the type of" ++ spc () + ++ Printer.pr_global g' ++ str "." ++ spc () + ++ str "Expected type is: " ++ constr exp ++ spc () + ++ str "instead of " ++ constr actual ++ str "." ++ spc () + ++ str "This might yield ill typed terms when using the notation.") + +let multiple_via_error () = + CErrors.user_err (Pp.str "Multiple 'via' options.") + +let multiple_after_error () = + CErrors.user_err (Pp.str "Multiple 'warning after' or 'abstract after' options.") + +let via_abstract_error () = + CErrors.user_err (Pp.str "'via' and 'abstract' cannot be used together.") + +let locate_global_sort_inductive_or_constant sigma qid = + let locate_sort qid = + match Nametab.locate_extended qid with + | Globnames.TrueGlobal _ -> raise Not_found + | Globnames.SynDef kn -> + match Syntax_def.search_syntactic_definition kn with + | [], Notation_term.NSort r -> + let sigma,c = Evd.fresh_sort_in_family sigma (Glob_ops.glob_sort_family r) in + sigma,Constr.mkSort c + | _ -> raise Not_found in + try locate_sort qid + with Not_found -> + match Smartlocate.global_with_alias qid with + | GlobRef.IndRef i -> sigma, Constr.mkInd i + | _ -> sigma, Constr.mkConst (Smartlocate.global_constant_with_alias qid) + +let locate_global_constructor_inductive_or_constant qid = + let g = Smartlocate.global_with_alias qid in + match g with + | GlobRef.ConstructRef c -> g, Constr.mkConstruct c + | GlobRef.IndRef i -> g, Constr.mkInd i + | _ -> g, Constr.mkConst (Smartlocate.global_constant_with_alias qid) + +(* [get_type env sigma c] retrieves the type of [c] and returns a pair + [l, t] such that [c : l_0 -> ... -> l_n -> t]. *) +let get_type env sigma c = + (* inspired from [compute_implicit_names] in "interp/impargs.ml" *) + let rec aux env acc t = + let t = Reductionops.whd_all env sigma t in + match EConstr.kind sigma t with + | Constr.Prod (na, a, b) -> + let a = Reductionops.whd_all env sigma a in + let rel = Context.Rel.Declaration.LocalAssum (na, a) in + aux (EConstr.push_rel rel env) ((na, a) :: acc) b + | _ -> List.rev acc, t in + let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let l, t = aux env [] t in + List.map (fun (na, a) -> na, EConstr.Unsafe.to_constr a) l, + EConstr.Unsafe.to_constr t + +(* [elaborate_to_post env sigma ty_name ty_ind l] builds the [to_post] + translation (c.f., interp/notation.mli) for the number notation to + parse/print type [ty_name] through the inductive [ty_ind] according + to the pairs [constant, constructor] in the list [l]. *) +let elaborate_to_post env sigma ty_name ty_ind l = + let sigma, ty_name = + locate_global_sort_inductive_or_constant sigma ty_name in + let ty_ind = Constr.mkInd ty_ind in + (* Retrieve constants and constructors mappings and their type. + For each constant [cnst] and inductive constructor [indc] in [l], retrieve: + * its location: [lcnst] and [lindc] + * its GlobRef: [cnst] and [indc] + * its type: [tcnst] and [tindc] (decomposed in product by [get_type] above) *) + let l = + let read (cnst, indc) = + let lcnst, lindc = cnst.CAst.loc, indc.CAst.loc in + let cnst, ccnst = locate_global_constructor_inductive_or_constant cnst in + let indc, cindc = + let indc = Smartlocate.global_constructor_with_alias indc in + GlobRef.ConstructRef indc, Constr.mkConstruct indc in + let get_type_wo_params c = + (* ignore parameters of inductive types *) + let rm_params c = match Constr.kind c with + | Constr.App (c, _) when Constr.isInd c -> c + | _ -> c in + let lc, tc = get_type env sigma c in + List.map (fun (n, c) -> n, rm_params c) lc, rm_params tc in + let tcnst, tindc = get_type_wo_params ccnst, get_type_wo_params cindc in + lcnst, cnst, tcnst, lindc, indc, tindc in + List.map read l in + let eq_indc indc (_, _, _, _, indc', _) = GlobRef.equal indc indc' in + (* Collect all inductive types involved. + That is [ty_ind] and all final codomains of [tindc] above. *) + let inds = + List.fold_left (fun s (_, _, _, _, _, tindc) -> CSet.add (snd tindc) s) + (CSet.singleton ty_ind) l in + (* And for each inductive, retrieve its constructors. *) + let constructors = + CSet.fold (fun ind m -> + let inductive, _ = Constr.destInd ind in + CMap.add ind (get_constructors inductive) m) + inds CMap.empty in + (* Error if one [constructor] in some inductive in [inds] + doesn't appear exactly once in [l] *) + let _ = (* check_for duplicate constructor and error *) + List.fold_left (fun already_seen (_, cnst, _, loc, indc, _) -> + try + let cnst' = List.assoc_f GlobRef.equal indc already_seen in + remapping_error ?loc indc cnst' cnst + with Not_found -> (indc, cnst) :: already_seen) + [] l in + let () = (* check for missing constructor and error *) + CMap.iter (fun _ -> + List.iter (fun cstr -> + if not (List.exists (eq_indc cstr) l) then error_missing cstr)) + constructors in + (* Perform some checks on types and warn if they look strange. + These checks are neither sound nor complete, so we only warn. *) + let () = + (* associate inductives to types, and check that this mapping is one to one + and maps [ty_ind] to [ty_name] *) + let ind2ty, ty2ind = + let add loc ckey cval m = + match CMap.find_opt ckey m with + | None -> CMap.add ckey cval m + | Some old_cval -> + if not (Constr.equal old_cval cval) then + warn_via_remapping ?loc (env, sigma, ckey, old_cval, cval); + m in + List.fold_left + (fun (ind2ty, ty2ind) (lcnst, _, (_, tcnst), lindc, _, (_, tindc)) -> + add lcnst tindc tcnst ind2ty, add lindc tcnst tindc ty2ind) + CMap.(singleton ty_ind ty_name, singleton ty_name ty_ind) l in + (* check that type of constants and constructors mapped in [l] + match modulo [ind2ty] *) + let replace m (l, t) = + let apply_m c = try CMap.find c m with Not_found -> c in + List.fold_right (fun (na, a) b -> Constr.mkProd (na, (apply_m a), b)) + l (apply_m t) in + List.iter (fun (_, cnst, tcnst, loc, indc, tindc) -> + let tcnst' = replace CMap.empty tcnst in + if not (Constr.equal tcnst' (replace ind2ty tindc)) then + let actual = replace CMap.empty tindc in + let expected = replace ty2ind tcnst in + warn_via_type_mismatch ?loc (env, sigma, indc, cnst, expected, actual)) + l in + (* Associate an index to each inductive, starting from 0 for [ty_ind]. *) + let ind2num, num2ind, nb_ind = + CMap.fold (fun ind _ (ind2num, num2ind, i) -> + CMap.add ind i ind2num, Int.Map.add i ind num2ind, i + 1) + (CMap.remove ty_ind constructors) + (CMap.singleton ty_ind 0, Int.Map.singleton 0 ty_ind, 1) in + (* Finally elaborate [to_post] *) + let to_post = + let rec map_prod = function + | [] -> [] + | (_, a) :: b -> + let t = match CMap.find_opt a ind2num with + | Some i -> ToPostAs i + | None -> ToPostCopy in + t :: map_prod b in + Array.init nb_ind (fun i -> + List.map (fun indc -> + let _, cnst, _, _, _, tindc = List.find (eq_indc indc) l in + indc, cnst, map_prod (fst tindc)) + (CMap.find (Int.Map.find i num2ind) constructors)) in + (* and use constants mapped to constructors of [ty_ind] as triggers. *) + let pt_refs = List.map (fun (_, cnst, _) -> cnst) (to_post.(0)) in + to_post, pt_refs + +let elaborate_to_post env sigma ty_ind via = + match via with + | None -> [||], get_constructors ty_ind + | Some (ty_name, l) -> elaborate_to_post env sigma ty_name ty_ind l + +let vernac_number_notation local ty f g opts scope = + let rec parse_opts = function + | [] -> None, Nop + | h :: opts -> + let via, opts = parse_opts opts in + let via = match h, via with + | Via _, Some _ -> multiple_via_error () + | Via v, None -> Some v + | _ -> via in + let opts = match h, opts with + | After _, (Warning _ | Abstract _) -> multiple_after_error () + | After a, Nop -> a + | _ -> opts in + via, opts in + let via, opts = parse_opts opts in + (match via, opts with Some _, Abstract _ -> via_abstract_error () | _ -> ()); let env = Global.env () in let sigma = Evd.from_env env in let num_ty = locate_number () in let z_pos_ty = locate_z () in let int63_ty = locate_int63 () in + let ty_name = ty in + let ty, via = + match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in let tyc = Smartlocate.global_inductive_with_alias ty in let to_ty = Smartlocate.global_with_alias f in let of_ty = Smartlocate.global_with_alias g in @@ -143,7 +367,6 @@ let vernac_number_notation local ty f g scope opts = mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) in let opt r = app (mkRefC (q_option ())) r in - let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = match num_ty with @@ -199,8 +422,8 @@ let vernac_number_notation local ty f g scope opts = | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> warn_deprecated_decimal () | _ -> ()); - let o = { to_kind; to_ty; to_post = [||]; of_kind; of_ty; - ty_name = ty; + let to_post, pt_refs = elaborate_to_post env sigma tyc via in + let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; warning = opts } in (match opts, to_kind with @@ -211,7 +434,7 @@ let vernac_number_notation local ty f g scope opts = pt_scope = scope; pt_interp_info = NumberNotation o; pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; - pt_refs = constructors; + pt_refs; pt_in_match = true } in enable_prim_token_interpretation i diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli index d5fe42b0b4..1f6896d549 100644 --- a/plugins/syntax/numeral.mli +++ b/plugins/syntax/numeral.mli @@ -14,6 +14,13 @@ open Notation (** * Number notation *) +type number_string_via = qualid * (qualid * qualid) list +type number_option = + | After of numnot_option + | Via of number_string_via + val vernac_number_notation : locality_flag -> - qualid -> qualid -> qualid -> - Notation_term.scope_name -> numnot_option -> unit + qualid -> + qualid -> qualid -> + number_option list -> + Notation_term.scope_name -> unit diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 141864d257..0239778bac 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -50,8 +50,8 @@ Number Notation Number.int Number.int_of_int Number.int_of_int : dec_int_scope. (* Parsing / printing of [nat] numbers *) -Number Notation nat Nat.of_num_uint Nat.to_num_hex_uint : hex_nat_scope (abstract after 5001). -Number Notation nat Nat.of_num_uint Nat.to_num_uint : nat_scope (abstract after 5001). +Number Notation nat Nat.of_num_uint Nat.to_num_hex_uint (abstract after 5001) : hex_nat_scope. +Number Notation nat Nat.of_num_uint Nat.to_num_uint (abstract after 5001) : nat_scope. (* Printing/Parsing of bytes *) Export Byte.ByteSyntaxNotations. -- cgit v1.2.3 From 14f301450a356915d131e9f9326b3fa7234241a8 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:13:00 +0200 Subject: [numeral notation] Add tests for the via ... using ... option --- test-suite/output/NumberNotations.out | 58 ++++++++++ test-suite/output/NumberNotations.v | 195 +++++++++++++++++++++++++++++++++- 2 files changed, 248 insertions(+), 5 deletions(-) diff --git a/test-suite/output/NumberNotations.out b/test-suite/output/NumberNotations.out index b00fd3b485..3d9d03ef1a 100644 --- a/test-suite/output/NumberNotations.out +++ b/test-suite/output/NumberNotations.out @@ -234,3 +234,61 @@ let v : ty := Build_ty Type type in v : ty : Prop 1_000 : list nat +0 + : Set +1 + : Set +2 + : Set +3 + : Set +Empty_set + : Set +unit + : Set +sum unit unit + : Set +sum unit (sum unit unit) + : Set +The command has indeed failed with message: +Missing mapping for constructor Isum. +The command has indeed failed with message: +Iunit was already mapped to unit and cannot be remapped to unit. +The command has indeed failed with message: +add is not an inductive type. +The command has indeed failed with message: +add is not a constructor of an inductive type. +The command has indeed failed with message: +Missing mapping for constructor Iempty. +File "stdin", line 574, characters 56-61: +Warning: Type of I'sum seems incompatible with the type of sum. +Expected type is: (I' -> I' -> I') instead of (I -> I' -> I'). +This might yield ill typed terms when using the notation. +[via-type-mismatch,numbers] +File "stdin", line 579, characters 32-33: +Warning: I was already mapped to Set, mapping it also to +nat might yield ill typed terms when using the notation. +[via-type-remapping,numbers] +File "stdin", line 579, characters 37-42: +Warning: Type of Iunit seems incompatible with the type of O. +Expected type is: I instead of I. +This might yield ill typed terms when using the notation. +[via-type-mismatch,numbers] +The command has indeed failed with message: +'via' and 'abstract' cannot be used together. +0 + : Set +1 + : Set +2 + : Set +3 + : Set +Empty_set + : Set +unit + : Set +sum unit unit + : Set +sum unit (sum unit unit) + : Set diff --git a/test-suite/output/NumberNotations.v b/test-suite/output/NumberNotations.v index af0aa895d1..88dc41f4e9 100644 --- a/test-suite/output/NumberNotations.v +++ b/test-suite/output/NumberNotations.v @@ -83,7 +83,7 @@ Module Test4. Polymorphic Definition pto_punits := pto_punit_all@{Set}. Polymorphic Definition pof_punits := pof_punit@{Set}. - Number Notation punit pto_punits pof_punits : ppps (abstract after 1). + Number Notation punit pto_punits pof_punits (abstract after 1) : ppps. Delimit Scope ppps with ppps. Universe u. Constraint Set < u. @@ -121,7 +121,7 @@ Module Test6. End Scopes. Module Export Notations. Export Scopes. - Number Notation wnat of_uint to_uint : wnat_scope (abstract after 5000). + Number Notation wnat of_uint to_uint (abstract after 5000) : wnat_scope. End Notations. Set Printing Coercions. Check let v := 0%wnat in v : wnat. @@ -200,12 +200,12 @@ Module Test10. Declare Scope unit2_scope. Delimit Scope unit_scope with unit. Delimit Scope unit2_scope with unit2. - Number Notation unit of_uint to_uint : unit_scope (abstract after 1). + Number Notation unit of_uint to_uint (abstract after 1) : unit_scope. Local Set Warnings Append "+abstract-large-number-no-op". (* Check that there is actually a warning here *) - Fail Number Notation unit of_uint to_uint : unit2_scope (abstract after 1). + Fail Number Notation unit of_uint to_uint (abstract after 1) : unit2_scope. (* Check that there is no warning here *) - Number Notation unit of_any_uint to_uint : unit2_scope (abstract after 1). + Number Notation unit of_any_uint to_uint (abstract after 1) : unit2_scope. End Test10. Module Test12. @@ -487,3 +487,188 @@ Check (-0)%Z. *) End Test22. + +(* Test the via ... mapping ... option *) +Module Test23. + +Inductive sum (A : Set) (B : Set) : Set := pair : A -> B -> sum A B. + +Inductive I := +| Iempty : I +| Iunit : I +| Isum : I -> I -> I. + +Definition of_uint (x : Number.uint) : I := + let fix f n := + match n with + | O => Iempty + | S O => Iunit + | S n => Isum Iunit (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : I) : Number.uint := + let fix f i := + match i with + | Iempty => O + | Iunit => 1 + | Isum i1 i2 => f i1 + f i2 + end in + Nat.to_num_uint (f x). + +Notation nSet := (Set) (only parsing). (* needed as a reference is expected in Number Notation and Set is syntactically not a reference *) +Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) + : type_scope. + +Local Open Scope type_scope. + +Check Empty_set. +Check unit. +Check sum unit unit. +Check sum unit (sum unit unit). +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Unset Printing All. + +(* Test error messages *) + +(* missing constructor *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit]) + : type_scope. + +(* duplicate constructor *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum, unit => Iunit]) + : type_scope. + +(* not an inductive *) +Fail Number Notation nSet of_uint to_uint (via add + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) + : type_scope. + +(* not a constructor *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => add, sum => Isum]) + : type_scope. + +(* put constructors of the wrong inductive ~~> missing constructors *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => O, unit => S]) + : type_scope. + +(* Test warnings *) + +(* wrong type *) +Inductive I' := +| I'empty : I' +| I'unit : I' +| I'sum : I -> I' -> I'. +Definition of_uint' (x : Number.uint) : I' := I'empty. +Definition to_uint' (x : I') : Number.uint := Number.UIntDec Decimal.Nil. +Number Notation nSet of_uint' to_uint' (via I' + mapping [Empty_set => I'empty, unit => I'unit, sum => I'sum]) + : type_scope. + +(* wrong type mapping *) +Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, O => Iunit, sum => Isum]) + : type_scope. + +(* incompatibility with abstract (but warning is fine) *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum], + abstract after 12) + : type_scope. +Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum], + warning after 12) + : type_scope. + +(* Test reduction of types when building the notation *) + +Inductive foo := bar : match (true <: bool) with true => nat -> foo | false => True end. + +Definition foo_of_uint (x : Number.uint) : foo := bar (Nat.of_num_uint x). +Definition foo_to_uint (x : foo) : Number.uint := + match x with + | bar x => Nat.to_num_uint x + end. + +Number Notation foo foo_of_uint foo_to_uint (via foo mapping [bar => bar]) + : type_scope. + +Inductive foo' := bar' : let n := nat in n -> foo'. + +Definition foo'_of_uint (x : Number.uint) : foo' := bar' (Nat.of_num_uint x). +Definition foo'_to_uint (x : foo') : Number.uint := + match x with + | bar' x => Nat.to_num_uint x + end. + +Number Notation foo' foo'_of_uint foo'_to_uint (via foo' mapping [bar' => bar']) + : type_scope. + +Inductive foo'' := bar'' : (nat <: Type) -> (foo'' <: Type). + +Definition foo''_of_uint (x : Number.uint) : foo'' := bar'' (Nat.of_num_uint x). +Definition foo''_to_uint (x : foo'') : Number.uint := + match x with + | bar'' x => Nat.to_num_uint x + end. + +Number Notation foo'' foo''_of_uint foo''_to_uint (via foo'' mapping [bar'' => bar'']) + : type_scope. + +End Test23. + +(* Test the via ... mapping ... option with let-binders, beta-redexes, delta-redexes, etc *) +Module Test26. + +Inductive sum (A : Set) (B : Set) : Set := pair : A -> B -> sum A B. + +Inductive I (dummy:=O) := +| Iempty : let v := I in id v +| Iunit : (fun x => x) I +| Isum : let v := I in (fun A B => A -> B) (let v' := v in v') (forall x : match O with O => I | _ => Empty_set end, let dummy2 := x in I). + +Definition of_uint (x : (fun x => let v := I in x) Number.uint) : (fun x => let v := I in x) I := + let fix f n := + match n with + | O => Iempty + | S O => Iunit + | S n => Isum Iunit (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : (fun x => let v := x in v) I) : match O with O => Number.uint | _ => Empty_set end := + let fix f i := + match i with + | Iempty => O + | Iunit => 1 + | Isum i1 i2 => f i1 + f i2 + end in + Nat.to_num_uint (f x). + +Notation nSet := (Set) (only parsing). (* needed as a reference is expected in Number Notation and Set is syntactically not a reference *) +Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) + : type_scope. + +Local Open Scope type_scope. + +Check Empty_set. +Check unit. +Check sum unit unit. +Check sum unit (sum unit unit). +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Unset Printing All. +End Test26. -- cgit v1.2.3 From c217bbe80e18255ee3e67fa6266736529d80636d Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:14:00 +0200 Subject: [numeral notation] Document the via ... using ... option --- doc/sphinx/user-extensions/syntax-extensions.rst | 116 +++++++++++++++++++++-- doc/tools/docgram/common.edit_mlg | 14 ++- doc/tools/docgram/fullGrammar | 22 +++-- doc/tools/docgram/orderedGrammar | 16 ++-- 4 files changed, 139 insertions(+), 29 deletions(-) diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index a36772b2d7..f07eb02946 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1553,14 +1553,16 @@ numbers (see :ref:`datatypes`). Number notations ~~~~~~~~~~~~~~~~ -.. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print : @scope_name {? @number_modifier } +.. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print {? ( {+, @number_modifier } ) } : @scope_name :name: Number Notation - .. insertprodn number_modifier number_modifier + .. insertprodn number_modifier number_via .. prodn:: - number_modifier ::= ( warning after @bignat ) - | ( abstract after @bignat ) + number_modifier ::= warning after @bignat + | abstract after @bignat + | @number_via + number_via ::= via @qualid mapping [ {+, @qualid => @qualid } ] This command allows the user to customize the way number literals are parsed and printed. @@ -1606,7 +1608,38 @@ Number notations function application, constructors, inductive type families, sorts, and primitive integers) will be considered for printing. - :n:`( warning after @bignat )` + :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` + When using this option, :n:`@qualid__type` no + longer needs to be an inductive type and is instead mapped to the + inductive type :n:`@qualid__ind` according to the provided + list of pairs, whose first component :n:`@qualid__constant` is a + constant of type :n:`@qualid__type` + (or a function of type :n:`{* _ -> } @qualid__type`) and the second a + constructor of type :n:`@qualid__ind`. The type + :n:`@qualid__type` is then replaced by :n:`@qualid__ind` in the + above parser and printer types. + + .. note:: + To use a :token:`sort` as the target type :n:`@qualid__type`, use an :ref:`abbreviation ` + as in the :ref:`example below `. + + .. exn:: @qualid was already mapped to @qualid and cannot be remapped to @qualid + + Duplicates are not allowed in the :n:`mapping` list. + + .. exn:: Missing mapping for constructor @qualid + + A mapping should be provided for :n:`@qualid` in the :n:`mapping` list. + + .. warn:: @type was already mapped to @type, mapping it also to @type might yield ill typed terms when using the notation. + + Two pairs in the :n:`mapping` list associate types that might be incompatible. + + .. warn:: Type of @qualid seems incompatible with the type of @qualid. Expected type is: @type instead of @type. This might yield ill typed terms when using the notation. + + A mapping given in the :n:`mapping` list associates a constant with a seemingly incompatible constructor. + + :n:`warning after @bignat` displays a warning message about a possible stack overflow when calling :n:`@qualid__parse` to parse a literal larger than :n:`@bignat`. @@ -1616,7 +1649,7 @@ Number notations with :n:`(warning after @bignat)`, this warning is emitted when parsing a number greater than or equal to :token:`bignat`. - :n:`( abstract after @bignat )` + :n:`abstract after @bignat` returns :n:`(@qualid__parse m)` when parsing a literal :n:`m` that's greater than :n:`@bignat` rather than reducing it to a normal form. Here :g:`m` will be a @@ -1642,6 +1675,12 @@ Number notations As noted above, the :n:`(abstract after @natural)` directive has no effect when :n:`@qualid__parse` lands in an :g:`option` type. + .. exn:: 'via' and 'abstract' cannot be used together. + + With the :n:`abstract after` option, the parser function + :n:`@qualid__parse` does not reduce large numbers to a normal form, + which prevents doing the translation given in the :n:`mapping` list. + .. exn:: Cannot interpret this number as a value of type @type The number notation registered for :token:`type` does not support @@ -1664,7 +1703,7 @@ Number notations .. exn:: Unexpected term @term while parsing a number notation. Parsing functions must always return ground terms, made up of - applications of constructors, inductive types, and primitive + function application, constructors, inductive type families, sorts and primitive integers. Parsing functions may not return terms containing axioms, bare (co)fixpoints, lambdas, etc. @@ -1675,6 +1714,67 @@ Number notations concrete number expressed as a (hexa)decimal. They may not return opaque constants. + .. exn:: Multiple 'via' options. + + At most one :g:`via` option can be given. + + .. exn:: Multiple 'warning after' or 'abstract after' options. + + At most one :g:`warning after` or :g:`abstract after` option can be given. + + .. _example-number-notation-non-inductive: + + .. example:: Number Notation for a non inductive type + + The following example encodes the terms in the form :g:`sum unit ( ... (sum unit unit) ... )` + as the number of units in the term. For instance :g:`sum unit (sum unit unit)` + is encoded as :g:`3` while :g:`unit` is :g:`1` and :g:`0` stands for :g:`Empty_set`. + The inductive :g:`I` will be used as :n:`@qualid__ind`. + + .. coqtop:: in + + Inductive I := Iempty : I | Iunit : I | Isum : I -> I -> I. + + We then define :n:`@qualid__parse` and :n:`@qualid__print` + + .. coqtop:: in + + Definition of_uint (x : Number.uint) : I := + let fix f n := match n with + | O => Iempty | S O => Iunit + | S n => Isum Iunit (f n) end in + f (Nat.of_num_uint x). + + Definition to_uint (x : I) : Number.uint := + let fix f i := match i with + | Iempty => O | Iunit => 1 + | Isum i1 i2 => f i1 + f i2 end in + Nat.to_num_uint (f x). + + Inductive sum (A : Set) (B : Set) : Set := pair : A -> B -> sum A B. + + the number notation itself + + .. coqtop:: in + + Notation nSet := Set (only parsing). + Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) : type_scope. + + and check the printer + + .. coqtop:: all + + Local Open Scope type_scope. + Check sum unit (sum unit unit). + + and the parser + + .. coqtop:: all + + Set Printing All. + Check 3. + .. _string-notations: String notations @@ -1746,7 +1846,7 @@ The following errors apply to both string and number notations: .. exn:: @type is not an inductive type. String and number notations can only be declared for inductive types with no - arguments. + arguments. Declare numeral notations for non-inductive types using :n:`@number_via`. .. exn:: Cannot interpret in @scope_name because @qualid could not be found in the current environment. diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 4d615a130a..e43583de09 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -1285,10 +1285,10 @@ command: [ | WITH "Declare" "Scope" scope_name (* odd that these are in command while other notation-related ones are in syntax *) -| REPLACE "Number" "Notation" reference OPT number_via reference reference ":" ident number_modifier -| WITH "Number" "Notation" reference OPT number_via reference reference ":" scope_name number_modifier -| REPLACE "Numeral" "Notation" reference OPT number_via reference reference ":" ident number_modifier -| WITH "Numeral" "Notation" reference OPT number_via reference reference ":" scope_name number_modifier +| REPLACE "Number" "Notation" reference reference reference OPT number_options ":" ident +| WITH "Number" "Notation" reference reference reference OPT number_options ":" scope_name +| REPLACE "Numeral" "Notation" reference reference reference ":" ident deprecated_number_modifier +| WITH "Numeral" "Notation" reference reference reference ":" scope_name deprecated_number_modifier | REPLACE "String" "Notation" reference reference reference ":" ident | WITH "String" "Notation" reference reference reference ":" scope_name @@ -1358,10 +1358,6 @@ explicit_subentry: [ | DELETE "constr" (* covered by another prod *) ] -number_modifier: [ -| OPTINREF -] - binder_tactic: [ | REPLACE "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" ltac_expr5 | WITH "let" OPT "rec" let_clause LIST0 ( "with" let_clause ) "in" ltac_expr5 @@ -2464,6 +2460,8 @@ SPLICE: [ | constr_with_bindings | simple_binding | ssexpr35 (* strange in mlg, ssexpr50 is after this *) +| number_mapping +| number_options ] (* end SPLICE *) RENAME: [ diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 8a0feb0e2f..17fc220f6c 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -686,8 +686,8 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" constr OPT field_mods (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Number" "Notation" reference OPT number_via reference reference ":" ident number_modifier -| "Numeral" "Notation" reference OPT number_via reference reference ":" ident number_modifier +| "Number" "Notation" reference reference reference OPT number_options ":" ident +| "Numeral" "Notation" reference reference reference ":" ident deprecated_number_modifier | "String" "Notation" reference reference reference ":" ident | "Ltac2" ltac2_entry (* Ltac2 plugin *) | "Ltac2" "Eval" ltac2_expr6 (* Ltac2 plugin *) @@ -2549,18 +2549,28 @@ field_mods: [ | "(" LIST1 field_mod SEP "," ")" (* ring plugin *) ] -number_modifier: [ +deprecated_number_modifier: [ | | "(" "warning" "after" bignat ")" | "(" "abstract" "after" bignat ")" ] -number_using: [ -| reference reference +number_mapping: [ +| reference "=>" reference ] number_via: [ -| "via" reference "using" "(" LIST1 number_using SEP "," ")" +| "via" reference "mapping" "[" LIST1 number_mapping SEP "," "]" +] + +number_modifier: [ +| "warning" "after" bignat +| "abstract" "after" bignat +| number_via +] + +number_options: [ +| "(" LIST1 number_modifier SEP "," ")" ] tac2pat1: [ diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index d12b3bf6cd..3d1041e592 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -884,8 +884,6 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Number" "Notation" qualid OPT number_via qualid qualid ":" scope_name OPT number_modifier -| "Numeral" "Notation" qualid OPT number_via qualid qualid ":" scope_name OPT number_modifier | "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) | "Typeclasses" "Transparent" LIST1 qualid | "Typeclasses" "Opaque" LIST1 qualid @@ -910,7 +908,8 @@ command: [ | "Derive" "Dependent" "Inversion_clear" ident "with" one_term "Sort" sort_family | "Declare" "Left" "Step" one_term | "Declare" "Right" "Step" one_term -| "Numeral" "Notation" qualid OPT number_via qualid qualid ":" scope_name OPT number_modifier +| "Number" "Notation" qualid qualid qualid OPT ( "(" LIST1 number_modifier SEP "," ")" ) ":" scope_name +| "Numeral" "Notation" qualid qualid qualid ":" scope_name deprecated_number_modifier | "String" "Notation" qualid qualid qualid ":" scope_name | "SubClass" ident_decl def_body | thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] @@ -1270,17 +1269,20 @@ field_mod: [ | "completeness" one_term (* ring plugin *) ] -number_modifier: [ +deprecated_number_modifier: [ +| | "(" "warning" "after" bignat ")" | "(" "abstract" "after" bignat ")" ] -number_using: [ -| qualid qualid +number_modifier: [ +| "warning" "after" bignat +| "abstract" "after" bignat +| number_via ] number_via: [ -| "via" qualid "using" "(" LIST1 number_using SEP "," ")" +| "via" qualid "mapping" "[" LIST1 ( qualid "=>" qualid ) SEP "," "]" ] hints_path: [ -- cgit v1.2.3 From 7ea7834b442cbfbf3299536020cb033702b2535c Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:15:00 +0200 Subject: [numeral notation] Remove proofs for Q Just to get a cleaner log, this will be proved again in a few commits. --- theories/Numbers/DecimalQ.v | 486 +--------------------------------------- theories/Numbers/HexadecimalQ.v | 480 +-------------------------------------- 2 files changed, 19 insertions(+), 947 deletions(-) diff --git a/theories/Numbers/DecimalQ.v b/theories/Numbers/DecimalQ.v index c51cced024..d2cd061594 100644 --- a/theories/Numbers/DecimalQ.v +++ b/theories/Numbers/DecimalQ.v @@ -16,62 +16,7 @@ Require Import Decimal DecimalFacts DecimalPos DecimalN DecimalZ QArith. Lemma of_to (q:Q) : forall d, to_decimal q = Some d -> of_decimal d = q. -Proof. - cut (match to_decimal q with None => True | Some d => of_decimal d = q end). - { now case to_decimal; [intros d <- d' Hd'; injection Hd'; intros ->|]. } - destruct q as (num, den). - unfold to_decimal; simpl. - generalize (DecimalPos.Unsigned.nztail_to_uint den). - case Decimal.nztail; intros u n. - case u; clear u; [intros; exact I|intros; exact I|intro u|intros; exact I..]. - case u; clear u; [|intros; exact I..]. - unfold Pos.of_uint, Pos.of_uint_acc; rewrite N.mul_1_l. - case n. - - unfold of_decimal, app_int, app, Z.to_int; simpl. - intro H; inversion H as (H1); clear H H1. - case num; [reflexivity|intro pnum; fold (rev (rev (Pos.to_uint pnum)))..]. - + rewrite rev_rev; simpl. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. - + rewrite rev_rev; simpl. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. - - clear n; intros n H. - injection H; clear H; intros ->. - case Nat.ltb. - + unfold of_decimal. - rewrite of_to. - apply f_equal2; [|now simpl]. - unfold app_int, app, Z.to_int; simpl. - now case num; - [|intro pnum; fold (rev (rev (Pos.to_uint pnum))); - rewrite rev_rev; unfold Z.of_int, Z.of_uint; - rewrite DecimalPos.Unsigned.of_to..]. - + unfold of_decimal; case Nat.ltb_spec; intro Hn; simpl. - * rewrite nb_digits_del_head; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply le_Sn_le]. - rewrite Z.sub_sub_distr, Z.sub_diag; simpl. - rewrite <-(of_to num) at 4. - now revert Hn; case Z.to_int; clear num; intros pnum Hn; simpl; - (rewrite app_del_tail_head; [|now apply le_Sn_le]). - * revert Hn. - set (anum := match Z.to_int num with Pos i => i | _ => _ end). - intro Hn. - assert (H : exists l, nb_digits anum = S l). - { exists (Nat.pred (nb_digits anum)); apply S_pred_pos. - now unfold anum; case num; - [apply Nat.lt_0_1| - intro pnum; apply nb_digits_pos, Unsigned.to_uint_nonnil..]. } - destruct H as (l, Hl); rewrite Hl. - assert (H : forall n d, (nb_digits (Nat.iter n D0 d) = n + nb_digits d)%nat). - { now intros n'; induction n'; intro d; [|simpl; rewrite IHn']. } - rewrite H, Hl. - rewrite Nat.add_succ_r, Nat.sub_add; [|now apply le_S_n; rewrite <-Hl]. - assert (H' : forall n d, Pos.of_uint (Nat.iter n D0 d) = Pos.of_uint d). - { now intro n'; induction n'; intro d; [|simpl; rewrite IHn']. } - now unfold anum; case num; simpl; [|intro pnum..]; - unfold app, Z.of_uint; simpl; - rewrite H', ?DecimalPos.Unsigned.of_to. -Qed. +Admitted. (* normalize without fractional part, for instance norme 12.3e-1 is 123e-2 *) Definition dnorme (d:decimal) : decimal := @@ -113,449 +58,38 @@ Lemma dnorme_spec d : | DecimalExp i Nil e => i = norm i /\ e = norm e /\ e <> Pos zero | _ => False end. -Proof. - case d; clear d; intros i f; [|intro e]; unfold dnorme; simpl. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); [intros->|intro Hne']. - + now rewrite norm_invol. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - replace m with r; [now unfold r; rewrite !norm_invol|]. - unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); [intros->|intro Hne']. - + now rewrite norm_invol. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - replace m with r; [now unfold r; rewrite !norm_invol|]. - unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. -Qed. +Admitted. Lemma dnormf_spec d : match dnormf d with | Decimal i f => i = Neg zero \/ i = norm i | _ => False end. -Proof. - case d; clear d; intros i f; [|intro e]; unfold dnormf, dnorme; simpl. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); [intros->|intro Hne']. - + now right; rewrite norm_invol. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - case_eq (Z.of_int e'); [|intros pe'..]; intro Hpe'; - [now right; rewrite norm_invol..|]. - case Nat.ltb_spec. - * now intro H; rewrite (norm_del_tail_int_norm _ _ H); right. - * now intros _; case norm; intros _; [right|left]. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); [intros->|intro Hne']. - + now right; rewrite norm_invol. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - case_eq (Z.of_int e'); [|intros pe'..]; intro Hpe'; - [now right; rewrite norm_invol..|]. - case Nat.ltb_spec. - * now intro H; rewrite (norm_del_tail_int_norm _ _ H); right. - * now intros _; case norm; intros _; [right|left]. -Qed. +Admitted. Lemma dnorme_invol d : dnorme (dnorme d) = dnorme d. -Proof. - case d; clear d; intros i f; [|intro e]; unfold dnorme; simpl. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); intro Hne'. - + rewrite Hne'; simpl; rewrite app_int_nil_r, norm_invol. - revert Hne'. - rewrite <-to_of. - change (Pos zero) with (Z.to_int 0). - intro H; generalize (to_int_inj _ _ H); clear H. - unfold e'; rewrite DecimalZ.of_to. - now case f; [rewrite app_int_nil_r|..]. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - unfold nb_digits, Z.of_nat; rewrite Z.sub_0_r, to_of, norm_invol. - rewrite app_int_nil_r, norm_invol. - set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); intro Hne'. - + rewrite Hne'; simpl; rewrite app_int_nil_r, norm_invol. - revert Hne'. - rewrite <-to_of. - change (Pos zero) with (Z.to_int 0). - intro H; generalize (to_int_inj _ _ H); clear H. - unfold e'; rewrite DecimalZ.of_to. - now case f; [rewrite app_int_nil_r|..]. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - unfold nb_digits, Z.of_nat; rewrite Z.sub_0_r, to_of, norm_invol. - rewrite app_int_nil_r, norm_invol. - set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. -Qed. +Admitted. Lemma dnormf_invol d : dnormf (dnormf d) = dnormf d. -Proof. - case d; clear d; intros i f; [|intro e]; unfold dnormf, dnorme; simpl. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); intro Hne'. - + rewrite Hne'; simpl; rewrite app_int_nil_r, norm_invol. - revert Hne'. - rewrite <-to_of. - change (Pos zero) with (Z.to_int 0). - intro H; generalize (to_int_inj _ _ H); clear H. - unfold e'; rewrite DecimalZ.of_to. - now case f; [rewrite app_int_nil_r|..]. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite of_int_norm. - case_eq (Z.of_int e'); [|intro pe'..]; intro Hnpe'; - [now simpl; rewrite app_int_nil_r, norm_invol..|]. - case Nat.ltb_spec; intro Hpe'. - * rewrite nb_digits_del_head; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.lt_le_incl]. - simpl. - rewrite Z.sub_sub_distr, Z.sub_diag, Z.add_0_l. - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite positive_nat_Z; simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. - now rewrite norm_invol, (proj2 (Nat.ltb_lt _ _) Hpe'). - * simpl. - rewrite nb_digits_iter_D0. - rewrite (Nat.sub_add _ _ Hpe'). - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite positive_nat_Z; simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - revert Hpe'. - set (i' := norm (app_int i f)). - case_eq i'; intros u Hu Hpe'. - ++ simpl; unfold app; simpl. - rewrite unorm_D0, unorm_iter_D0. - assert (Hu' : unorm u = u). - { generalize (f_equal norm Hu). - unfold i'; rewrite norm_invol; fold i'. - now simpl; rewrite Hu; intro H; injection H. } - now rewrite Hu', (proj2 (Nat.ltb_ge _ _) Hpe'). - ++ simpl; rewrite nzhead_iter_D0. - assert (Hu' : nzhead u = u). - { generalize (f_equal norm Hu). - unfold i'; rewrite norm_invol; fold i'. - now rewrite Hu; simpl; case (nzhead u); [|intros u' H; injection H..]. } - rewrite Hu'. - assert (Hu'' : u <> Nil). - { intro H; revert Hu; rewrite H; unfold i'. - now case app_int; intro u'; [|simpl; case nzhead]. } - set (m := match u with Nil => Pos zero | _ => _ end). - assert (H : m = Neg u); [|rewrite H; clear m H]. - { now revert Hu''; unfold m; case u. } - now rewrite (proj2 (Nat.ltb_ge _ _) Hpe'). - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); intro Hne'. - + rewrite Hne'; simpl; rewrite app_int_nil_r, norm_invol. - revert Hne'. - rewrite <-to_of. - change (Pos zero) with (Z.to_int 0). - intro H; generalize (to_int_inj _ _ H); clear H. - unfold e'; rewrite DecimalZ.of_to. - now case f; [rewrite app_int_nil_r|..]. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite of_int_norm. - case_eq (Z.of_int e'); [|intro pe'..]; intro Hnpe'; - [now simpl; rewrite app_int_nil_r, norm_invol..|]. - case Nat.ltb_spec; intro Hpe'. - * rewrite nb_digits_del_head; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.lt_le_incl]. - simpl. - rewrite Z.sub_sub_distr, Z.sub_diag, Z.add_0_l. - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite positive_nat_Z; simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. - now rewrite norm_invol, (proj2 (Nat.ltb_lt _ _) Hpe'). - * simpl. - rewrite nb_digits_iter_D0. - rewrite (Nat.sub_add _ _ Hpe'). - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite positive_nat_Z; simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - revert Hpe'. - set (i' := norm (app_int i f)). - case_eq i'; intros u Hu Hpe'. - ++ simpl; unfold app; simpl. - rewrite unorm_D0, unorm_iter_D0. - assert (Hu' : unorm u = u). - { generalize (f_equal norm Hu). - unfold i'; rewrite norm_invol; fold i'. - now simpl; rewrite Hu; intro H; injection H. } - now rewrite Hu', (proj2 (Nat.ltb_ge _ _) Hpe'). - ++ simpl; rewrite nzhead_iter_D0. - assert (Hu' : nzhead u = u). - { generalize (f_equal norm Hu). - unfold i'; rewrite norm_invol; fold i'. - now rewrite Hu; simpl; case (nzhead u); [|intros u' H; injection H..]. } - rewrite Hu'. - assert (Hu'' : u <> Nil). - { intro H; revert Hu; rewrite H; unfold i'. - now case app_int; intro u'; [|simpl; case nzhead]. } - set (m := match u with Nil => Pos zero | _ => _ end). - assert (H : m = Neg u); [|rewrite H; clear m H]. - { now revert Hu''; unfold m; case u. } - now rewrite (proj2 (Nat.ltb_ge _ _) Hpe'). -Qed. +Admitted. Lemma to_of (d:decimal) : to_decimal (of_decimal d) = Some (dnorme d) \/ to_decimal (of_decimal d) = Some (dnormf d). -Proof. - unfold to_decimal. - pose (t10 := fun y => ((y + y~0~0)~0)%positive). - assert (H : exists e_den, - Decimal.nztail (Pos.to_uint (Qden (of_decimal d))) = (D1 Nil, e_den)). - { assert (H : forall p, - Decimal.nztail (Pos.to_uint (Pos.iter t10 1%positive p)) - = (D1 Nil, Pos.to_nat p)). - { intro p; rewrite Pos2Nat.inj_iter. - fold (Nat.iter (Pos.to_nat p) t10 1%positive). - induction (Pos.to_nat p); [now simpl|]. - rewrite DecimalPos.Unsigned.nat_iter_S. - unfold Pos.to_uint. - change (Pos.to_little_uint _) - with (Unsigned.to_lu (10 * N.pos (Nat.iter n t10 1%positive))). - rewrite Unsigned.to_ldec_tenfold. - revert IHn; unfold Pos.to_uint. - unfold Decimal.nztail; rewrite !rev_rev; simpl. - set (f'' := _ (Pos.to_little_uint _)). - now case f''; intros r n' H; inversion H. } - case d; intros i f; [|intro e]; unfold of_decimal; simpl. - - case (- Z.of_nat _)%Z; [|intro p..]; simpl; [now exists O..|]. - exists (Pos.to_nat p); apply H. - - case (_ - _)%Z; [|intros p..]; simpl; [now exists O..|]. - exists (Pos.to_nat p); apply H. } - generalize (DecimalPos.Unsigned.nztail_to_uint (Qden (of_decimal d))). - destruct H as (e, He); rewrite He; clear He; simpl. - assert (Hn1 : forall p, N.pos (Pos.iter t10 1%positive p) = 1%N -> False). - { intro p. - rewrite Pos2Nat.inj_iter. - case_eq (Pos.to_nat p); [|now simpl]. - intro H; exfalso; apply (lt_irrefl O). - rewrite <-H at 2; apply Pos2Nat.is_pos. } - assert (Ht10inj : forall n m, t10 n = t10 m -> n = m). - { intros n m H; generalize (f_equal Z.pos H); clear H. - change (Z.pos (t10 n)) with (Z.mul 10 (Z.pos n)). - change (Z.pos (t10 m)) with (Z.mul 10 (Z.pos m)). - rewrite Z.mul_comm, (Z.mul_comm 10). - intro H; generalize (f_equal (fun z => Z.div z 10) H); clear H. - now rewrite !Z.div_mul; [|now simpl..]; intro H; inversion H. } - assert (Hinj : forall n m, - Nat.iter n t10 1%positive = Nat.iter m t10 1%positive -> n = m). - { induction n; [now intro m; case m|]. - intro m; case m; [now simpl|]; clear m; intro m. - rewrite !Unsigned.nat_iter_S. - intro H; generalize (Ht10inj _ _ H); clear H; intro H. - now rewrite (IHn _ H). } - case e; clear e; [|intro e]; simpl; unfold of_decimal, dnormf, dnorme. - - case d; clear d; intros i f; [|intro e]; simpl. - + intro H; left; revert H. - generalize (nb_digits_pos f). - case f; - [|now clear f; intro f; intros H1 H2; exfalso; revert H1 H2; - case nb_digits; simpl; - [intros H _; apply (lt_irrefl O), H|intros n _; apply Hn1]..]. - now intros _ _; simpl; rewrite to_of. - + intro H; right; revert H. - rewrite <-to_of, DecimalZ.of_to. - set (emf := (_ - _)%Z). - case_eq emf; [|intro pemf..]. - * now simpl; rewrite to_of. - * set (r := DecimalExp _ _ _). - set (m := match _ with Pos _ => _ | _ => r end). - assert (H : m = r). - { unfold m, Z.to_int. - generalize (Unsigned.to_uint_nonzero pemf). - now case Pos.to_uint; [|intro u; case u..]. } - rewrite H; unfold r; clear H m r. - rewrite DecimalZ.of_to. - simpl Qnum. - intros Hpemf _. - apply f_equal; apply f_equal2; [|reflexivity]. - rewrite !Pos2Nat.inj_iter. - set (n := _ pemf). - fold (Nat.iter n (Z.mul 10) (Z.of_int (app_int i f))). - fold (Nat.iter n D0 Nil). - rewrite <-of_int_iter_D0, to_of. - now rewrite norm_app_int_norm; [|induction n]. - * simpl Qden; intros _ H; exfalso; revert H; apply Hn1. - - case d; clear d; intros i f; [|intro e']; simpl. - + case_eq (nb_digits f); [|intros nf' Hnf']; - [now simpl; intros _ H; exfalso; symmetry in H; revert H; apply Hn1|]. - unfold Z.of_nat, Z.opp. - simpl Qden. - intro H; injection H; clear H; unfold Pos.pow. - rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (SuccNat2Pos.inj _ _ ((Pos2Nat.inj _ _ H))); clear H. - intro He; rewrite <-He; clear e He. - simpl Qnum. - case Nat.ltb; [left|right]. - * now rewrite <-to_of, DecimalZ.of_to, to_of. - * rewrite to_of. - set (nif := norm _). - set (anif := match nif with Pos i0 => i0 | _ => _ end). - set (r := DecimalExp nif Nil _). - set (m := match _ with Pos _ => _ | _ => r end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { now unfold m; rewrite <-to_of, DecimalZ.of_to. } - rewrite <-to_of, !DecimalZ.of_to. - fold anif. - now rewrite SuccNat2Pos.id_succ. - + set (nemf := (_ - _)%Z); intro H. - assert (H' : exists pnemf, nemf = Z.neg pnemf); [|revert H]. - { revert H; case nemf; [|intro pnemf..]; [..|now intros _; exists pnemf]; - simpl Qden; intro H; exfalso; symmetry in H; revert H; apply Hn1. } - destruct H' as (pnemf,Hpnemf); rewrite Hpnemf. - simpl Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H. - intro H; revert Hpnemf; rewrite H; clear pnemf H; intro Hnemf. - simpl Qnum. - case Nat.ltb; [left|right]. - * now rewrite <-to_of, DecimalZ.of_to, to_of. - * rewrite to_of. - set (nif := norm _). - set (anif := match nif with Pos i0 => i0 | _ => _ end). - set (r := DecimalExp nif Nil _). - set (m := match _ with Pos _ => _ | _ => r end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { now unfold m; rewrite <-to_of, DecimalZ.of_to. } - rewrite <-to_of, !DecimalZ.of_to. - fold anif. - now rewrite SuccNat2Pos.id_succ. -Qed. +Admitted. (** Some consequences *) Lemma to_decimal_inj q q' : to_decimal q <> None -> to_decimal q = to_decimal q' -> q = q'. -Proof. - intros Hnone EQ. - generalize (of_to q) (of_to q'). - rewrite <-EQ. - revert Hnone; case to_decimal; [|now simpl]. - now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). -Qed. +Admitted. Lemma to_decimal_surj d : exists q, to_decimal q = Some (dnorme d) \/ to_decimal q = Some (dnormf d). -Proof. - exists (of_decimal d). apply to_of. -Qed. +Admitted. Lemma of_decimal_dnorme d : of_decimal (dnorme d) = of_decimal d. -Proof. - unfold of_decimal, dnorme. - destruct d. - - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - case_eq (nb_digits f); [|intro nf]; intro Hnf. - + now simpl; rewrite app_int_nil_r, <-DecimalZ.to_of, DecimalZ.of_to. - + simpl; rewrite Z.sub_0_r. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_nil_r. - now rewrite <-DecimalZ.to_of, DecimalZ.of_to. - - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - set (emf := (_ - _)%Z). - case_eq emf; [|intro pemf..]; intro Hemf. - + now simpl; rewrite app_int_nil_r, <-DecimalZ.to_of, DecimalZ.of_to. - + simpl. - set (r := DecimalExp _ Nil _). - set (m := match Pos.to_uint pemf with zero => _ | _ => r end). - assert (H : m = r); [|rewrite H; unfold r; clear m r H]. - { generalize (Unsigned.to_uint_nonzero pemf). - now unfold m; case Pos.to_uint; [|intro u; case u|..]. } - simpl; rewrite Z.sub_0_r. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_nil_r. - now rewrite <-DecimalZ.to_of, DecimalZ.of_to. - + simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_nil_r. - now rewrite <-DecimalZ.to_of, DecimalZ.of_to. -Qed. +Admitted. Lemma of_decimal_dnormf d : of_decimal (dnormf d) = of_decimal d. -Proof. - rewrite <-(of_decimal_dnorme d). - unfold of_decimal, dnormf. - assert (H : match dnorme d with Decimal _ f | DecimalExp _ f _ => f end = Nil). - { now unfold dnorme; destruct d; - (case norm; intro d; [case d; [|intro u; case u|..]|]). } - revert H; generalize (dnorme d); clear d; intro d. - destruct d; intro H; rewrite H; clear H; [now simpl|]. - case (Z.of_int e); clear e; [|intro e..]. - - now simpl. - - simpl. - rewrite app_int_nil_r. - apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite !Pos2Nat.inj_iter. - fold (Nat.iter (Pos.to_nat e) D0 Nil). - now rewrite of_int_iter_D0. - - simpl. - set (ai := match i with Pos _ => _ | _ => _ end). - rewrite app_int_nil_r. - case Nat.ltb_spec; intro Hei; simpl. - + rewrite nb_digits_del_head; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply le_Sn_le]. - rewrite Z.sub_sub_distr, Z.sub_diag; simpl. - rewrite positive_nat_Z; simpl. - now revert Hei; unfold ai; case i; clear i ai; intros i Hei; simpl; - (rewrite app_del_tail_head; [|now apply le_Sn_le]). - + set (n := nb_digits _). - assert (H : (n = Pos.to_nat e - nb_digits ai + nb_digits ai)%nat). - { unfold n; induction (_ - _)%nat; [now simpl|]. - now rewrite Unsigned.nat_iter_S; simpl; rewrite IHn0. } - rewrite H; clear n H. - rewrite Nat2Z.inj_add, (Nat2Z.inj_sub _ _ Hei). - rewrite <-Z.sub_sub_distr, Z.sub_diag, Z.sub_0_r. - rewrite positive_nat_Z; simpl. - rewrite <-(DecimalZ.of_to (Z.of_int (app_int _ _))), DecimalZ.to_of. - rewrite <-(DecimalZ.of_to (Z.of_int i)), DecimalZ.to_of. - apply f_equal2; [|reflexivity]; apply f_equal. - now unfold ai; case i; clear i ai Hei; intro i; - (induction (_ - _)%nat; [|rewrite <-IHn]). -Qed. +Admitted. diff --git a/theories/Numbers/HexadecimalQ.v b/theories/Numbers/HexadecimalQ.v index 9bf43ceb88..ce6f074d70 100644 --- a/theories/Numbers/HexadecimalQ.v +++ b/theories/Numbers/HexadecimalQ.v @@ -17,63 +17,7 @@ Require Import Decimal DecimalFacts DecimalPos DecimalN DecimalZ. Require Import Hexadecimal HexadecimalFacts HexadecimalPos HexadecimalN HexadecimalZ QArith. Lemma of_to (q:Q) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. -Proof. - cut (match to_hexadecimal q with None => True | Some d => of_hexadecimal d = q end). - { now case to_hexadecimal; [intros d <- d' Hd'; injection Hd'; intros ->|]. } - destruct q as (num, den). - unfold to_hexadecimal; simpl Qnum; simpl Qden. - generalize (HexadecimalPos.Unsigned.nztail_to_hex_uint den). - case Hexadecimal.nztail; intros u n. - change 16%N with (2^4)%N; rewrite <-N.pow_mul_r. - change 4%N with (N.of_nat 4); rewrite <-Nnat.Nat2N.inj_mul. - change 4%Z with (Z.of_nat 4); rewrite <-Nat2Z.inj_mul. - case u; clear u; try (intros; exact I); [| | |]; intro u; - (case u; clear u; [|intros; exact I..]). - - unfold Pos.of_hex_uint, Pos.of_hex_uint_acc; rewrite N.mul_1_l. - case n. - + unfold of_hexadecimal, app_int, app, Z.to_hex_int; simpl. - intro H; inversion H as (H1); clear H H1. - case num; [reflexivity|intro pnum; fold (rev (rev (Pos.to_hex_uint pnum)))..]. - * rewrite rev_rev; simpl. - now unfold Z.of_hex_uint; rewrite HexadecimalPos.Unsigned.of_to. - * rewrite rev_rev; simpl. - now unfold Z.of_hex_uint; rewrite HexadecimalPos.Unsigned.of_to. - + clear n; intros n. - intro H; injection H; intros ->; clear H. - unfold of_hexadecimal. - rewrite DecimalZ.of_to. - simpl nb_digits; rewrite Nat2Z.inj_0, Z.mul_0_r, Z.sub_0_r. - now apply f_equal2; [rewrite app_int_nil_r, of_to|]. - - unfold Pos.of_hex_uint, Pos.of_hex_uint_acc. - rewrite <-N.pow_succ_r', <-Nnat.Nat2N.inj_succ. - intro H; injection H; intros ->; clear H. - fold (4 * n)%nat. - change 1%Z with (Z.of_nat 1); rewrite <-Znat.Nat2Z.inj_add. - unfold of_hexadecimal. - rewrite DecimalZ.of_to. - simpl nb_digits; rewrite Nat2Z.inj_0, Z.mul_0_r, Z.sub_0_r. - now apply f_equal2; [rewrite app_int_nil_r, of_to|]. - - change 2%Z with (Z.of_nat 2); rewrite <-Znat.Nat2Z.inj_add. - unfold Pos.of_hex_uint, Pos.of_hex_uint_acc. - change 4%N with (2^2)%N; rewrite <-N.pow_add_r. - change 2%N with (N.of_nat 2); rewrite <-Nnat.Nat2N.inj_add. - intro H; injection H; intros ->; clear H. - fold (4 * n)%nat. - unfold of_hexadecimal. - rewrite DecimalZ.of_to. - simpl nb_digits; rewrite Nat2Z.inj_0, Z.mul_0_r, Z.sub_0_r. - now apply f_equal2; [rewrite app_int_nil_r, of_to|]. - - change 3%Z with (Z.of_nat 3); rewrite <-Znat.Nat2Z.inj_add. - unfold Pos.of_hex_uint, Pos.of_hex_uint_acc. - change 8%N with (2^3)%N; rewrite <-N.pow_add_r. - change 3%N with (N.of_nat 3); rewrite <-Nnat.Nat2N.inj_add. - intro H; injection H; intros ->; clear H. - fold (4 * n)%nat. - unfold of_hexadecimal. - rewrite DecimalZ.of_to. - simpl nb_digits; rewrite Nat2Z.inj_0, Z.mul_0_r, Z.sub_0_r. - now apply f_equal2; [rewrite app_int_nil_r, of_to|]. -Qed. +Admitted. (* normalize without fractional part, for instance norme 0x1.2p-1 is 0x12e-5 *) Definition hnorme (d:hexadecimal) : hexadecimal := @@ -97,437 +41,31 @@ Lemma hnorme_spec d : i = norm i /\ e = Decimal.norm e /\ e <> Decimal.Pos Decimal.zero | _ => False end. -Proof. - case d; clear d; intros i f; [|intro e]; unfold hnorme; simpl. - - case_eq (nb_digits f); [now simpl; rewrite norm_invol|]; intros nf Hnf. - split; [now simpl; rewrite norm_invol|]. - unfold Z.of_nat. - now rewrite <-!DecimalZ.to_of, !DecimalZ.of_to. - - set (e' := (_ - _)%Z). - case_eq e'; [|intro pe'..]; intro He'. - + now rewrite norm_invol. - + rewrite Pos2Nat.inj_iter. - set (ne' := Pos.to_nat pe'). - fold (Nat.iter ne' double (norm (app_int i f))). - induction ne'; [now simpl; rewrite norm_invol|]. - now rewrite Unsigned.nat_iter_S, <-double_norm, IHne', norm_invol. - + split; [now rewrite norm_invol|]. - split; [now rewrite DecimalFacts.norm_invol|]. - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - change (Decimal.Pos _) with (Z.to_int 0). - now intro H; generalize (DecimalZ.to_int_inj _ _ H). -Qed. +Admitted. Lemma hnorme_invol d : hnorme (hnorme d) = hnorme d. -Proof. - case d; clear d; intros i f; [|intro e]; unfold hnorme; simpl. - - case_eq (nb_digits f); [now simpl; rewrite app_int_nil_r, norm_invol|]. - intros nf Hnf. - unfold Z.of_nat. - simpl. - set (pnf := Pos.to_uint _). - set (nz := Decimal.nzhead pnf). - assert (Hnz : nz <> Decimal.Nil). - { unfold nz, pnf. - rewrite <-DecimalFacts.unorm_0. - rewrite <-DecimalPos.Unsigned.to_of. - rewrite DecimalPos.Unsigned.of_to. - change Decimal.zero with (N.to_uint 0). - now intro H; generalize (DecimalN.Unsigned.to_uint_inj _ _ H). } - set (m := match nz with Decimal.Nil => _ | _ => _ end). - assert (Hm : m = (Decimal.Neg (Decimal.unorm pnf))). - { now revert Hnz; unfold m, nz, Decimal.unorm; fold nz; case nz. } - rewrite Hm; unfold pnf. - rewrite <-DecimalPos.Unsigned.to_of, DecimalPos.Unsigned.of_to. - simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. - rewrite Z.sub_0_r; simpl. - fold pnf; fold nz; fold m; rewrite Hm; unfold pnf. - rewrite <-DecimalPos.Unsigned.to_of, DecimalPos.Unsigned.of_to. - now rewrite app_int_nil_r, norm_invol. - - set (e' := (_ - _)%Z). - case_eq e'; [|intro pe'..]; intro Hpe'. - + now simpl; rewrite app_int_nil_r, norm_invol. - + simpl; rewrite app_int_nil_r. - apply f_equal2; [|reflexivity]. - rewrite Pos2Nat.inj_iter. - set (ne' := Pos.to_nat pe'). - fold (Nat.iter ne' double (norm (app_int i f))). - induction ne'; [now simpl; rewrite norm_invol|]. - now rewrite Unsigned.nat_iter_S, <-double_norm, IHne'. - + rewrite <-DecimalZ.to_of, !DecimalZ.of_to; simpl. - rewrite app_int_nil_r, norm_invol. - set (pnf := Pos.to_uint _). - set (nz := Decimal.nzhead pnf). - assert (Hnz : nz <> Decimal.Nil). - { unfold nz, pnf. - rewrite <-DecimalFacts.unorm_0. - rewrite <-DecimalPos.Unsigned.to_of. - rewrite DecimalPos.Unsigned.of_to. - change Decimal.zero with (N.to_uint 0). - now intro H; generalize (DecimalN.Unsigned.to_uint_inj _ _ H). } - set (m := match nz with Decimal.Nil => _ | _ => _ end). - assert (Hm : m = (Decimal.Neg (Decimal.unorm pnf))). - { now revert Hnz; unfold m, nz, Decimal.unorm; fold nz; case nz. } - rewrite Hm; unfold pnf. - now rewrite <-DecimalPos.Unsigned.to_of, DecimalPos.Unsigned.of_to. -Qed. +Admitted. Lemma to_of (d:hexadecimal) : to_hexadecimal (of_hexadecimal d) = Some (hnorme d). -Proof. - unfold to_hexadecimal. - pose (t10 := fun y => (y~0~0~0~0)%positive). - assert (H : exists h e_den, - Hexadecimal.nztail (Pos.to_hex_uint (Qden (of_hexadecimal d))) - = (h, e_den) - /\ (h = D1 Nil \/ h = D2 Nil \/ h = D4 Nil \/ h = D8 Nil)). - { assert (H : forall p, - Hexadecimal.nztail (Pos.to_hex_uint (Pos.iter (Pos.mul 2) 1%positive p)) - = ((match (Pos.to_nat p) mod 4 with 0%nat => D1 | 1 => D2 | 2 => D4 | _ => D8 end)%nat Nil, - (Pos.to_nat p / 4)%nat)). - { intro p; clear d; rewrite Pos2Nat.inj_iter. - fold (Nat.iter (Pos.to_nat p) (Pos.mul 2) 1%positive). - set (n := Pos.to_nat p). - fold (Nat.iter n t10 1%positive). - set (nm4 := (n mod 4)%nat); set (nd4 := (n / 4)%nat). - rewrite (Nat.div_mod n 4); [|now simpl]. - unfold nm4, nd4; clear nm4 nd4. - generalize (Nat.mod_upper_bound n 4 ltac:(now simpl)). - generalize (n mod 4); generalize (n / 4)%nat. - intros d r Hr; clear p n. - induction d. - { simpl; revert Hr. - do 4 (case r; [now simpl|clear r; intro r]). - intro H; exfalso. - now do 4 (generalize (lt_S_n _ _ H); clear H; intro H). } - rewrite Nat.mul_succ_r, <-Nat.add_assoc, (Nat.add_comm 4), Nat.add_assoc. - rewrite (Nat.add_comm _ 4). - change (4 + _)%nat with (S (S (S (S (4 * d + r))))). - rewrite !Unsigned.nat_iter_S. - rewrite !Pos.mul_assoc. - unfold Pos.to_hex_uint. - change (2 * 2 * 2 * 2)%positive with 0x10%positive. - set (n := Nat.iter _ _ _). - change (Pos.to_little_hex_uint _) with (Unsigned.to_lu (16 * N.pos n)). - rewrite Unsigned.to_lhex_tenfold. - unfold Hexadecimal.nztail; rewrite rev_rev. - rewrite <-(rev_rev (Unsigned.to_lu _)). - set (m := _ (rev _)). - replace m with (let (r, n) := let (r, n) := m in (rev r, n) in (rev r, n)). - 2:{ now case m; intros r' n'; rewrite rev_rev. } - change (let (r, n) := m in (rev r, n)) - with (Hexadecimal.nztail (Pos.to_hex_uint n)). - now unfold n; rewrite IHd, rev_rev; clear n m. } - unfold of_hexadecimal. - case d; intros i f; [|intro e]; unfold of_hexadecimal; simpl. - - case (Z.of_nat _)%Z; [|intro p..]; - [now exists (D1 Nil), O; split; [|left] - | |now exists (D1 Nil), O; split; [|left]]. - exists (D1 Nil), (Pos.to_nat p). - split; [|now left]; simpl. - change (Pos.iter _ _ _) with (Pos.iter (Pos.mul 2) 1%positive (4 * p)). - rewrite H. - rewrite Pos2Nat.inj_mul, Nat.mul_comm, Nat.div_mul; [|now simpl]. - now rewrite Nat.mod_mul; [|now simpl]. - - case (_ - _)%Z; [|intros p..]; [now exists (D1 Nil), O; split; [|left]..|]. - simpl Qden; rewrite H. - eexists; eexists; split; [reflexivity|]. - case (_ mod _); [now left|intro n]. - case n; [now right; left|clear n; intro n]. - case n; [now right; right; left|clear n; intro n]. - now right; right; right. } - generalize (HexadecimalPos.Unsigned.nztail_to_hex_uint (Qden (of_hexadecimal d))). - destruct H as (h, (e, (He, Hh))); rewrite He; clear He. - assert (Hn1 : forall p, N.pos (Pos.iter (Pos.mul 2) 1%positive p) = 1%N -> False). - { intro p. - rewrite Pos2Nat.inj_iter. - case_eq (Pos.to_nat p); [|now simpl]. - intro H; exfalso; apply (lt_irrefl O). - rewrite <-H at 2; apply Pos2Nat.is_pos. } - assert (H16_2 : forall p, (16^p = 2^(4 * p))%positive). - { intro p. - apply (@f_equal _ _ (fun z => match z with Z.pos p => p | _ => 1%positive end) - (Z.pos _) (Z.pos _)). - rewrite !Pos2Z.inj_pow_pos, !Z.pow_pos_fold, Pos2Z.inj_mul. - now change 16%Z with (2^4)%Z; rewrite <-Z.pow_mul_r. } - assert (HN16_2 : forall n, (16^n = 2^(4 * n))%N). - { intro n. - apply N2Z.inj; rewrite !N2Z.inj_pow, N2Z.inj_mul. - change (Z.of_N 16) with (2^4)%Z. - now rewrite <-Z.pow_mul_r; [| |apply N2Z.is_nonneg]. } - assert (Hn1' : forall p, N.pos (Pos.iter (Pos.mul 16) 1%positive p) = 1%N -> False). - { intro p; fold (16^p)%positive; rewrite H16_2; apply Hn1. } - assert (Ht10inj : forall n m, t10 n = t10 m -> n = m). - { intros n m H; generalize (f_equal Z.pos H); clear H. - change (Z.pos (t10 n)) with (Z.mul 0x10 (Z.pos n)). - change (Z.pos (t10 m)) with (Z.mul 0x10 (Z.pos m)). - rewrite Z.mul_comm, (Z.mul_comm 0x10). - intro H; generalize (f_equal (fun z => Z.div z 0x10) H); clear H. - now rewrite !Z.div_mul; [|now simpl..]; intro H; inversion H. } - assert (Ht2inj : forall n m, Pos.mul 2 n = Pos.mul 2 m -> n = m). - { intros n m H; generalize (f_equal Z.pos H); clear H. - change (Z.pos (Pos.mul 2 n)) with (Z.mul 2 (Z.pos n)). - change (Z.pos (Pos.mul 2 m)) with (Z.mul 2 (Z.pos m)). - rewrite Z.mul_comm, (Z.mul_comm 2). - intro H; generalize (f_equal (fun z => Z.div z 2) H); clear H. - now rewrite !Z.div_mul; [|now simpl..]; intro H; inversion H. } - assert (Hinj : forall n m, - Nat.iter n (Pos.mul 2) 1%positive = Nat.iter m (Pos.mul 2) 1%positive - -> n = m). - { induction n; [now intro m; case m|]. - intro m; case m; [now simpl|]; clear m; intro m. - rewrite !Unsigned.nat_iter_S. - intro H; generalize (Ht2inj _ _ H); clear H; intro H. - now rewrite (IHn _ H). } - change 4%Z with (Z.of_nat 4); rewrite <-Nat2Z.inj_mul. - change 1%Z with (Z.of_nat 1); rewrite <-Nat2Z.inj_add. - change 2%Z with (Z.of_nat 2); rewrite <-Nat2Z.inj_add. - change 3%Z with (Z.of_nat 3); rewrite <-Nat2Z.inj_add. - destruct Hh as [Hh|[Hh|[Hh|Hh]]]; rewrite Hh; clear h Hh. - - case e; clear e; [|intro e]; simpl; unfold of_hexadecimal, hnorme. - + case d; clear d; intros i f; [|intro e]. - * generalize (nb_digits_pos f). - case f; - [|now clear f; intro f; intros H1 H2; exfalso; revert H1 H2; - case nb_digits; - [intros H _; apply (lt_irrefl O), H|intros n _; apply Hn1]..]. - now intros _ _; simpl; rewrite to_of. - * rewrite <-DecimalZ.to_of, DecimalZ.of_to. - set (emf := (_ - _)%Z). - case_eq emf; [|intro pemf..]. - ++ now simpl; rewrite to_of. - ++ intros Hemf _; simpl. - apply f_equal, f_equal2; [|reflexivity]. - rewrite !Pos2Nat.inj_iter. - fold (Nat.iter (Pos.to_nat pemf) (Z.mul 2) (Z.of_hex_int (app_int i f))). - fold (Nat.iter (Pos.to_nat pemf) double (norm (app_int i f))). - induction Pos.to_nat; [now simpl; rewrite HexadecimalZ.to_of|]. - now rewrite !Unsigned.nat_iter_S, <-IHn, double_to_hex_int. - ++ simpl Qden; intros _ H; exfalso; revert H; apply Hn1. - + case d; clear d; intros i f; [|intro e']. - * simpl; case_eq (nb_digits f); [|intros nf' Hnf']; - [now simpl; intros _ H; exfalso; symmetry in H; revert H; apply Hn1'|]. - unfold Z.of_nat, Z.opp, Qnum, Qden. - rewrite H16_2. - fold (Pos.mul 2); fold (2^(Pos.of_succ_nat nf')~0~0)%positive. - intro H; injection H; clear H. - unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intro H; injection H. - clear H; intro H; generalize (SuccNat2Pos.inj _ _ H); clear H. - intros <-. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite SuccNat2Pos.id_succ. - change (_~0)%positive with (4 * Pos.of_succ_nat nf')%positive. - now rewrite Pos2Nat.inj_mul, SuccNat2Pos.id_succ. - * set (nemf := (_ - _)%Z); intro H. - assert (H' : exists pnemf, nemf = Z.neg pnemf); [|revert H]. - { revert H; case nemf; [|intro pnemf..]; [..|now intros _; exists pnemf]; - simpl Qden; intro H; exfalso; symmetry in H; revert H; apply Hn1'. } - destruct H' as (pnemf,Hpnemf); rewrite Hpnemf. - unfold Qnum, Qden. - rewrite H16_2. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H. - intro H; revert Hpnemf; rewrite H; clear pnemf H; intro Hnemf. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite SuccNat2Pos.id_succ. - change (_~0)%positive with (4 * Pos.of_succ_nat e)%positive. - now rewrite Pos2Nat.inj_mul, SuccNat2Pos.id_succ. - - simpl Pos.of_hex_uint. - rewrite HN16_2. - rewrite <-N.pow_succ_r; [|now apply N.le_0_l]. - rewrite <-N.succ_pos_spec. - case d; clear d; intros i f; [|intro e']; unfold of_hexadecimal, hnorme. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - - simpl Pos.of_hex_uint. - rewrite HN16_2. - change 4%N with (2 * 2)%N at 1; rewrite <-!N.mul_assoc. - do 2 (rewrite <-N.pow_succ_r; [|now apply N.le_0_l]). - rewrite <-N.succ_pos_spec. - case d; clear d; intros i f; [|intro e']; unfold of_hexadecimal, hnorme. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite <-SuccNat2Pos.inj_succ. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite <-SuccNat2Pos.inj_succ. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - - simpl Pos.of_hex_uint. - rewrite HN16_2. - change 8%N with (2 * 2 * 2)%N; rewrite <-!N.mul_assoc. - do 3 (rewrite <-N.pow_succ_r; [|now apply N.le_0_l]). - rewrite <-N.succ_pos_spec. - case d; clear d; intros i f; [|intro e']; unfold of_hexadecimal, hnorme. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite <-!SuccNat2Pos.inj_succ. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite <-!SuccNat2Pos.inj_succ. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. -Qed. +Admitted. (** Some consequences *) Lemma to_hexadecimal_inj q q' : to_hexadecimal q <> None -> to_hexadecimal q = to_hexadecimal q' -> q = q'. -Proof. - intros Hnone EQ. - generalize (of_to q) (of_to q'). - rewrite <-EQ. - revert Hnone; case to_hexadecimal; [|now simpl]. - now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). -Qed. +Admitted. Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (hnorme d). -Proof. - exists (of_hexadecimal d). apply to_of. -Qed. +Admitted. Lemma of_hexadecimal_hnorme d : of_hexadecimal (hnorme d) = of_hexadecimal d. -Proof. - unfold of_hexadecimal, hnorme. - destruct d. - - simpl Z.of_int; unfold Z.of_uint, Z.of_N, Pos.of_uint. - rewrite Z.sub_0_l. - set (n4f := (- _)%Z). - case_eq n4f; [|intro pn4f..]; intro Hn4f. - + apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - now rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to. - + apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - generalize (app_int i f); intro i'. - rewrite !Pos2Nat.inj_iter. - generalize (Pos.to_nat pn4f); intro n. - fold (Nat.iter n double (norm i')). - fold (Nat.iter n (Z.mul 2) (Z.of_hex_int i')). - induction n; [now simpl; rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to|]. - now rewrite !Unsigned.nat_iter_S, <-IHn, of_hex_int_double. - + unfold nb_digits, Z.of_nat. - rewrite Z.mul_0_r, Z.sub_0_r. - rewrite <-DecimalZ.to_of, !DecimalZ.of_to. - rewrite app_int_nil_r. - now rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to. - - set (nem4f := (_ - _)%Z). - case_eq nem4f; [|intro pnem4f..]; intro Hnem4f. - + apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - now rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to. - + apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - generalize (app_int i f); intro i'. - rewrite !Pos2Nat.inj_iter. - generalize (Pos.to_nat pnem4f); intro n. - fold (Nat.iter n double (norm i')). - fold (Nat.iter n (Z.mul 2) (Z.of_hex_int i')). - induction n; [now simpl; rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to|]. - now rewrite !Unsigned.nat_iter_S, <-IHn, of_hex_int_double. - + unfold nb_digits, Z.of_nat. - rewrite Z.mul_0_r, Z.sub_0_r. - rewrite <-DecimalZ.to_of, !DecimalZ.of_to. - rewrite app_int_nil_r. - now rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to. -Qed. +Admitted. Lemma of_inj d d' : of_hexadecimal d = of_hexadecimal d' -> hnorme d = hnorme d'. -Proof. - intros. - cut (Some (hnorme d) = Some (hnorme d')); [now intro H'; injection H'|]. - rewrite <- !to_of. now f_equal. -Qed. +Admitted. Lemma of_iff d d' : of_hexadecimal d = of_hexadecimal d' <-> hnorme d = hnorme d'. -Proof. - split. apply of_inj. intros E. rewrite <- of_hexadecimal_hnorme, E. - apply of_hexadecimal_hnorme. -Qed. +Admitted. -- cgit v1.2.3 From ec24b26be7795af27256d39431e1c4e3d42fe3b7 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:16:00 +0200 Subject: [numeral notation] Q Previously rationals were all parsed as a pair numerator, denominator. This means 1.02 and 102e-2 were both parsed as 102 # 100 and could not be tell apart when printing. So the printer had to choose between two representations : without exponent or without decimal dot. The choice was made heuristically toward a most compact representation. Now, decimal dot is still parsed as a power of ten denominator but exponents are parsed as a product or division by Z.pow_pos. For instance, 1.02 is parsed as 102 # 100 whereas 102e-2 is parsed as (102 # 1) / (Z.pow_pos 10 2 # 1). 1.02 and 102e-2 remain equal (proved by reflexivity) but 1.02e1 = (102 # 100) * (10 # 1) = 1020 # 100 and 10.2 = 102 # 10 no longer are. A nice side effect is that exponents can no longer blow up during parsing. Previously 1e1_000_000 literally produced a numerator with a million digits, now it just yields (1 # 1) * (Z.pow_pos 10 1_000_000 # 1). --- test-suite/output/QArithSyntax.out | 90 +++++++++--- test-suite/output/QArithSyntax.v | 34 ++++- theories/Init/Decimal.v | 6 + theories/Init/Hexadecimal.v | 38 +++++ theories/Numbers/DecimalQ.v | 2 +- theories/Numbers/HexadecimalQ.v | 2 +- theories/QArith/QArith_base.v | 285 ++++++++++++++++++++++++------------- 7 files changed, 329 insertions(+), 128 deletions(-) diff --git a/test-suite/output/QArithSyntax.out b/test-suite/output/QArithSyntax.out index 9b5c076cb4..ced52524f2 100644 --- a/test-suite/output/QArithSyntax.out +++ b/test-suite/output/QArithSyntax.out @@ -1,26 +1,72 @@ eq_refl : 1.02 = 1.02 : 1.02 = 1.02 -eq_refl : 10.2 = 10.2 - : 10.2 = 10.2 -eq_refl : 1020 = 1020 - : 1020 = 1020 -eq_refl : 102 = 102 - : 102 = 102 -eq_refl : 1.02 = 1.02 - : 1.02 = 1.02 -eq_refl : -1e-4 = -1e-4 - : -1e-4 = -1e-4 +1.02e1 + : Q +10.2 + : Q +1.02e3 + : Q +1020 + : Q +1.02e2 + : Q +102 + : Q +eq_refl : 10.2e-1 = 1.02 + : 10.2e-1 = 1.02 +eq_refl : -0.0001 = -0.0001 + : -0.0001 = -0.0001 eq_refl : -0.50 = -0.50 : -0.50 = -0.50 -eq_refl : -26 = -26 - : -26 = -26 -eq_refl : 2860 # 256 = 2860 # 256 - : 2860 # 256 = 2860 # 256 -eq_refl : -6882 = -6882 - : -6882 = -6882 -eq_refl : 2860 # 64 = 2860 # 64 - : 2860 # 64 = 2860 # 64 -eq_refl : 2860 = 2860 - : 2860 = 2860 -eq_refl : -2860 # 1024 = -2860 # 1024 - : -2860 # 1024 = -2860 # 1024 +0 + : Q +0 + : Q +42 + : Q +42 + : Q +1.23 + : Q +0x1.23%xQ + : Q +0.0012 + : Q +42e3 + : Q +42e-3 + : Q +eq_refl : -0x1a = -0x1a + : -0x1a = -0x1a +eq_refl : 0xb.2c = 0xb.2c + : 0xb.2c = 0xb.2c +eq_refl : -0x1ae2 = -0x1ae2 + : -0x1ae2 = -0x1ae2 +0xb.2cp2 + : Q +2860 # 64 + : Q +0xb.2cp8 + : Q +0xb2c + : Q +eq_refl : -0xb.2cp-2 = -2860 # 1024 + : -0xb.2cp-2 = -2860 # 1024 +0x0 + : Q +0x0 + : Q +0x2a + : Q +0x2a + : Q +1.23%Q + : Q +0x1.23 + : Q +0x0.0012 + : Q +0x2ap3 + : Q +0x2ap-3 + : Q diff --git a/test-suite/output/QArithSyntax.v b/test-suite/output/QArithSyntax.v index b5c6222bba..e979abca66 100644 --- a/test-suite/output/QArithSyntax.v +++ b/test-suite/output/QArithSyntax.v @@ -1,15 +1,39 @@ Require Import QArith. Open Scope Q_scope. Check (eq_refl : 1.02 = 102 # 100). -Check (eq_refl : 1.02e1 = 102 # 10). -Check (eq_refl : 1.02e+03 = 1020). -Check (eq_refl : 1.02e+02 = 102 # 1). +Check 1.02e1. +Check 102 # 10. +Check 1.02e+03. +Check 1020. +Check 1.02e+02. +Check 102 # 1. Check (eq_refl : 10.2e-1 = 1.02). Check (eq_refl : -0.0001 = -1 # 10000). Check (eq_refl : -0.50 = - 50 # 100). +Check 0. +Check 000. +Check 42. +Check 0x2a. +Check 1.23. +Check 0x1.23. +Check 0.0012. +Check 42e3. +Check 42e-3. +Open Scope hex_Q_scope. Check (eq_refl : -0x1a = - 26 # 1). Check (eq_refl : 0xb.2c = 2860 # 256). Check (eq_refl : -0x1ae2 = -6882). -Check (eq_refl : 0xb.2cp2 = 2860 # 64). -Check (eq_refl : 0xb.2cp8 = 2860). +Check 0xb.2cp2. +Check 2860 # 64. +Check 0xb.2cp8. +Check 2860. Check (eq_refl : -0xb.2cp-2 = -2860 # 1024). +Check 0x0. +Check 0x00. +Check 42. +Check 0x2a. +Check 1.23. +Check 0x1.23. +Check 0x0.0012. +Check 0x2ap3. +Check 0x2ap-3. diff --git a/theories/Init/Decimal.v b/theories/Init/Decimal.v index 025264ab01..bb12f9ca3e 100644 --- a/theories/Init/Decimal.v +++ b/theories/Init/Decimal.v @@ -118,6 +118,12 @@ Definition opp (d:int) := | Neg d => Pos d end. +Definition abs (d:int) : uint := + match d with + | Pos d => d + | Neg d => d + end. + (** For conversions with binary numbers, it is easier to operate on little-endian numbers. *) diff --git a/theories/Init/Hexadecimal.v b/theories/Init/Hexadecimal.v index 36f5e5ad1f..7467aa1262 100644 --- a/theories/Init/Hexadecimal.v +++ b/theories/Init/Hexadecimal.v @@ -125,6 +125,12 @@ Definition opp (d:int) := | Neg d => Pos d end. +Definition abs (d:int) : uint := + match d with + | Pos d => d + | Neg d => d + end. + (** For conversions with binary numbers, it is easier to operate on little-endian numbers. *) @@ -173,6 +179,38 @@ Definition nztail_int d := | Neg d => let (r, n) := nztail d in pair (Neg r) n end. +(** [del_head n d] removes [n] digits at beginning of [d] + or returns [zero] if [d] has less than [n] digits. *) + +Fixpoint del_head n d := + match n with + | O => d + | S n => + match d with + | Nil => zero + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d + | Da d | Db d | Dc d | Dd d | De d | Df d => + del_head n d + end + end. + +Definition del_head_int n d := + match d with + | Pos d => del_head n d + | Neg d => del_head n d + end. + +(** [del_tail n d] removes [n] digits at end of [d] + or returns [zero] if [d] has less than [n] digits. *) + +Definition del_tail n d := rev (del_head n (rev d)). + +Definition del_tail_int n d := + match d with + | Pos d => Pos (del_tail n d) + | Neg d => Neg (del_tail n d) + end. + Module Little. (** Successor of little-endian numbers *) diff --git a/theories/Numbers/DecimalQ.v b/theories/Numbers/DecimalQ.v index d2cd061594..f666c29643 100644 --- a/theories/Numbers/DecimalQ.v +++ b/theories/Numbers/DecimalQ.v @@ -15,7 +15,7 @@ Require Import Decimal DecimalFacts DecimalPos DecimalN DecimalZ QArith. -Lemma of_to (q:Q) : forall d, to_decimal q = Some d -> of_decimal d = q. +Lemma of_to (q:IQ) : forall d, to_decimal q = Some d -> of_decimal d = q. Admitted. (* normalize without fractional part, for instance norme 12.3e-1 is 123e-2 *) diff --git a/theories/Numbers/HexadecimalQ.v b/theories/Numbers/HexadecimalQ.v index ce6f074d70..b773aede8c 100644 --- a/theories/Numbers/HexadecimalQ.v +++ b/theories/Numbers/HexadecimalQ.v @@ -16,7 +16,7 @@ Require Import Decimal DecimalFacts DecimalPos DecimalN DecimalZ. Require Import Hexadecimal HexadecimalFacts HexadecimalPos HexadecimalN HexadecimalZ QArith. -Lemma of_to (q:Q) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. +Lemma of_to (q:IQ) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. Admitted. (* normalize without fractional part, for instance norme 0x1.2p-1 is 0x12e-5 *) diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 151355519e..9a70ac311a 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -18,6 +18,9 @@ Require Export Morphisms Setoid Bool. Record Q : Set := Qmake {Qnum : Z; Qden : positive}. +Declare Scope hex_Q_scope. +Delimit Scope hex_Q_scope with xQ. + Declare Scope Q_scope. Delimit Scope Q_scope with Q. Bind Scope Q_scope with Q. @@ -33,104 +36,6 @@ Ltac simpl_mult := rewrite ?Pos2Z.inj_mul. Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope. -Definition of_decimal (d:Decimal.decimal) : Q := - let '(i, f, e) := - match d with - | Decimal.Decimal i f => (i, f, Decimal.Pos Decimal.Nil) - | Decimal.DecimalExp i f e => (i, f, e) - end in - let num := Z.of_int (Decimal.app_int i f) in - let e := Z.sub (Z.of_int e) (Z.of_nat (Decimal.nb_digits f)) in - match e with - | Z0 => Qmake num 1 - | Zpos e => Qmake (Pos.iter (Z.mul 10) num e) 1 - | Zneg e => Qmake num (Pos.iter (Pos.mul 10) 1%positive e) - end. - -Definition to_decimal (q:Q) : option Decimal.decimal := - (* choose between 123e-2 and 1.23, this is purely heuristic - and doesn't play any soundness role *) - let choose_exponent i ne := - let i := match i with Decimal.Pos i | Decimal.Neg i => i end in - let li := Decimal.nb_digits i in - let le := Decimal.nb_digits (Nat.to_uint ne) in - Nat.ltb (Nat.add li le) ne in - (* print 123 / 100 as 123e-2 *) - let decimal_exponent i ne := - let e := Z.to_int (Z.opp (Z.of_nat ne)) in - Decimal.DecimalExp i Decimal.Nil e in - (* print 123 / 100 as 1.23 *) - let decimal_dot i ne := - let ai := match i with Decimal.Pos i | Decimal.Neg i => i end in - let ni := Decimal.nb_digits ai in - if Nat.ltb ne ni then - let i := Decimal.del_tail_int ne i in - let f := Decimal.del_head (Nat.sub ni ne) ai in - Decimal.Decimal i f - else - let z := match i with - | Decimal.Pos _ => Decimal.Pos (Decimal.zero) - | Decimal.Neg _ => Decimal.Neg (Decimal.zero) end in - Decimal.Decimal z (Nat.iter (Nat.sub ne ni) Decimal.D0 ai) in - let num := Z.to_int (Qnum q) in - let (den, e_den) := Decimal.nztail (Pos.to_uint (Qden q)) in - match den with - | Decimal.D1 Decimal.Nil => - match e_den with - | O => Some (Decimal.Decimal num Decimal.Nil) - | ne => - if choose_exponent num ne then Some (decimal_exponent num ne) - else Some (decimal_dot num ne) - end - | _ => None - end. - -Definition of_hexadecimal (d:Hexadecimal.hexadecimal) : Q := - let '(i, f, e) := - match d with - | Hexadecimal.Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) - | Hexadecimal.HexadecimalExp i f e => (i, f, e) - end in - let num := Z.of_hex_int (Hexadecimal.app_int i f) in - let e := Z.sub (Z.of_int e) (Z.mul 4 (Z.of_nat (Hexadecimal.nb_digits f))) in - match e with - | Z0 => Qmake num 1 - | Zpos e => Qmake (Pos.iter (Z.mul 2) num e) 1 - | Zneg e => Qmake num (Pos.iter (Pos.mul 2) 1%positive e) - end. - -Definition to_hexadecimal (q:Q) : option Hexadecimal.hexadecimal := - let mk_exp i e := - Hexadecimal.HexadecimalExp i Hexadecimal.Nil (Z.to_int (Z.opp e)) in - let num := Z.to_hex_int (Qnum q) in - let (den, e_den) := Hexadecimal.nztail (Pos.to_hex_uint (Qden q)) in - let e := Z.of_nat e_den in - match den with - | Hexadecimal.D1 Hexadecimal.Nil => - match e_den with - | O => Some (Hexadecimal.Hexadecimal num Hexadecimal.Nil) - | _ => Some (mk_exp num (4 * e)%Z) - end - | Hexadecimal.D2 Hexadecimal.Nil => Some (mk_exp num (1 + 4 * e)%Z) - | Hexadecimal.D4 Hexadecimal.Nil => Some (mk_exp num (2 + 4 * e)%Z) - | Hexadecimal.D8 Hexadecimal.Nil => Some (mk_exp num (3 + 4 * e)%Z) - | _ => None - end. - -Definition of_numeral (d:Number.number) : option Q := - match d with - | Number.Dec d => Some (of_decimal d) - | Number.Hex d => Some (of_hexadecimal d) - end. - -Definition to_numeral (q:Q) : option Number.number := - match to_decimal q with - | None => None - | Some q => Some (Number.Dec q) - end. - -Number Notation Q of_numeral to_numeral : Q_scope. - Definition inject_Z (x : Z) := Qmake x 1. Arguments inject_Z x%Z. @@ -316,7 +221,7 @@ Definition Qminus (x y : Q) := Qplus x (Qopp y). Definition Qinv (x : Q) := match Qnum x with - | Z0 => 0 + | Z0 => 0#1 | Zpos p => (QDen x)#p | Zneg p => (Zneg (Qden x))#p end. @@ -335,6 +240,188 @@ Register Qminus as rat.Q.Qminus. Register Qopp as rat.Q.Qopp. Register Qmult as rat.Q.Qmult. +(** Number notation for constants *) + +Inductive IZ := + | IZpow_pos : Z -> positive -> IZ + | IZ0 : IZ + | IZpos : positive -> IZ + | IZneg : positive -> IZ. + +Inductive IQ := + | IQmake : IZ -> positive -> IQ + | IQmult : IQ -> IQ -> IQ + | IQdiv : IQ -> IQ -> IQ. + +Definition IZ_of_Z z := + match z with + | Z0 => IZ0 + | Zpos e => IZpos e + | Zneg e => IZneg e + end. + +Definition IZ_to_Z z := + match z with + | IZ0 => Some Z0 + | IZpos e => Some (Zpos e) + | IZneg e => Some (Zneg e) + | IZpow_pos _ _ => None + end. + +Definition of_decimal (d:Decimal.decimal) : IQ := + let '(i, f, e) := + match d with + | Decimal.Decimal i f => (i, f, Decimal.Pos Decimal.Nil) + | Decimal.DecimalExp i f e => (i, f, e) + end in + let num := Z.of_int (Decimal.app_int i f) in + let den := Nat.iter (Decimal.nb_digits f) (Pos.mul 10) 1%positive in + let q := IQmake (IZ_of_Z num) den in + let e := Z.of_int e in + match e with + | Z0 => q + | Zpos e => IQmult q (IQmake (IZpow_pos 10 e) 1) + | Zneg e => IQdiv q (IQmake (IZpow_pos 10 e) 1) + end. + +Definition IQmake_to_decimal num den := + let num := Z.to_int num in + let (den, e_den) := Decimal.nztail (Pos.to_uint den) in + match den with + | Decimal.D1 Decimal.Nil => + match e_den with + | O => Some (Decimal.Decimal num Decimal.Nil) + | ne => + let ai := Decimal.abs num in + let ni := Decimal.nb_digits ai in + if Nat.ltb ne ni then + let i := Decimal.del_tail_int ne num in + let f := Decimal.del_head (Nat.sub ni ne) ai in + Some (Decimal.Decimal i f) + else + let z := match num with + | Decimal.Pos _ => Decimal.Pos (Decimal.zero) + | Decimal.Neg _ => Decimal.Neg (Decimal.zero) end in + Some (Decimal.Decimal z (Nat.iter (Nat.sub ne ni) Decimal.D0 ai)) + end + | _ => None + end. + +Definition IQmake_to_decimal' num den := + match IZ_to_Z num with + | None => None + | Some num => IQmake_to_decimal num den + end. + +Definition to_decimal (n : IQ) : option Decimal.decimal := + match n with + | IQmake num den => IQmake_to_decimal' num den + | IQmult (IQmake num den) (IQmake (IZpow_pos 10 e) 1) => + match IQmake_to_decimal' num den with + | Some (Decimal.Decimal i f) => + Some (Decimal.DecimalExp i f (Pos.to_int e)) + | _ => None + end + | IQdiv (IQmake num den) (IQmake (IZpow_pos 10 e) 1) => + match IQmake_to_decimal' num den with + | Some (Decimal.Decimal i f) => + Some (Decimal.DecimalExp i f (Decimal.Neg (Pos.to_uint e))) + | _ => None + end + | _ => None + end. + +Definition of_hexadecimal (d:Hexadecimal.hexadecimal) : IQ := + let '(i, f, e) := + match d with + | Hexadecimal.Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) + | Hexadecimal.HexadecimalExp i f e => (i, f, e) + end in + let num := Z.of_hex_int (Hexadecimal.app_int i f) in + let den := Nat.iter (Hexadecimal.nb_digits f) (Pos.mul 16) 1%positive in + let q := IQmake (IZ_of_Z num) den in + let e := Z.of_int e in + match e with + | Z0 => q + | Zpos e => IQmult q (IQmake (IZpow_pos 2 e) 1) + | Zneg e => IQdiv q (IQmake (IZpow_pos 2 e) 1) + end. + +Definition IQmake_to_hexadecimal num den := + let num := Z.to_hex_int num in + let (den, e_den) := Hexadecimal.nztail (Pos.to_hex_uint den) in + match den with + | Hexadecimal.D1 Hexadecimal.Nil => + match e_den with + | O => Some (Hexadecimal.Hexadecimal num Hexadecimal.Nil) + | ne => + let ai := Hexadecimal.abs num in + let ni := Hexadecimal.nb_digits ai in + if Nat.ltb ne ni then + let i := Hexadecimal.del_tail_int ne num in + let f := Hexadecimal.del_head (Nat.sub ni ne) ai in + Some (Hexadecimal.Hexadecimal i f) + else + let z := match num with + | Hexadecimal.Pos _ => Hexadecimal.Pos (Hexadecimal.zero) + | Hexadecimal.Neg _ => Hexadecimal.Neg (Hexadecimal.zero) end in + Some (Hexadecimal.Hexadecimal z (Nat.iter (Nat.sub ne ni) Hexadecimal.D0 ai)) + end + | _ => None + end. + +Definition IQmake_to_hexadecimal' num den := + match IZ_to_Z num with + | None => None + | Some num => IQmake_to_hexadecimal num den + end. + +Definition to_hexadecimal (n : IQ) : option Hexadecimal.hexadecimal := + match n with + | IQmake num den => IQmake_to_hexadecimal' num den + | IQmult (IQmake num den) (IQmake (IZpow_pos 2 e) 1) => + match IQmake_to_hexadecimal' num den with + | Some (Hexadecimal.Hexadecimal i f) => + Some (Hexadecimal.HexadecimalExp i f (Pos.to_int e)) + | _ => None + end + | IQdiv (IQmake num den) (IQmake (IZpow_pos 2 e) 1) => + match IQmake_to_hexadecimal' num den with + | Some (Hexadecimal.Hexadecimal i f) => + Some (Hexadecimal.HexadecimalExp i f (Decimal.Neg (Pos.to_uint e))) + | _ => None + end + | _ => None + end. + +Definition of_number (n : Number.number) : IQ := + match n with + | Number.Dec d => of_decimal d + | Number.Hex h => of_hexadecimal h + end. + +Definition to_number (q:IQ) : option Number.number := + match to_decimal q with + | None => None + | Some q => Some (Number.Dec q) + end. + +Definition to_hex_number q := + match to_hexadecimal q with + | None => None + | Some q => Some (Number.Hex q) + end. + +Number Notation Q of_number to_hex_number (via IQ + mapping [Qmake => IQmake, Qmult => IQmult, Qdiv => IQdiv, + Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) + : hex_Q_scope. + +Number Notation Q of_number to_number (via IQ + mapping [Qmake => IQmake, Qmult => IQmult, Qdiv => IQdiv, + Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) + : Q_scope. + (** A light notation for [Zpos] *) Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z (Zpos b). -- cgit v1.2.3 From 398dc5e41a25b5488a648782946a408e5312c1dc Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:17:00 +0200 Subject: [numeral notation] Specify Q --- theories/Numbers/DecimalQ.v | 118 +++++++++++++++++++++------------------- theories/Numbers/HexadecimalQ.v | 97 ++++++++++++++++++++++----------- 2 files changed, 127 insertions(+), 88 deletions(-) diff --git a/theories/Numbers/DecimalQ.v b/theories/Numbers/DecimalQ.v index f666c29643..d9642d7b02 100644 --- a/theories/Numbers/DecimalQ.v +++ b/theories/Numbers/DecimalQ.v @@ -18,78 +18,84 @@ Require Import Decimal DecimalFacts DecimalPos DecimalN DecimalZ QArith. Lemma of_to (q:IQ) : forall d, to_decimal q = Some d -> of_decimal d = q. Admitted. -(* normalize without fractional part, for instance norme 12.3e-1 is 123e-2 *) -Definition dnorme (d:decimal) : decimal := - let '(i, f, e) := - match d with - | Decimal i f => (i, f, Pos Nil) - | DecimalExp i f e => (i, f, e) +Definition dnorm (d:decimal) : decimal := + let norm_i i f := + match i with + | Pos i => Pos (unorm i) + | Neg i => match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end end in - let i := norm (app_int i f) in - let e := norm (Z.to_int (Z.of_int e - Z.of_nat (nb_digits f))) in - match e with - | Pos zero => Decimal i Nil - | _ => DecimalExp i Nil e - end. - -(* normalize without exponent part, for instance norme 12.3e-1 is 1.23 *) -Definition dnormf (d:decimal) : decimal := - match dnorme d with - | Decimal i _ => Decimal i Nil - | DecimalExp i _ e => - match Z.of_int e with - | Z0 => Decimal i Nil - | Zpos e => Decimal (norm (app_int i (Pos.iter D0 Nil e))) Nil - | Zneg e => - let ne := Pos.to_nat e in - let ai := match i with Pos d | Neg d => d end in - let ni := nb_digits ai in - if ne Pos zero | Neg _ => Neg zero end in - Decimal z (Nat.iter (ne - ni) D0 ai) + match d with + | Decimal i f => Decimal (norm_i i f) f + | DecimalExp i f e => + match norm e with + | Pos zero => Decimal (norm_i i f) f + | e => DecimalExp (norm_i i f) f e end end. -Lemma dnorme_spec d : - match dnorme d with - | Decimal i Nil => i = norm i - | DecimalExp i Nil e => i = norm i /\ e = norm e /\ e <> Pos zero - | _ => False +Lemma dnorm_spec_i d : + let (i, f) := + match d with Decimal i f => (i, f) | DecimalExp i f _ => (i, f) end in + let i' := match dnorm d with Decimal i _ => i | DecimalExp i _ _ => i end in + match i with + | Pos i => i' = Pos (unorm i) + | Neg i => + (i' = Neg (unorm i) /\ (nzhead i <> Nil \/ nzhead f <> Nil)) + \/ (i' = Pos zero /\ (nzhead i = Nil /\ nzhead f = Nil)) end. Admitted. -Lemma dnormf_spec d : - match dnormf d with - | Decimal i f => i = Neg zero \/ i = norm i - | _ => False - end. +Lemma dnorm_spec_f d : + let f := match d with Decimal _ f => f | DecimalExp _ f _ => f end in + let f' := match dnorm d with Decimal _ f => f | DecimalExp _ f _ => f end in + f' = f. Admitted. -Lemma dnorme_invol d : dnorme (dnorme d) = dnorme d. +Lemma dnorm_spec_e d : + match d, dnorm d with + | Decimal _ _, Decimal _ _ => True + | DecimalExp _ _ e, Decimal _ _ => norm e = Pos zero + | DecimalExp _ _ e, DecimalExp _ _ e' => e' = norm e /\ e' <> Pos zero + | Decimal _ _, DecimalExp _ _ _ => False + end. Admitted. -Lemma dnormf_invol d : dnormf (dnormf d) = dnormf d. +Lemma dnorm_invol d : dnorm (dnorm d) = dnorm d. Admitted. -Lemma to_of (d:decimal) : - to_decimal (of_decimal d) = Some (dnorme d) - \/ to_decimal (of_decimal d) = Some (dnormf d). +Lemma to_of (d:decimal) : to_decimal (of_decimal d) = Some (dnorm d). Admitted. (** Some consequences *) Lemma to_decimal_inj q q' : to_decimal q <> None -> to_decimal q = to_decimal q' -> q = q'. -Admitted. - -Lemma to_decimal_surj d : - exists q, to_decimal q = Some (dnorme d) \/ to_decimal q = Some (dnormf d). -Admitted. - -Lemma of_decimal_dnorme d : of_decimal (dnorme d) = of_decimal d. -Admitted. - -Lemma of_decimal_dnormf d : of_decimal (dnormf d) = of_decimal d. -Admitted. +Proof. +intros Hnone EQ. +generalize (of_to q) (of_to q'). +rewrite <-EQ. +revert Hnone; case to_decimal; [|now simpl]. +now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). +Qed. + +Lemma to_decimal_surj d : exists q, to_decimal q = Some (dnorm d). +Proof. + exists (of_decimal d). apply to_of. +Qed. + +Lemma of_decimal_dnorm d : of_decimal (dnorm d) = of_decimal d. +Proof. now apply to_decimal_inj; rewrite !to_of; [|rewrite dnorm_invol]. Qed. + +Lemma of_inj d d' : of_decimal d = of_decimal d' -> dnorm d = dnorm d'. +Proof. +intro H. +apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). +now rewrite <- !to_of, H. +Qed. + +Lemma of_iff d d' : of_decimal d = of_decimal d' <-> dnorm d = dnorm d'. +Proof. +split. apply of_inj. intros E. rewrite <- of_decimal_dnorm, E. +apply of_decimal_dnorm. +Qed. diff --git a/theories/Numbers/HexadecimalQ.v b/theories/Numbers/HexadecimalQ.v index b773aede8c..bbafa7ddc1 100644 --- a/theories/Numbers/HexadecimalQ.v +++ b/theories/Numbers/HexadecimalQ.v @@ -19,53 +19,86 @@ Require Import Hexadecimal HexadecimalFacts HexadecimalPos HexadecimalN Hexadeci Lemma of_to (q:IQ) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. Admitted. -(* normalize without fractional part, for instance norme 0x1.2p-1 is 0x12e-5 *) -Definition hnorme (d:hexadecimal) : hexadecimal := - let '(i, f, e) := - match d with - | Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) - | HexadecimalExp i f e => (i, f, e) +Definition dnorm (d:hexadecimal) : hexadecimal := + let norm_i i f := + match i with + | Pos i => Pos (unorm i) + | Neg i => match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end end in - let i := norm (app_int i f) in - let e := (Z.of_int e - 4 * Z.of_nat (nb_digits f))%Z in - match e with - | Z0 => Hexadecimal i Nil - | Zpos e => Hexadecimal (Pos.iter double i e) Nil - | Zneg _ => HexadecimalExp i Nil (Decimal.norm (Z.to_int e)) + match d with + | Hexadecimal i f => Hexadecimal (norm_i i f) f + | HexadecimalExp i f e => + match Decimal.norm e with + | Decimal.Pos Decimal.zero => Hexadecimal (norm_i i f) f + | e => HexadecimalExp (norm_i i f) f e + end end. -Lemma hnorme_spec d : - match hnorme d with - | Hexadecimal i Nil => i = norm i - | HexadecimalExp i Nil e => - i = norm i /\ e = Decimal.norm e /\ e <> Decimal.Pos Decimal.zero - | _ => False +Lemma dnorm_spec_i d : + let (i, f) := + match d with Hexadecimal i f => (i, f) | HexadecimalExp i f _ => (i, f) end in + let i' := match dnorm d with Hexadecimal i _ => i | HexadecimalExp i _ _ => i end in + match i with + | Pos i => i' = Pos (unorm i) + | Neg i => + (i' = Neg (unorm i) /\ (nzhead i <> Nil \/ nzhead f <> Nil)) + \/ (i' = Pos zero /\ (nzhead i = Nil /\ nzhead f = Nil)) end. Admitted. -Lemma hnorme_invol d : hnorme (hnorme d) = hnorme d. +Lemma dnorm_spec_f d : + let f := match d with Hexadecimal _ f => f | HexadecimalExp _ f _ => f end in + let f' := match dnorm d with Hexadecimal _ f => f | HexadecimalExp _ f _ => f end in + f' = f. Admitted. -Lemma to_of (d:hexadecimal) : - to_hexadecimal (of_hexadecimal d) = Some (hnorme d). +Lemma dnorm_spec_e d : + match d, dnorm d with + | Hexadecimal _ _, Hexadecimal _ _ => True + | HexadecimalExp _ _ e, Hexadecimal _ _ => + Decimal.norm e = Decimal.Pos Decimal.zero + | HexadecimalExp _ _ e, HexadecimalExp _ _ e' => + e' = Decimal.norm e /\ e' <> Decimal.Pos Decimal.zero + | Hexadecimal _ _, HexadecimalExp _ _ _ => False + end. +Admitted. + +Lemma dnorm_invol d : dnorm (dnorm d) = dnorm d. +Admitted. + +Lemma to_of (d:hexadecimal) : to_hexadecimal (of_hexadecimal d) = Some (dnorm d). Admitted. (** Some consequences *) Lemma to_hexadecimal_inj q q' : to_hexadecimal q <> None -> to_hexadecimal q = to_hexadecimal q' -> q = q'. -Admitted. +Proof. +intros Hnone EQ. +generalize (of_to q) (of_to q'). +rewrite <-EQ. +revert Hnone; case to_hexadecimal; [|now simpl]. +now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). +Qed. -Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (hnorme d). -Admitted. +Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (dnorm d). +Proof. + exists (of_hexadecimal d). apply to_of. +Qed. -Lemma of_hexadecimal_hnorme d : of_hexadecimal (hnorme d) = of_hexadecimal d. -Admitted. +Lemma of_hexadecimal_dnorm d : of_hexadecimal (dnorm d) = of_hexadecimal d. +Proof. now apply to_hexadecimal_inj; rewrite !to_of; [|rewrite dnorm_invol]. Qed. -Lemma of_inj d d' : - of_hexadecimal d = of_hexadecimal d' -> hnorme d = hnorme d'. -Admitted. +Lemma of_inj d d' : of_hexadecimal d = of_hexadecimal d' -> dnorm d = dnorm d'. +Proof. +intro H. +apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). +now rewrite <- !to_of, H. +Qed. -Lemma of_iff d d' : - of_hexadecimal d = of_hexadecimal d' <-> hnorme d = hnorme d'. -Admitted. +Lemma of_iff d d' : of_hexadecimal d = of_hexadecimal d' <-> dnorm d = dnorm d'. +Proof. +split. apply of_inj. intros E. rewrite <- of_hexadecimal_dnorm, E. +apply of_hexadecimal_dnorm. +Qed. -- cgit v1.2.3 From 11f8d8fca374565b4cad542e131fd32a50a70440 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:18:00 +0200 Subject: [numeral notation] Prove Q --- theories/Numbers/DecimalFacts.v | 607 ++++++++++++++++++++++++---------- theories/Numbers/DecimalN.v | 4 +- theories/Numbers/DecimalNat.v | 4 +- theories/Numbers/DecimalQ.v | 396 +++++++++++++++++++++-- theories/Numbers/DecimalZ.v | 27 +- theories/Numbers/HexadecimalFacts.v | 627 +++++++++++++++++++++++++++++------- theories/Numbers/HexadecimalN.v | 4 +- theories/Numbers/HexadecimalNat.v | 4 +- theories/Numbers/HexadecimalQ.v | 393 ++++++++++++++++++++-- theories/Numbers/HexadecimalZ.v | 27 +- 10 files changed, 1742 insertions(+), 351 deletions(-) diff --git a/theories/Numbers/DecimalFacts.v b/theories/Numbers/DecimalFacts.v index dd361562ba..87a9f704cd 100644 --- a/theories/Numbers/DecimalFacts.v +++ b/theories/Numbers/DecimalFacts.v @@ -10,175 +10,425 @@ (** * DecimalFacts : some facts about Decimal numbers *) -Require Import Decimal Arith. +Require Import Decimal Arith ZArith. + +Variant digits := d0 | d1 | d2 | d3 | d4 | d5 | d6 | d7 | d8 | d9. + +Fixpoint to_list (u : uint) : list digits := + match u with + | Nil => nil + | D0 u => cons d0 (to_list u) + | D1 u => cons d1 (to_list u) + | D2 u => cons d2 (to_list u) + | D3 u => cons d3 (to_list u) + | D4 u => cons d4 (to_list u) + | D5 u => cons d5 (to_list u) + | D6 u => cons d6 (to_list u) + | D7 u => cons d7 (to_list u) + | D8 u => cons d8 (to_list u) + | D9 u => cons d9 (to_list u) + end. -Lemma uint_dec (d d' : uint) : { d = d' } + { d <> d' }. -Proof. - decide equality. -Defined. +Fixpoint of_list (l : list digits) : uint := + match l with + | nil => Nil + | cons d0 l => D0 (of_list l) + | cons d1 l => D1 (of_list l) + | cons d2 l => D2 (of_list l) + | cons d3 l => D3 (of_list l) + | cons d4 l => D4 (of_list l) + | cons d5 l => D5 (of_list l) + | cons d6 l => D6 (of_list l) + | cons d7 l => D7 (of_list l) + | cons d8 l => D8 (of_list l) + | cons d9 l => D9 (of_list l) + end. -Lemma rev_revapp d d' : - rev (revapp d d') = revapp d' d. +Lemma of_list_to_list u : of_list (to_list u) = u. +Proof. now induction u; [|simpl; rewrite IHu..]. Qed. + +Lemma to_list_of_list l : to_list (of_list l) = l. +Proof. now induction l as [|h t IHl]; [|case h; simpl; rewrite IHl]. Qed. + +Lemma to_list_inj u u' : to_list u = to_list u' -> u = u'. Proof. - revert d'. induction d; simpl; intros; now rewrite ?IHd. + now intro H; rewrite <-(of_list_to_list u), <-(of_list_to_list u'), H. Qed. -Lemma rev_rev d : rev (rev d) = d. +Lemma of_list_inj u u' : of_list u = of_list u' -> u = u'. Proof. - apply rev_revapp. + now intro H; rewrite <-(to_list_of_list u), <-(to_list_of_list u'), H. Qed. -Lemma revapp_rev_nil d : revapp (rev d) Nil = d. -Proof. now fold (rev (rev d)); rewrite rev_rev. Qed. +Lemma nb_digits_spec u : nb_digits u = length (to_list u). +Proof. now induction u; [|simpl; rewrite IHu..]. Qed. -Lemma app_nil_r d : app d Nil = d. -Proof. now unfold app; rewrite revapp_rev_nil. Qed. +Fixpoint lnzhead l := + match l with + | nil => nil + | cons d l' => + match d with + | d0 => lnzhead l' + | _ => l + end + end. -Lemma app_int_nil_r d : app_int d Nil = d. -Proof. now case d; intro d'; simpl; rewrite app_nil_r. Qed. +Lemma nzhead_spec u : to_list (nzhead u) = lnzhead (to_list u). +Proof. now induction u; [|simpl; rewrite IHu|..]. Qed. + +Definition lzero := cons d0 nil. + +Definition lunorm l := + match lnzhead l with + | nil => lzero + | d => d + end. + +Lemma unorm_spec u : to_list (unorm u) = lunorm (to_list u). +Proof. now unfold unorm, lunorm; rewrite <-nzhead_spec; case (nzhead u). Qed. -Lemma revapp_revapp_1 d d' d'' : - nb_digits d <= 1 -> - revapp (revapp d d') d'' = revapp d' (revapp d d''). +Lemma revapp_spec d d' : + to_list (revapp d d') = List.rev_append (to_list d) (to_list d'). +Proof. now revert d'; induction d; intro d'; [|simpl; rewrite IHd..]. Qed. + +Lemma rev_spec d : to_list (rev d) = List.rev (to_list d). +Proof. now unfold rev; rewrite revapp_spec, List.rev_alt; simpl. Qed. + +Lemma app_spec d d' : + to_list (app d d') = Datatypes.app (to_list d) (to_list d'). Proof. - now case d; clear d; intro d; - [|case d; clear d; intro d; - [|simpl; case nb_digits; [|intros n]; intros Hn; exfalso; - [apply (Nat.nle_succ_diag_l _ Hn)| - apply (Nat.nle_succ_0 _ (le_S_n _ _ Hn))]..]..]. + unfold app. + now rewrite revapp_spec, List.rev_append_rev, rev_spec, List.rev_involutive. Qed. -Lemma nb_digits_pos d : d <> Nil -> 0 < nb_digits d. -Proof. now case d; [|intros d' _; apply Nat.lt_0_succ..]. Qed. +Definition lnztail l := + let fix aux l_rev := + match l_rev with + | cons d0 l_rev => let (r, n) := aux l_rev in pair r (S n) + | _ => pair l_rev O + end in + let (r, n) := aux (List.rev l) in pair (List.rev r) n. -Lemma nb_digits_revapp d d' : - nb_digits (revapp d d') = nb_digits d + nb_digits d'. +Lemma nztail_spec d : + let (r, n) := nztail d in + let (r', n') := lnztail (to_list d) in + to_list r = r' /\ n = n'. Proof. - now revert d'; induction d; [|intro d'; simpl; rewrite IHd; simpl..]. + unfold nztail, lnztail. + set (f := fix aux d_rev := match d_rev with + | D0 d_rev => let (r, n) := aux d_rev in (r, S n) + | _ => (d_rev, 0) end). + set (f' := fix aux (l_rev : list digits) : list digits * nat := + match l_rev with + | cons d0 l_rev => let (r, n) := aux l_rev in (r, S n) + | _ => (l_rev, 0) + end). + rewrite <-(of_list_to_list (rev d)), rev_spec. + induction (List.rev _) as [|h t IHl]; [now simpl|]. + case h; simpl; [|now rewrite rev_spec; simpl; rewrite to_list_of_list..]. + now revert IHl; case f; intros r n; case f'; intros r' n' [-> ->]. Qed. -Lemma nb_digits_rev u : nb_digits (rev u) = nb_digits u. -Proof. now unfold rev; rewrite nb_digits_revapp. Qed. +Lemma del_head_spec_0 d : del_head 0 d = d. +Proof. now simpl. Qed. -Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. -Proof. now induction u; [|apply le_S|..]. Qed. +Lemma del_head_spec_small n d : + n <= length (to_list d) -> to_list (del_head n d) = List.skipn n (to_list d). +Proof. + revert d; induction n as [|n IHn]; intro d; [now simpl|]. + now case d; [|intros d' H; apply IHn, le_S_n..]. +Qed. -Lemma del_head_nb_digits (u:uint) : del_head (nb_digits u) u = Nil. -Proof. now induction u. Qed. +Lemma del_head_spec_large n d : length (to_list d) < n -> del_head n d = zero. +Proof. + revert d; induction n; intro d; [now case d|]. + now case d; [|intro d'; simpl; intro H; rewrite (IHn _ (lt_S_n _ _ H))..]. +Qed. -Lemma nb_digits_del_head n u : - n <= nb_digits u -> nb_digits (del_head n u) = nb_digits u - n. +Lemma nb_digits_0 d : nb_digits d = 0 -> d = Nil. Proof. - revert u; induction n; intros u; [now rewrite Nat.sub_0_r|]. - now case u; clear u; intro u; [|intro Hn; apply IHn, le_S_n..]. + rewrite nb_digits_spec, <-(of_list_to_list d). + now case (to_list d) as [|h t]; [|rewrite to_list_of_list]. Qed. +Lemma nb_digits_n0 d : nb_digits d <> 0 -> d <> Nil. +Proof. now case d; [|intros u _..]. Qed. + Lemma nb_digits_iter_D0 n d : nb_digits (Nat.iter n D0 d) = n + nb_digits d. Proof. now induction n; simpl; [|rewrite IHn]. Qed. -Fixpoint nth n u := - match n with - | O => - match u with - | Nil => Nil - | D0 d => D0 Nil - | D1 d => D1 Nil - | D2 d => D2 Nil - | D3 d => D3 Nil - | D4 d => D4 Nil - | D5 d => D5 Nil - | D6 d => D6 Nil - | D7 d => D7 Nil - | D8 d => D8 Nil - | D9 d => D9 Nil - end - | S n => - match u with - | Nil => Nil - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => - nth n d - end - end. +Lemma length_lnzhead l : length (lnzhead l) <= length l. +Proof. now induction l as [|h t IHl]; [|case h; [apply le_S|..]]. Qed. + +Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. +Proof. now induction u; [|apply le_S|..]. Qed. + +Lemma unorm_nzhead u : nzhead u <> Nil -> unorm u = nzhead u. +Proof. now unfold unorm; case nzhead. Qed. -Lemma nb_digits_nth n u : nb_digits (nth n u) <= 1. +Lemma nb_digits_unorm u : u <> Nil -> nb_digits (unorm u) <= nb_digits u. Proof. - revert u; induction n. - - now intro u; case u; [apply Nat.le_0_1|..]. - - intro u; case u; [apply Nat.le_0_1|intro u'; apply IHn..]. + intro Hu; case (uint_eq_dec (nzhead u) Nil). + { unfold unorm; intros ->; simpl. + now revert Hu; case u; [|intros u' _; apply le_n_S, Nat.le_0_l..]. } + intro H; rewrite (unorm_nzhead _ H); apply nb_digits_nzhead. Qed. -Lemma del_head_nth n u : - n < nb_digits u -> - del_head n u = revapp (nth n u) (del_head (S n) u). -Proof. - revert u; induction n; intro u; [now case u|]. - now case u; [|intro u'; intro H; apply IHn, le_S_n..]. -Qed. - -Lemma nth_revapp_r n d d' : - nb_digits d <= n -> - nth n (revapp d d') = nth (n - nb_digits d) d'. -Proof. - revert d d'; induction n; intro d. - - now case d; intro d'; - [case d'|intros d'' H; exfalso; revert H; apply Nat.nle_succ_0..]. - - now induction d; - [intro d'; case d'| - intros d' H; - simpl revapp; rewrite IHd; [|now apply le_Sn_le]; - rewrite Nat.sub_succ_l; [|now apply le_S_n]; - simpl; rewrite <-(IHn _ _ (le_S_n _ _ H))..]. -Qed. - -Lemma nth_revapp_l n d d' : - n < nb_digits d -> - nth n (revapp d d') = nth (nb_digits d - n - 1) d. -Proof. - revert d d'; induction n; intro d. - - rewrite Nat.sub_0_r. - now induction d; - [|intros d' _; simpl revapp; - revert IHd; case d; clear d; [|intro d..]; intro IHd; - [|rewrite IHd; [simpl nb_digits; rewrite (Nat.sub_succ_l _ (S _))|]; - [|apply le_n_S, Nat.le_0_l..]..]..]. - - now induction d; - [|intros d' H; - simpl revapp; simpl nb_digits; - simpl in H; generalize (lt_S_n _ _ H); clear H; intro H; - case (le_lt_eq_dec _ _ H); clear H; intro H; - [rewrite (IHd _ H), Nat.sub_succ_l; - [rewrite Nat.sub_succ_l; [|apply Nat.le_add_le_sub_r]| - apply le_Sn_le]| - rewrite nth_revapp_r; rewrite <-H; - [rewrite Nat.sub_succ, Nat.sub_succ_l; [rewrite !Nat.sub_diag|]|]]..]. -Qed. - -Lemma app_del_tail_head (u:uint) n : - n <= nb_digits u -> - app (del_tail n u) (del_head (nb_digits u - n) u) = u. -Proof. - unfold app, del_tail; rewrite rev_rev. - induction n. - - intros _; rewrite Nat.sub_0_r, del_head_nb_digits; simpl. - now rewrite revapp_rev_nil. - - intro Hn. - rewrite (del_head_nth (_ - _)); - [|now apply Nat.sub_lt; [|apply Nat.lt_0_succ]]. - rewrite Nat.sub_succ_r, <-Nat.sub_1_r. - rewrite <-(nth_revapp_l _ _ Nil Hn); fold (rev u). - rewrite <-revapp_revapp_1; [|now apply nb_digits_nth]. - rewrite <-(del_head_nth _ _); [|now rewrite nb_digits_rev]. - rewrite Nat.sub_1_r, Nat.succ_pred_pos; [|now apply Nat.lt_add_lt_sub_r]. - apply (IHn (le_Sn_le _ _ Hn)). +Lemma nb_digits_rev d : nb_digits (rev d) = nb_digits d. +Proof. now rewrite !nb_digits_spec, rev_spec, List.rev_length. Qed. + +Lemma nb_digits_del_head_sub d n : + n <= nb_digits d -> + nb_digits (del_head (nb_digits d - n) d) = n. +Proof. + rewrite !nb_digits_spec; intro Hn. + rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. + rewrite List.skipn_length, <-(Nat2Z.id (_ - _)). + rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. + rewrite (Nat2Z.inj_sub _ _ Hn). + rewrite Z.sub_sub_distr, Z.sub_diag; apply Nat2Z.id. +Qed. + +Lemma unorm_D0 u : unorm (D0 u) = unorm u. +Proof. reflexivity. Qed. + +Lemma app_nil_l d : app Nil d = d. +Proof. now simpl. Qed. + +Lemma app_nil_r d : app d Nil = d. +Proof. now apply to_list_inj; rewrite app_spec, List.app_nil_r. Qed. + +Lemma abs_app_int d d' : abs (app_int d d') = app (abs d) d'. +Proof. now case d. Qed. + +Lemma abs_norm d : abs (norm d) = unorm (abs d). +Proof. now case d as [u|u]; [|simpl; unfold unorm; case nzhead]. Qed. + +Lemma iter_D0_nzhead d : + Nat.iter (nb_digits d - nb_digits (nzhead d)) D0 (nzhead d) = d. +Proof. + induction d; [now simpl| |now rewrite Nat.sub_diag..]. + simpl nzhead; simpl nb_digits. + rewrite (Nat.sub_succ_l _ _ (nb_digits_nzhead _)). + now rewrite <-IHd at 4. +Qed. + +Lemma iter_D0_unorm d : + d <> Nil -> + Nat.iter (nb_digits d - nb_digits (unorm d)) D0 (unorm d) = d. +Proof. + case (uint_eq_dec (nzhead d) Nil); intro Hn. + { unfold unorm; rewrite Hn; simpl; intro H. + revert H Hn; induction d; [now simpl|intros _|now intros _..]. + case (uint_eq_dec d Nil); simpl; intros H Hn; [now rewrite H|]. + rewrite Nat.sub_0_r, (le_plus_minus 1 (nb_digits d)). + { now simpl; rewrite IHd. } + revert H; case d; [now simpl|intros u _; apply le_n_S, Nat.le_0_l..]. } + intros _; rewrite (unorm_nzhead _ Hn); apply iter_D0_nzhead. +Qed. + +Lemma nzhead_app_l d d' : + nb_digits d' < nb_digits (nzhead (app d d')) -> + nzhead (app d d') = app (nzhead d) d'. +Proof. + intro Hl; apply to_list_inj; revert Hl. + rewrite !nb_digits_spec, app_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]. + { now simpl; intro H; exfalso; revert H; apply le_not_lt, length_lnzhead. } + rewrite <-List.app_comm_cons. + now case h; [simpl; intro Hl; apply IHl|..]. +Qed. + +Lemma nzhead_app_r d d' : + nb_digits (nzhead (app d d')) <= nb_digits d' -> + nzhead (app d d') = nzhead d'. +Proof. + intro Hl; apply to_list_inj; revert Hl. + rewrite !nb_digits_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + rewrite <-List.app_comm_cons. + now case h; [| simpl; rewrite List.app_length; intro Hl; exfalso; revert Hl; + apply le_not_lt, le_plus_r..]. +Qed. + +Lemma nzhead_app_nil_r d d' : nzhead (app d d') = Nil -> nzhead d' = Nil. +Proof. +now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. +Qed. + +Lemma nzhead_app_nil d d' : + nb_digits (nzhead (app d d')) <= nb_digits d' -> nzhead d = Nil. +Proof. + intro H; apply to_list_inj; revert H. + rewrite !nb_digits_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + now case h; [now simpl|..]; + simpl;intro H; exfalso; revert H; apply le_not_lt; + rewrite List.app_length; apply le_plus_r. +Qed. + +Lemma nzhead_app_nil_l d d' : nzhead (app d d') = Nil -> nzhead d = Nil. +Proof. + intro H; apply to_list_inj; generalize (f_equal to_list H); clear H. + rewrite !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + now rewrite <-List.app_comm_cons; case h. +Qed. + +Lemma unorm_app_zero d d' : + nb_digits (unorm (app d d')) <= nb_digits d' -> unorm d = zero. +Proof. + unfold unorm. + case (uint_eq_dec (nzhead (app d d')) Nil). + { now intro Hn; rewrite Hn, (nzhead_app_nil_l _ _ Hn). } + intro H; fold (unorm (app d d')); rewrite (unorm_nzhead _ H); intro H'. + case (uint_eq_dec (nzhead d) Nil); [now intros->|]. + intro H''; fold (unorm d); rewrite (unorm_nzhead _ H''). + exfalso; apply H''; revert H'; apply nzhead_app_nil. +Qed. + +Lemma app_int_nil_r d : app_int d Nil = d. +Proof. + now case d; intro d'; simpl; + rewrite <-(of_list_to_list (app _ _)), app_spec; + rewrite List.app_nil_r, of_list_to_list. +Qed. + +Lemma unorm_app_l d d' : + nb_digits d' < nb_digits (unorm (app d d')) -> + unorm (app d d') = app (unorm d) d'. +Proof. + case (uint_eq_dec d' Nil); [now intros->; rewrite !app_nil_r|intro Hd']. + case (uint_eq_dec (nzhead (app d d')) Nil). + { unfold unorm; intros->; simpl; intro H; exfalso; revert H; apply le_not_lt. + now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } + intro Ha; rewrite (unorm_nzhead _ Ha). + intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). + rewrite !nb_digits_spec, app_spec, List.app_length. + case (uint_eq_dec (nzhead d) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } + now intro H; rewrite (unorm_nzhead _ H). +Qed. + +Lemma unorm_app_r d d' : + nb_digits (unorm (app d d')) <= nb_digits d' -> + unorm (app d d') = unorm d'. +Proof. + case (uint_eq_dec (nzhead (app d d')) Nil). + { now unfold unorm; intro H; rewrite H, (nzhead_app_nil_r _ _ H). } + intro Ha; rewrite (unorm_nzhead _ Ha). + case (uint_eq_dec (nzhead d') Nil). + { now intros H H'; exfalso; apply Ha; rewrite nzhead_app_r. } + intro Hd'; rewrite (unorm_nzhead _ Hd'); apply nzhead_app_r. +Qed. + +Lemma norm_app_int d d' : + nb_digits d' < nb_digits (unorm (app (abs d) d')) -> + norm (app_int d d') = app_int (norm d) d'. +Proof. + case (uint_eq_dec d' Nil); [now intros->; rewrite !app_int_nil_r|intro Hd']. + case d as [d|d]; [now simpl; intro H; apply f_equal, unorm_app_l|]. + simpl; unfold unorm. + case (uint_eq_dec (nzhead (app d d')) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply le_not_lt. + now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } + set (m := match nzhead _ with Nil => _ | _ => _ end). + intro Ha. + replace m with (nzhead (app d d')). + 2:{ now unfold m; revert Ha; case nzhead. } + intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). + case (uint_eq_dec (app (nzhead d) d') Nil). + { intros->; simpl; intro H; exfalso; revert H; apply le_not_lt, Nat.le_0_l. } + clear m; set (m := match app _ _ with Nil => _ | _ => _ end). + intro Ha'. + replace m with (Neg (app (nzhead d) d')); [|now unfold m; revert Ha'; case app]. + case (uint_eq_dec (nzhead d) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + intro Hd. + now replace m with (Neg (nzhead d)); [|unfold m; revert Hd; case nzhead]. +Qed. + +Lemma del_head_nb_digits d : del_head (nb_digits d) d = Nil. +Proof. + apply to_list_inj. + rewrite nb_digits_spec, del_head_spec_small; [|now simpl]. + now rewrite List.skipn_all. +Qed. + +Lemma del_tail_nb_digits d : del_tail (nb_digits d) d = Nil. +Proof. now unfold del_tail; rewrite <-nb_digits_rev, del_head_nb_digits. Qed. + +Lemma del_head_app n d d' : + n <= nb_digits d -> del_head n (app d d') = app (del_head n d) d'. +Proof. + rewrite nb_digits_spec; intro Hn. + apply to_list_inj. + rewrite del_head_spec_small. + 2:{ now rewrite app_spec, List.app_length; apply le_plus_trans. } + rewrite !app_spec, (del_head_spec_small _ _ Hn). + rewrite List.skipn_app. + now rewrite (proj2 (Nat.sub_0_le _ _) Hn). +Qed. + +Lemma del_tail_app n d d' : + n <= nb_digits d' -> del_tail n (app d d') = app d (del_tail n d'). +Proof. + rewrite nb_digits_spec; intro Hn. + unfold del_tail. + rewrite <-(of_list_to_list (rev (app d d'))), rev_spec, app_spec. + rewrite List.rev_app_distr, <-!rev_spec, <-app_spec, of_list_to_list. + rewrite del_head_app; [|now rewrite nb_digits_spec, rev_spec, List.rev_length]. + apply to_list_inj. + rewrite rev_spec, !app_spec, !rev_spec. + now rewrite List.rev_app_distr, List.rev_involutive. +Qed. + +Lemma del_tail_app_int n d d' : + n <= nb_digits d' -> del_tail_int n (app_int d d') = app_int d (del_tail n d'). +Proof. now case d as [d|d]; simpl; intro H; rewrite del_tail_app. Qed. + +Lemma app_del_tail_head n (d:uint) : + n <= nb_digits d -> app (del_tail n d) (del_head (nb_digits d - n) d) = d. +Proof. + rewrite nb_digits_spec; intro Hn; unfold del_tail. + rewrite <-(of_list_to_list (app _ _)), app_spec, rev_spec. + rewrite del_head_spec_small; [|now rewrite rev_spec, List.rev_length]. + rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. + rewrite rev_spec. + set (n' := _ - n). + assert (Hn' : n = length (to_list d) - n'). + { now apply plus_minus; rewrite Nat.add_comm; symmetry; apply le_plus_minus_r. } + now rewrite Hn', <-List.firstn_skipn_rev, List.firstn_skipn, of_list_to_list. Qed. Lemma app_int_del_tail_head n (d:int) : - let ad := match d with Pos d | Neg d => d end in - n <= nb_digits ad -> - app_int (del_tail_int n d) (del_head (nb_digits ad - n) ad) = d. + n <= nb_digits (abs d) -> + app_int (del_tail_int n d) (del_head (nb_digits (abs d) - n) (abs d)) = d. Proof. now case d; clear d; simpl; intros u Hu; rewrite app_del_tail_head. Qed. +Lemma del_head_app_int_exact i f : + nb_digits f < nb_digits (unorm (app (abs i) f)) -> + del_head (nb_digits (unorm (app (abs i) f)) - nb_digits f) (unorm (app (abs i) f)) = f. +Proof. + simpl; intro Hnb; generalize Hnb; rewrite (unorm_app_l _ _ Hnb); clear Hnb. + replace (_ - _) with (nb_digits (unorm (abs i))). + - now rewrite del_head_app; [rewrite del_head_nb_digits|]. + - rewrite !nb_digits_spec, app_spec, List.app_length. + now rewrite Nat.add_comm, minus_plus. +Qed. + +Lemma del_tail_app_int_exact i f : + nb_digits f < nb_digits (unorm (app (abs i) f)) -> + del_tail_int (nb_digits f) (norm (app_int i f)) = norm i. +Proof. + simpl; intro Hnb. + rewrite (norm_app_int _ _ Hnb). + rewrite del_tail_app_int; [|now simpl]. + now rewrite del_tail_nb_digits, app_int_nil_r. +Qed. + (** Normalization on little-endian numbers *) Fixpoint nztail d := @@ -224,10 +474,13 @@ Proof. apply nzhead_revapp. Qed. +Lemma rev_rev d : rev (rev d) = d. +Proof. now apply to_list_inj; rewrite !rev_spec, List.rev_involutive. Qed. + Lemma rev_nztail_rev d : rev (nztail (rev d)) = nzhead d. Proof. - destruct (uint_dec (nztail (rev d)) Nil) as [H|H]. + destruct (uint_eq_dec (nztail (rev d)) Nil) as [H|H]. - rewrite H. unfold rev; simpl. rewrite <- (rev_rev d). symmetry. now apply nzhead_revapp_0. @@ -278,21 +531,9 @@ Proof. unfold unorm. now destruct nzhead. Qed. -Lemma unorm_D0 u : unorm (D0 u) = unorm u. -Proof. reflexivity. Qed. - Lemma unorm_iter_D0 n u : unorm (Nat.iter n D0 u) = unorm u. Proof. now induction n. Qed. -Lemma nb_digits_unorm u : - u <> Nil -> nb_digits (unorm u) <= nb_digits u. -Proof. - case u; clear u; [now simpl|intro u..]; [|now simpl..]. - intros _; unfold unorm. - case_eq (nzhead (D0 u)); [|now intros u' <-; apply nb_digits_nzhead..]. - intros _; apply le_n_S, Nat.le_0_l. -Qed. - Lemma del_head_nonnil n u : n < nb_digits u -> del_head n u <> Nil. Proof. @@ -311,73 +552,78 @@ Proof. now apply del_head_nonnil. Qed. -Lemma nzhead_invol d : nzhead (nzhead d) = nzhead d. +Lemma nzhead_involutive d : nzhead (nzhead d) = nzhead d. Proof. now induction d. Qed. +#[deprecated(since="8.13",note="Use nzhead_involutive instead.")] +Notation nzhead_invol := nzhead_involutive (only parsing). -Lemma nztail_invol d : nztail (nztail d) = nztail d. +Lemma nztail_involutive d : nztail (nztail d) = nztail d. Proof. rewrite <-(rev_rev (nztail _)), <-(rev_rev (nztail d)), <-(rev_rev d). - now rewrite !rev_nztail_rev, nzhead_invol. + now rewrite !rev_nztail_rev, nzhead_involutive. Qed. +#[deprecated(since="8.13",note="Use nztail_involutive instead.")] +Notation nztail_invol := nztail_involutive (only parsing). -Lemma unorm_invol d : unorm (unorm d) = unorm d. +Lemma unorm_involutive d : unorm (unorm d) = unorm d. Proof. unfold unorm. destruct (nzhead d) eqn:E; trivial. destruct (nzhead_nonzero _ _ E). Qed. +#[deprecated(since="8.13",note="Use unorm_involutive instead.")] +Notation unorm_invol := unorm_involutive (only parsing). -Lemma norm_invol d : norm (norm d) = norm d. +Lemma norm_involutive d : norm (norm d) = norm d. Proof. unfold norm. destruct d. - - f_equal. apply unorm_invol. + - f_equal. apply unorm_involutive. - destruct (nzhead d) eqn:E; auto. destruct (nzhead_nonzero _ _ E). Qed. +#[deprecated(since="8.13",note="Use norm_involutive instead.")] +Notation norm_invol := norm_involutive (only parsing). + +Lemma lnzhead_neq_d0_head l l' : ~(lnzhead l = cons d0 l'). +Proof. now induction l as [|h t Il]; [|case h]. Qed. + +Lemma lnzhead_head_nd0 h t : h <> d0 -> lnzhead (cons h t) = cons h t. +Proof. now case h. Qed. Lemma nzhead_del_tail_nzhead_eq n u : nzhead u = u -> n < nb_digits u -> nzhead (del_tail n u) = del_tail n u. Proof. + rewrite nb_digits_spec, <-List.rev_length. intros Hu Hn. - assert (Hhd : forall u, - nzhead u = u <-> match nth 0 u with D0 _ => False | _ => True end). - { clear n u Hu Hn; intro u. - case u; clear u; [|intro u..]; [now simpl| |now simpl..]; simpl. - split; [|now simpl]. - apply nzhead_nonzero. } - assert (Hhd' : nth 0 (del_tail n u) = nth 0 u). - { rewrite <-(app_del_tail_head _ _ (le_Sn_le _ _ Hn)) at 2. - unfold app. - rewrite nth_revapp_l. - - rewrite <-(nth_revapp_l _ _ Nil). - + now fold (rev (rev (del_tail n u))); rewrite rev_rev. - + unfold del_tail; rewrite rev_rev. - rewrite nb_digits_del_head; rewrite nb_digits_rev. - * now rewrite <-Nat.lt_add_lt_sub_r. - * now apply Nat.lt_le_incl. - - unfold del_tail; rewrite rev_rev. - rewrite nb_digits_del_head; rewrite nb_digits_rev. - + now rewrite <-Nat.lt_add_lt_sub_r. - + now apply Nat.lt_le_incl. } - revert Hu; rewrite Hhd; intro Hu. - now rewrite Hhd, Hhd'. + apply to_list_inj; unfold del_tail. + rewrite nzhead_spec, rev_spec. + rewrite del_head_spec_small; [|now rewrite rev_spec; apply Nat.lt_le_incl]. + rewrite rev_spec. + rewrite List.skipn_rev, List.rev_involutive. + generalize (f_equal to_list Hu) Hn; rewrite nzhead_spec; intro Hu'. + case (to_list u) as [|h t]. + { simpl; intro H; exfalso; revert H; apply le_not_lt, Peano.le_0_n. } + intro Hn'; generalize (Nat.sub_gt _ _ Hn'); rewrite List.rev_length. + case (_ - _); [now simpl|]; intros n' _. + rewrite List.firstn_cons, lnzhead_head_nd0; [now simpl|]. + intro Hh; revert Hu'; rewrite Hh; apply lnzhead_neq_d0_head. Qed. Lemma nzhead_del_tail_nzhead n u : n < nb_digits (nzhead u) -> nzhead (del_tail n (nzhead u)) = del_tail n (nzhead u). -Proof. apply nzhead_del_tail_nzhead_eq, nzhead_invol. Qed. +Proof. apply nzhead_del_tail_nzhead_eq, nzhead_involutive. Qed. Lemma unorm_del_tail_unorm n u : n < nb_digits (unorm u) -> unorm (del_tail n (unorm u)) = del_tail n (unorm u). Proof. - case (uint_dec (nzhead u) Nil). + case (uint_eq_dec (nzhead u) Nil). - unfold unorm; intros->; case n; [now simpl|]; intro n'. now simpl; intro H; exfalso; generalize (lt_S_n _ _ H). - unfold unorm. @@ -396,7 +642,7 @@ Lemma norm_del_tail_int_norm n d : Proof. case d; clear d; intros u; simpl. - now intro H; simpl; rewrite unorm_del_tail_unorm. - - case (uint_dec (nzhead u) Nil); intro Hu. + - case (uint_eq_dec (nzhead u) Nil); intro Hu. + now rewrite Hu; case n; [|intros n' Hn'; generalize (lt_S_n _ _ Hn')]. + set (m := match nzhead u with Nil => Pos zero | _ => _ end). replace m with (Neg (nzhead u)); [|now unfold m; revert Hu; case nzhead]. @@ -418,7 +664,7 @@ Proof. generalize (nzhead_revapp d d'). generalize (nzhead_revapp_0 (nztail d) d'). generalize (nzhead_revapp (nztail d) d'). - rewrite nztail_invol. + rewrite nztail_involutive. now case nztail; [intros _ H _ H'; rewrite (H eq_refl), (H' eq_refl) |intros d'' H _ H' _; rewrite H; [rewrite H'|]..]. @@ -455,5 +701,10 @@ Proof. |rewrite H'; unfold r; clear m r H']; unfold norm; rewrite rev_rev, <-Hd''; - rewrite nzhead_revapp; rewrite nztail_invol; [|rewrite Hd'']..]. + rewrite nzhead_revapp; rewrite nztail_involutive; [|rewrite Hd'']..]. +Qed. + +Lemma unorm_app_l_nil d d' : nzhead d = Nil -> unorm (app d d') = unorm d'. +Proof. + now unfold unorm; rewrite <-nzhead_app_nzhead; intros->; rewrite app_nil_l. Qed. diff --git a/theories/Numbers/DecimalN.v b/theories/Numbers/DecimalN.v index 8bc5c38fb5..a5dd97f24b 100644 --- a/theories/Numbers/DecimalN.v +++ b/theories/Numbers/DecimalN.v @@ -74,7 +74,7 @@ Proof. destruct (norm d) eqn:Hd; intros [= <-]. unfold N.to_int. rewrite Unsigned.to_of. f_equal. revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_invol. + - intros [= <-]. apply unorm_involutive. - destruct (nzhead d); now intros [= <-]. Qed. @@ -93,7 +93,7 @@ Qed. Lemma of_int_norm d : N.of_int (norm d) = N.of_int d. Proof. - unfold N.of_int. now rewrite norm_invol. + unfold N.of_int. now rewrite norm_involutive. Qed. Lemma of_inj_pos d d' : diff --git a/theories/Numbers/DecimalNat.v b/theories/Numbers/DecimalNat.v index 1962ac5d9d..4fee40caa2 100644 --- a/theories/Numbers/DecimalNat.v +++ b/theories/Numbers/DecimalNat.v @@ -270,7 +270,7 @@ Proof. destruct (norm d) eqn:Hd; intros [= <-]. unfold Nat.to_int. rewrite Unsigned.to_of. f_equal. revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_invol. + - intros [= <-]. apply unorm_involutive. - destruct (nzhead d); now intros [= <-]. Qed. @@ -289,7 +289,7 @@ Qed. Lemma of_int_norm d : Nat.of_int (norm d) = Nat.of_int d. Proof. - unfold Nat.of_int. now rewrite norm_invol. + unfold Nat.of_int. now rewrite norm_involutive. Qed. Lemma of_inj_pos d d' : diff --git a/theories/Numbers/DecimalQ.v b/theories/Numbers/DecimalQ.v index d9642d7b02..2027813eec 100644 --- a/theories/Numbers/DecimalQ.v +++ b/theories/Numbers/DecimalQ.v @@ -15,8 +15,112 @@ Require Import Decimal DecimalFacts DecimalPos DecimalN DecimalZ QArith. +Lemma of_IQmake_to_decimal num den : + match IQmake_to_decimal num den with + | None => True + | Some (DecimalExp _ _ _) => False + | Some (Decimal i f) => of_decimal (Decimal i f) = IQmake (IZ_of_Z num) den + end. +Proof. + unfold IQmake_to_decimal. + generalize (Unsigned.nztail_to_uint den). + case Decimal.nztail; intros den' e_den'. + case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. + case den'; [ |now simpl..]; clear den'. + case e_den' as [|e_den']; simpl; intro H; injection H; clear H; intros->. + { now unfold of_decimal; simpl; rewrite app_int_nil_r, DecimalZ.of_to. } + replace (10 ^ _)%positive with (Nat.iter (S e_den') (Pos.mul 10) 1%positive). + 2:{ induction e_den' as [|n IHn]; [now simpl| ]. + now rewrite SuccNat2Pos.inj_succ, Pos.pow_succ_r, <-IHn. } + case Nat.ltb_spec; intro He_den'. + - unfold of_decimal; simpl. + rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. + rewrite DecimalZ.of_to. + now rewrite nb_digits_del_head_sub; [|now apply Nat.lt_le_incl]. + - unfold of_decimal; simpl. + rewrite nb_digits_iter_D0. + apply f_equal2. + + apply f_equal, DecimalZ.to_int_inj. + rewrite DecimalZ.to_of. + rewrite <-(DecimalZ.of_to num), DecimalZ.to_of. + case (Z.to_int num); clear He_den' num; intro num; simpl. + * unfold app; simpl. + now rewrite unorm_D0, unorm_iter_D0, unorm_involutive. + * case (uint_eq_dec (nzhead num) Nil); [|intro Hn]. + { intros->; simpl; unfold app; simpl. + now rewrite unorm_D0, unorm_iter_D0. } + replace (match nzhead num with Nil => _ | _ => _ end) + with (Neg (nzhead num)); [|now revert Hn; case nzhead]. + simpl. + rewrite nzhead_iter_D0, nzhead_involutive. + now revert Hn; case nzhead. + + revert He_den'; case nb_digits as [|n]; [now simpl; rewrite Nat.add_0_r|]. + intro Hn. + rewrite Nat.add_succ_r, Nat.add_comm. + now rewrite <-le_plus_minus; [|apply le_S_n]. +Qed. + +Lemma IZ_of_Z_IZ_to_Z z z' : IZ_to_Z z = Some z' -> IZ_of_Z z' = z. +Proof. now case z as [| |p|p]; [|intro H; injection H; intros<-..]. Qed. + +Lemma of_IQmake_to_decimal' num den : + match IQmake_to_decimal' num den with + | None => True + | Some (DecimalExp _ _ _) => False + | Some (Decimal i f) => of_decimal (Decimal i f) = IQmake num den + end. +Proof. + unfold IQmake_to_decimal'. + case_eq (IZ_to_Z num); [intros num' Hnum'|now simpl]. + generalize (of_IQmake_to_decimal num' den). + case IQmake_to_decimal as [d|]; [|now simpl]. + case d as [i f|]; [|now simpl]. + now rewrite (IZ_of_Z_IZ_to_Z _ _ Hnum'). +Qed. + Lemma of_to (q:IQ) : forall d, to_decimal q = Some d -> of_decimal d = q. -Admitted. +Proof. + intro d. + case q as [num den|q q'|q q']; simpl. + - generalize (of_IQmake_to_decimal' num den). + case IQmake_to_decimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + now intros H H'; injection H'; clear H'; intros <-. + - case q as [num den| |]; [|now simpl..]. + case q' as [num' den'| |]; [|now simpl..]. + case num' as [z p| | |]; [|now simpl..]. + case (Z.eq_dec z 10); [intros->|]. + 2:{ case z; [now simpl| |now simpl]; intro pz'. + case pz'; [intros d0..| ]; [now simpl| |now simpl]. + case d0; [intros d1..| ]; [ |now simpl..]. + case d1; [intros d2..| ]; [now simpl| |now simpl]. + now case d2. } + case (Pos.eq_dec den' 1%positive); [intros->|now case den']. + generalize (of_IQmake_to_decimal' num den). + case IQmake_to_decimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros <-; clear num den. + intros H; injection H; clear H; intros<-. + unfold of_decimal; simpl. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + - case q as [num den| |]; [|now simpl..]. + case q' as [num' den'| |]; [|now simpl..]. + case num' as [z p| | |]; [|now simpl..]. + case (Z.eq_dec z 10); [intros->|]. + 2:{ case z; [now simpl| |now simpl]; intro pz'. + case pz'; [intros d0..| ]; [now simpl| |now simpl]. + case d0; [intros d1..| ]; [ |now simpl..]. + case d1; [intros d2..| ]; [now simpl| |now simpl]. + now case d2. } + case (Pos.eq_dec den' 1%positive); [intros->|now case den']. + generalize (of_IQmake_to_decimal' num den). + case IQmake_to_decimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros <-; clear num den. + intros H; injection H; clear H; intros<-. + unfold of_decimal; simpl. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. +Qed. Definition dnorm (d:decimal) : decimal := let norm_i i f := @@ -43,13 +147,50 @@ Lemma dnorm_spec_i d : (i' = Neg (unorm i) /\ (nzhead i <> Nil \/ nzhead f <> Nil)) \/ (i' = Pos zero /\ (nzhead i = Nil /\ nzhead f = Nil)) end. -Admitted. +Proof. + case d as [i f|i f e]; case i as [i|i]. + - now simpl. + - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. + + rewrite Ha; right; split; [now simpl|split]. + * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). + * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). + + left; split; [now revert Ha; case nzhead|]. + case (uint_eq_dec (nzhead i) Nil). + * intro Hi; right; intro Hf; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now intro H; left. + - simpl; case (norm e); clear e; intro e; [|now simpl]. + now case e; clear e; [|intro e..]; [|case e|..]. + - simpl. + set (m := match nzhead _ with Nil => _ | _ => _ end). + set (m' := match _ with Decimal _ _ => _ | _ => _ end). + replace m' with m. + 2:{ unfold m'; case (norm e); clear m' e; intro e; [|now simpl]. + now case e; clear e; [|intro e..]; [|case e|..]. } + unfold m; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. + + rewrite Ha; right; split; [now simpl|split]. + * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). + * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). + + left; split; [now revert Ha; case nzhead|]. + case (uint_eq_dec (nzhead i) Nil). + * intro Hi; right; intro Hf; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now intro H; left. +Qed. Lemma dnorm_spec_f d : let f := match d with Decimal _ f => f | DecimalExp _ f _ => f end in let f' := match dnorm d with Decimal _ f => f | DecimalExp _ f _ => f end in f' = f. -Admitted. +Proof. + case d as [i f|i f e]; [now simpl|]. + simpl; case (int_eq_dec (norm e) (Pos zero)); [now intros->|intro He]. + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match norm e with Pos Nil => _ | _ => _ end). + replace m with (DecimalExp i' f (norm e)); [now simpl|]. + unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. +Qed. Lemma dnorm_spec_e d : match d, dnorm d with @@ -58,24 +199,241 @@ Lemma dnorm_spec_e d : | DecimalExp _ _ e, DecimalExp _ _ e' => e' = norm e /\ e' <> Pos zero | Decimal _ _, DecimalExp _ _ _ => False end. -Admitted. +Proof. + case d as [i f|i f e]; [now simpl|]. + simpl; case (int_eq_dec (norm e) (Pos zero)); [now intros->|intro He]. + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match norm e with Pos Nil => _ | _ => _ end). + replace m with (DecimalExp i' f (norm e)); [now simpl|]. + unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. +Qed. -Lemma dnorm_invol d : dnorm (dnorm d) = dnorm d. -Admitted. +Lemma dnorm_involutive d : dnorm (dnorm d) = dnorm d. +Proof. + case d as [i f|i f e]; case i as [i|i]. + - now simpl; rewrite unorm_involutive. + - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + set (m := match nzhead _ with Nil =>_ | _ => _ end). + replace m with (Neg (unorm i)). + 2:{ now unfold m; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + + unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + * intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now case nzhead. + + rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. + - simpl; case (int_eq_dec (norm e) (Pos zero)); intro He. + + now rewrite He; simpl; rewrite unorm_involutive. + + set (m := match norm e with Pos Nil => _ | _ => _ end). + replace m with (DecimalExp (Pos (unorm i)) f (norm e)). + 2:{ unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + simpl; rewrite norm_involutive, unorm_involutive. + revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. + - simpl; case (int_eq_dec (norm e) (Pos zero)); intro He. + + rewrite He; simpl. + case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + set (m := match nzhead _ with Nil =>_ | _ => _ end). + replace m with (Neg (unorm i)). + 2:{ now unfold m; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + * unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + -- intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + -- now case nzhead. + * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. + + set (m := match norm e with Pos Nil => _ | _ => _ end). + pose (i' := match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end). + replace m with (DecimalExp i' f (norm e)). + 2:{ unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + simpl; rewrite norm_involutive. + set (i'' := match i' with Pos _ => _ | _ => _ end). + clear m; set (m := match norm e with Pos Nil => _ | _ => _ end). + replace m with (DecimalExp i'' f (norm e)). + 2:{ unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + unfold i'', i'. + case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + fold i'; replace i' with (Neg (unorm i)). + 2:{ now unfold i'; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + * unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + -- intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + -- now case nzhead. + * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. +Qed. + +Lemma IZ_to_Z_IZ_of_Z z : IZ_to_Z (IZ_of_Z z) = Some z. +Proof. now case z. Qed. + +Lemma dnorm_i_exact i f : + (nb_digits f < nb_digits (unorm (app (abs i) f)))%nat -> + match i with + | Pos i => Pos (unorm i) + | Neg i => + match nzhead (app i f) with + | Nil => Pos zero + | _ => Neg (unorm i) + end + end = norm i. +Proof. + case i as [ni|ni]; [now simpl|]; simpl. + case (uint_eq_dec (nzhead (app ni f)) Nil); intro Ha. + { now rewrite Ha, (nzhead_app_nil_l _ _ Ha). } + rewrite (unorm_nzhead _ Ha). + set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (unorm ni)); [|now unfold m; revert Ha; case nzhead]. + case (uint_eq_dec (nzhead ni) Nil); intro Hni. + { rewrite <-nzhead_app_nzhead, Hni, app_nil_l. + intro H; exfalso; revert H; apply le_not_lt, nb_digits_nzhead. } + clear m; set (m := match nzhead ni with Nil => _ | _ => _ end). + replace m with (Neg (nzhead ni)); [|now unfold m; revert Hni; case nzhead]. + now rewrite (unorm_nzhead _ Hni). +Qed. + +Lemma dnorm_i_exact' i f : + (nb_digits (unorm (app (abs i) f)) <= nb_digits f)%nat -> + match i with + | Pos i => Pos (unorm i) + | Neg i => + match nzhead (app i f) with + | Nil => Pos zero + | _ => Neg (unorm i) + end + end = + match norm (app_int i f) with + | Pos _ => Pos zero + | Neg _ => Neg zero + end. +Proof. + case i as [ni|ni]; simpl. + { now intro Hnb; rewrite (unorm_app_zero _ _ Hnb). } + unfold unorm. + case (uint_eq_dec (nzhead (app ni f)) Nil); intro Hn. + { now rewrite Hn. } + set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (nzhead (app ni f)). + 2:{ now unfold m; revert Hn; case nzhead. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (unorm ni)). + 2:{ now unfold m, unorm; revert Hn; case nzhead. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (nzhead (app ni f))). + 2:{ now unfold m; revert Hn; case nzhead. } + rewrite <-(unorm_nzhead _ Hn). + now intro H; rewrite (unorm_app_zero _ _ H). +Qed. Lemma to_of (d:decimal) : to_decimal (of_decimal d) = Some (dnorm d). -Admitted. +Proof. + case d as [i f|i f e]. + - unfold of_decimal; simpl; unfold IQmake_to_decimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_decimal; simpl. + change (fun _ : positive => _) with (Pos.mul 10). + rewrite nztail_to_uint_pow10, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + + rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + + rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + * rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + * rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + - unfold of_decimal; simpl. + rewrite <-to_of. + case (Z.of_int e); clear e; [|intro e..]; simpl. + + unfold IQmake_to_decimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_decimal; simpl. + change (fun _ : positive => _) with (Pos.mul 10). + rewrite nztail_to_uint_pow10, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + + unfold IQmake_to_decimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_decimal; simpl. + change (fun _ : positive => _) with (Pos.mul 10). + rewrite nztail_to_uint_pow10, to_of. + generalize (Unsigned.to_uint_nonzero e); intro He. + set (dnorm_i := match i with Pos _ => _ | _ => _ end). + set (m := match Pos.to_uint e with Nil => _ | _ => _ end). + replace m with (DecimalExp dnorm_i f (Pos (Pos.to_uint e))). + 2:{ now unfold m; revert He; case (Pos.to_uint e); [|intro u; case u|..]. } + clear m; unfold dnorm_i. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + + unfold IQmake_to_decimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_decimal; simpl. + change (fun _ : positive => _) with (Pos.mul 10). + rewrite nztail_to_uint_pow10, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. +Qed. (** Some consequences *) Lemma to_decimal_inj q q' : to_decimal q <> None -> to_decimal q = to_decimal q' -> q = q'. Proof. -intros Hnone EQ. -generalize (of_to q) (of_to q'). -rewrite <-EQ. -revert Hnone; case to_decimal; [|now simpl]. -now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). + intros Hnone EQ. + generalize (of_to q) (of_to q'). + rewrite <-EQ. + revert Hnone; case to_decimal; [|now simpl]. + now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). Qed. Lemma to_decimal_surj d : exists q, to_decimal q = Some (dnorm d). @@ -84,18 +442,18 @@ Proof. Qed. Lemma of_decimal_dnorm d : of_decimal (dnorm d) = of_decimal d. -Proof. now apply to_decimal_inj; rewrite !to_of; [|rewrite dnorm_invol]. Qed. +Proof. now apply to_decimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. Lemma of_inj d d' : of_decimal d = of_decimal d' -> dnorm d = dnorm d'. Proof. -intro H. -apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) - (Some (dnorm d)) (Some (dnorm d'))). -now rewrite <- !to_of, H. + intro H. + apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). + now rewrite <- !to_of, H. Qed. Lemma of_iff d d' : of_decimal d = of_decimal d' <-> dnorm d = dnorm d'. Proof. -split. apply of_inj. intros E. rewrite <- of_decimal_dnorm, E. -apply of_decimal_dnorm. + split. apply of_inj. intros E. rewrite <- of_decimal_dnorm, E. + apply of_decimal_dnorm. Qed. diff --git a/theories/Numbers/DecimalZ.v b/theories/Numbers/DecimalZ.v index 69d8073fc7..faaf8a3932 100644 --- a/theories/Numbers/DecimalZ.v +++ b/theories/Numbers/DecimalZ.v @@ -79,9 +79,11 @@ Qed. Lemma of_uint_iter_D0 d n : Z.of_uint (app d (Nat.iter n D0 Nil)) = Nat.iter n (Z.mul 10) (Z.of_uint d). Proof. - unfold Z.of_uint. - unfold app; rewrite <-rev_revapp. - rewrite Unsigned.of_lu_rev, Unsigned.of_lu_revapp. + rewrite <-(rev_rev (app _ _)), <-(of_list_to_list (rev (app _ _))). + rewrite rev_spec, app_spec, List.rev_app_distr. + rewrite <-!rev_spec, <-app_spec, of_list_to_list. + unfold Z.of_uint; rewrite Unsigned.of_lu_rev. + unfold app; rewrite Unsigned.of_lu_revapp, !rev_rev. rewrite <-!Unsigned.of_lu_rev, !rev_rev. assert (H' : Pos.of_uint (Nat.iter n D0 Nil) = 0%N). { now induction n; [|rewrite Unsigned.nat_iter_S]. } @@ -100,3 +102,22 @@ Proof. - rewrite of_uint_iter_D0; induction n; [now simpl|]. rewrite !Unsigned.nat_iter_S, <-IHn; ring. Qed. + +Lemma nztail_to_uint_pow10 n : + Decimal.nztail (Pos.to_uint (Nat.iter n (Pos.mul 10) 1%positive)) + = (D1 Nil, n). +Proof. + case n as [|n]; [now simpl|]. + rewrite <-(Nat2Pos.id (S n)); [|now simpl]. + generalize (Pos.of_nat (S n)); clear n; intro p. + induction (Pos.to_nat p); [now simpl|]. + rewrite Unsigned.nat_iter_S. + unfold Pos.to_uint. + change (Pos.to_little_uint _) + with (Unsigned.to_lu (10 * N.pos (Nat.iter n (Pos.mul 10) 1%positive))). + rewrite Unsigned.to_ldec_tenfold. + revert IHn; unfold Pos.to_uint. + unfold Decimal.nztail; rewrite !rev_rev; simpl. + set (f'' := _ (Pos.to_little_uint _)). + now case f''; intros r n' H; inversion H. +Qed. diff --git a/theories/Numbers/HexadecimalFacts.v b/theories/Numbers/HexadecimalFacts.v index 7328b2303d..c624b4e6b9 100644 --- a/theories/Numbers/HexadecimalFacts.v +++ b/theories/Numbers/HexadecimalFacts.v @@ -10,136 +10,437 @@ (** * HexadecimalFacts : some facts about Hexadecimal numbers *) -Require Import Hexadecimal Arith. +Require Import Hexadecimal Arith ZArith. + +Variant digits := + | d0 | d1 | d2 | d3 | d4 | d5 | d6 | d7 | d8 | d9 + | da | db | dc | dd | de | df. + +Fixpoint to_list (u : uint) : list digits := + match u with + | Nil => nil + | D0 u => cons d0 (to_list u) + | D1 u => cons d1 (to_list u) + | D2 u => cons d2 (to_list u) + | D3 u => cons d3 (to_list u) + | D4 u => cons d4 (to_list u) + | D5 u => cons d5 (to_list u) + | D6 u => cons d6 (to_list u) + | D7 u => cons d7 (to_list u) + | D8 u => cons d8 (to_list u) + | D9 u => cons d9 (to_list u) + | Da u => cons da (to_list u) + | Db u => cons db (to_list u) + | Dc u => cons dc (to_list u) + | Dd u => cons dd (to_list u) + | De u => cons de (to_list u) + | Df u => cons df (to_list u) + end. + +Fixpoint of_list (l : list digits) : uint := + match l with + | nil => Nil + | cons d0 l => D0 (of_list l) + | cons d1 l => D1 (of_list l) + | cons d2 l => D2 (of_list l) + | cons d3 l => D3 (of_list l) + | cons d4 l => D4 (of_list l) + | cons d5 l => D5 (of_list l) + | cons d6 l => D6 (of_list l) + | cons d7 l => D7 (of_list l) + | cons d8 l => D8 (of_list l) + | cons d9 l => D9 (of_list l) + | cons da l => Da (of_list l) + | cons db l => Db (of_list l) + | cons dc l => Dc (of_list l) + | cons dd l => Dd (of_list l) + | cons de l => De (of_list l) + | cons df l => Df (of_list l) + end. -Scheme Equality for uint. +Lemma of_list_to_list u : of_list (to_list u) = u. +Proof. now induction u; [|simpl; rewrite IHu..]. Qed. -Scheme Equality for int. +Lemma to_list_of_list l : to_list (of_list l) = l. +Proof. now induction l as [|h t IHl]; [|case h; simpl; rewrite IHl]. Qed. -Lemma rev_revapp d d' : - rev (revapp d d') = revapp d' d. +Lemma to_list_inj u u' : to_list u = to_list u' -> u = u'. Proof. - revert d'. induction d; simpl; intros; now rewrite ?IHd. + now intro H; rewrite <-(of_list_to_list u), <-(of_list_to_list u'), H. Qed. -Lemma rev_rev d : rev (rev d) = d. +Lemma of_list_inj u u' : of_list u = of_list u' -> u = u'. Proof. - apply rev_revapp. + now intro H; rewrite <-(to_list_of_list u), <-(to_list_of_list u'), H. Qed. -Lemma revapp_rev_nil d : revapp (rev d) Nil = d. -Proof. now fold (rev (rev d)); rewrite rev_rev. Qed. +Lemma nb_digits_spec u : nb_digits u = length (to_list u). +Proof. now induction u; [|simpl; rewrite IHu..]. Qed. -Lemma app_nil_r d : app d Nil = d. -Proof. now unfold app; rewrite revapp_rev_nil. Qed. +Fixpoint lnzhead l := + match l with + | nil => nil + | cons d l' => + match d with + | d0 => lnzhead l' + | _ => l + end + end. -Lemma app_int_nil_r d : app_int d Nil = d. -Proof. now case d; intro d'; simpl; rewrite app_nil_r. Qed. +Lemma nzhead_spec u : to_list (nzhead u) = lnzhead (to_list u). +Proof. now induction u; [|simpl; rewrite IHu|..]. Qed. + +Definition lzero := cons d0 nil. + +Definition lunorm l := + match lnzhead l with + | nil => lzero + | d => d + end. + +Lemma unorm_spec u : to_list (unorm u) = lunorm (to_list u). +Proof. now unfold unorm, lunorm; rewrite <-nzhead_spec; case (nzhead u). Qed. + +Lemma revapp_spec d d' : + to_list (revapp d d') = List.rev_append (to_list d) (to_list d'). +Proof. now revert d'; induction d; intro d'; [|simpl; rewrite IHd..]. Qed. + +Lemma rev_spec d : to_list (rev d) = List.rev (to_list d). +Proof. now unfold rev; rewrite revapp_spec, List.rev_alt; simpl. Qed. + +Lemma app_spec d d' : + to_list (app d d') = Datatypes.app (to_list d) (to_list d'). +Proof. + unfold app. + now rewrite revapp_spec, List.rev_append_rev, rev_spec, List.rev_involutive. +Qed. -Lemma revapp_revapp_1 d d' d'' : - nb_digits d <= 1 -> - revapp (revapp d d') d'' = revapp d' (revapp d d''). +Definition lnztail l := + let fix aux l_rev := + match l_rev with + | cons d0 l_rev => let (r, n) := aux l_rev in pair r (S n) + | _ => pair l_rev O + end in + let (r, n) := aux (List.rev l) in pair (List.rev r) n. + +Lemma nztail_spec d : + let (r, n) := nztail d in + let (r', n') := lnztail (to_list d) in + to_list r = r' /\ n = n'. Proof. - now case d; clear d; intro d; - [|case d; clear d; intro d; - [|simpl; case nb_digits; [|intros n]; intros Hn; exfalso; - [apply (Nat.nle_succ_diag_l _ Hn)| - apply (Nat.nle_succ_0 _ (le_S_n _ _ Hn))]..]..]. + unfold nztail, lnztail. + set (f := fix aux d_rev := match d_rev with + | D0 d_rev => let (r, n) := aux d_rev in (r, S n) + | _ => (d_rev, 0) end). + set (f' := fix aux (l_rev : list digits) : list digits * nat := + match l_rev with + | cons d0 l_rev => let (r, n) := aux l_rev in (r, S n) + | _ => (l_rev, 0) + end). + rewrite <-(of_list_to_list (rev d)), rev_spec. + induction (List.rev _) as [|h t IHl]; [now simpl|]. + case h; simpl; [|now rewrite rev_spec; simpl; rewrite to_list_of_list..]. + now revert IHl; case f; intros r n; case f'; intros r' n' [-> ->]. Qed. -Lemma nb_digits_pos d : d <> Nil -> 0 < nb_digits d. -Proof. now case d; [|intros d' _; apply Nat.lt_0_succ..]. Qed. +Lemma del_head_spec_0 d : del_head 0 d = d. +Proof. now simpl. Qed. -Lemma nb_digits_revapp d d' : - nb_digits (revapp d d') = nb_digits d + nb_digits d'. +Lemma del_head_spec_small n d : + n <= length (to_list d) -> to_list (del_head n d) = List.skipn n (to_list d). Proof. - now revert d'; induction d; [|intro d'; simpl; rewrite IHd; simpl..]. + revert d; induction n as [|n IHn]; intro d; [now simpl|]. + now case d; [|intros d' H; apply IHn, le_S_n..]. Qed. -Lemma nb_digits_rev u : nb_digits (rev u) = nb_digits u. -Proof. now unfold rev; rewrite nb_digits_revapp. Qed. +Lemma del_head_spec_large n d : length (to_list d) < n -> del_head n d = zero. +Proof. + revert d; induction n; intro d; [now case d|]. + now case d; [|intro d'; simpl; intro H; rewrite (IHn _ (lt_S_n _ _ H))..]. +Qed. -Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. -Proof. now induction u; [|apply le_S|..]. Qed. +Lemma nb_digits_0 d : nb_digits d = 0 -> d = Nil. +Proof. + rewrite nb_digits_spec, <-(of_list_to_list d). + now case (to_list d) as [|h t]; [|rewrite to_list_of_list]. +Qed. + +Lemma nb_digits_n0 d : nb_digits d <> 0 -> d <> Nil. +Proof. now case d; [|intros u _..]. Qed. Lemma nb_digits_iter_D0 n d : nb_digits (Nat.iter n D0 d) = n + nb_digits d. Proof. now induction n; simpl; [|rewrite IHn]. Qed. -Fixpoint nth n u := - match n with - | O => - match u with - | Nil => Nil - | D0 d => D0 Nil - | D1 d => D1 Nil - | D2 d => D2 Nil - | D3 d => D3 Nil - | D4 d => D4 Nil - | D5 d => D5 Nil - | D6 d => D6 Nil - | D7 d => D7 Nil - | D8 d => D8 Nil - | D9 d => D9 Nil - | Da d => Da Nil - | Db d => Db Nil - | Dc d => Dc Nil - | Dd d => Dd Nil - | De d => De Nil - | Df d => Df Nil - end - | S n => - match u with - | Nil => Nil - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d - | Da d | Db d | Dc d | Dd d | De d | Df d => - nth n d - end - end. +Lemma length_lnzhead l : length (lnzhead l) <= length l. +Proof. now induction l as [|h t IHl]; [|case h; [apply le_S|..]]. Qed. + +Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. +Proof. now induction u; [|apply le_S|..]. Qed. -Lemma nb_digits_nth n u : nb_digits (nth n u) <= 1. -Proof. - revert u; induction n. - - now intro u; case u; [apply Nat.le_0_1|..]. - - intro u; case u; [apply Nat.le_0_1|intro u'; apply IHn..]. -Qed. - -Lemma nth_revapp_r n d d' : - nb_digits d <= n -> - nth n (revapp d d') = nth (n - nb_digits d) d'. -Proof. - revert d d'; induction n; intro d. - - now case d; intro d'; - [case d'|intros d'' H; exfalso; revert H; apply Nat.nle_succ_0..]. - - now induction d; - [intro d'; case d'| - intros d' H; - simpl revapp; rewrite IHd; [|now apply le_Sn_le]; - rewrite Nat.sub_succ_l; [|now apply le_S_n]; - simpl; rewrite <-(IHn _ _ (le_S_n _ _ H))..]. -Qed. - -Lemma nth_revapp_l n d d' : - n < nb_digits d -> - nth n (revapp d d') = nth (nb_digits d - n - 1) d. -Proof. - revert d d'; induction n; intro d. - - rewrite Nat.sub_0_r. - now induction d; - [|intros d' _; simpl revapp; - revert IHd; case d; clear d; [|intro d..]; intro IHd; - [|rewrite IHd; [simpl nb_digits; rewrite (Nat.sub_succ_l _ (S _))|]; - [|apply le_n_S, Nat.le_0_l..]..]..]. - - now induction d; - [|intros d' H; - simpl revapp; simpl nb_digits; - simpl in H; generalize (lt_S_n _ _ H); clear H; intro H; - case (le_lt_eq_dec _ _ H); clear H; intro H; - [rewrite (IHd _ H), Nat.sub_succ_l; - [rewrite Nat.sub_succ_l; [|apply Nat.le_add_le_sub_r]| - apply le_Sn_le]| - rewrite nth_revapp_r; rewrite <-H; - [rewrite Nat.sub_succ, Nat.sub_succ_l; [rewrite !Nat.sub_diag|]|]]..]. +Lemma unorm_nzhead u : nzhead u <> Nil -> unorm u = nzhead u. +Proof. now unfold unorm; case nzhead. Qed. + +Lemma nb_digits_unorm u : u <> Nil -> nb_digits (unorm u) <= nb_digits u. +Proof. + intro Hu; case (uint_eq_dec (nzhead u) Nil). + { unfold unorm; intros ->; simpl. + now revert Hu; case u; [|intros u' _; apply le_n_S, Nat.le_0_l..]. } + intro H; rewrite (unorm_nzhead _ H); apply nb_digits_nzhead. +Qed. + +Lemma nb_digits_rev d : nb_digits (rev d) = nb_digits d. +Proof. now rewrite !nb_digits_spec, rev_spec, List.rev_length. Qed. + +Lemma nb_digits_del_head_sub d n : + n <= nb_digits d -> + nb_digits (del_head (nb_digits d - n) d) = n. +Proof. + rewrite !nb_digits_spec; intro Hn. + rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. + rewrite List.skipn_length, <-(Nat2Z.id (_ - _)). + rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. + rewrite (Nat2Z.inj_sub _ _ Hn). + rewrite Z.sub_sub_distr, Z.sub_diag; apply Nat2Z.id. +Qed. + +Lemma unorm_D0 u : unorm (D0 u) = unorm u. +Proof. reflexivity. Qed. + +Lemma app_nil_l d : app Nil d = d. +Proof. now simpl. Qed. + +Lemma app_nil_r d : app d Nil = d. +Proof. now apply to_list_inj; rewrite app_spec, List.app_nil_r. Qed. + +Lemma abs_app_int d d' : abs (app_int d d') = app (abs d) d'. +Proof. now case d. Qed. + +Lemma abs_norm d : abs (norm d) = unorm (abs d). +Proof. now case d as [u|u]; [|simpl; unfold unorm; case nzhead]. Qed. + +Lemma iter_D0_nzhead d : + Nat.iter (nb_digits d - nb_digits (nzhead d)) D0 (nzhead d) = d. +Proof. + induction d; [now simpl| |now rewrite Nat.sub_diag..]. + simpl nzhead; simpl nb_digits. + rewrite (Nat.sub_succ_l _ _ (nb_digits_nzhead _)). + now rewrite <-IHd at 4. +Qed. + +Lemma iter_D0_unorm d : + d <> Nil -> + Nat.iter (nb_digits d - nb_digits (unorm d)) D0 (unorm d) = d. +Proof. + case (uint_eq_dec (nzhead d) Nil); intro Hn. + { unfold unorm; rewrite Hn; simpl; intro H. + revert H Hn; induction d; [now simpl|intros _|now intros _..]. + case (uint_eq_dec d Nil); simpl; intros H Hn; [now rewrite H|]. + rewrite Nat.sub_0_r, (le_plus_minus 1 (nb_digits d)). + { now simpl; rewrite IHd. } + revert H; case d; [now simpl|intros u _; apply le_n_S, Nat.le_0_l..]. } + intros _; rewrite (unorm_nzhead _ Hn); apply iter_D0_nzhead. +Qed. + +Lemma nzhead_app_l d d' : + nb_digits d' < nb_digits (nzhead (app d d')) -> + nzhead (app d d') = app (nzhead d) d'. +Proof. + intro Hl; apply to_list_inj; revert Hl. + rewrite !nb_digits_spec, app_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]. + { now simpl; intro H; exfalso; revert H; apply le_not_lt, length_lnzhead. } + rewrite <-List.app_comm_cons. + now case h; [simpl; intro Hl; apply IHl|..]. +Qed. + +Lemma nzhead_app_r d d' : + nb_digits (nzhead (app d d')) <= nb_digits d' -> + nzhead (app d d') = nzhead d'. +Proof. + intro Hl; apply to_list_inj; revert Hl. + rewrite !nb_digits_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + rewrite <-List.app_comm_cons. + now case h; [| simpl; rewrite List.app_length; intro Hl; exfalso; revert Hl; + apply le_not_lt, le_plus_r..]. +Qed. + +Lemma nzhead_app_nil_r d d' : nzhead (app d d') = Nil -> nzhead d' = Nil. +Proof. +now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. +Qed. + +Lemma nzhead_app_nil d d' : + nb_digits (nzhead (app d d')) <= nb_digits d' -> nzhead d = Nil. +Proof. + intro H; apply to_list_inj; revert H. + rewrite !nb_digits_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + now case h; [now simpl|..]; + simpl;intro H; exfalso; revert H; apply le_not_lt; + rewrite List.app_length; apply le_plus_r. +Qed. + +Lemma nzhead_app_nil_l d d' : nzhead (app d d') = Nil -> nzhead d = Nil. +Proof. + intro H; apply to_list_inj; generalize (f_equal to_list H); clear H. + rewrite !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + now rewrite <-List.app_comm_cons; case h. +Qed. + +Lemma unorm_app_zero d d' : + nb_digits (unorm (app d d')) <= nb_digits d' -> unorm d = zero. +Proof. + unfold unorm. + case (uint_eq_dec (nzhead (app d d')) Nil). + { now intro Hn; rewrite Hn, (nzhead_app_nil_l _ _ Hn). } + intro H; fold (unorm (app d d')); rewrite (unorm_nzhead _ H); intro H'. + case (uint_eq_dec (nzhead d) Nil); [now intros->|]. + intro H''; fold (unorm d); rewrite (unorm_nzhead _ H''). + exfalso; apply H''; revert H'; apply nzhead_app_nil. +Qed. + +Lemma app_int_nil_r d : app_int d Nil = d. +Proof. + now case d; intro d'; simpl; + rewrite <-(of_list_to_list (app _ _)), app_spec; + rewrite List.app_nil_r, of_list_to_list. +Qed. + +Lemma unorm_app_l d d' : + nb_digits d' < nb_digits (unorm (app d d')) -> + unorm (app d d') = app (unorm d) d'. +Proof. + case (uint_eq_dec d' Nil); [now intros->; rewrite !app_nil_r|intro Hd']. + case (uint_eq_dec (nzhead (app d d')) Nil). + { unfold unorm; intros->; simpl; intro H; exfalso; revert H; apply le_not_lt. + now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } + intro Ha; rewrite (unorm_nzhead _ Ha). + intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). + rewrite !nb_digits_spec, app_spec, List.app_length. + case (uint_eq_dec (nzhead d) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } + now intro H; rewrite (unorm_nzhead _ H). +Qed. + +Lemma unorm_app_r d d' : + nb_digits (unorm (app d d')) <= nb_digits d' -> + unorm (app d d') = unorm d'. +Proof. + case (uint_eq_dec (nzhead (app d d')) Nil). + { now unfold unorm; intro H; rewrite H, (nzhead_app_nil_r _ _ H). } + intro Ha; rewrite (unorm_nzhead _ Ha). + case (uint_eq_dec (nzhead d') Nil). + { now intros H H'; exfalso; apply Ha; rewrite nzhead_app_r. } + intro Hd'; rewrite (unorm_nzhead _ Hd'); apply nzhead_app_r. +Qed. + +Lemma norm_app_int d d' : + nb_digits d' < nb_digits (unorm (app (abs d) d')) -> + norm (app_int d d') = app_int (norm d) d'. +Proof. + case (uint_eq_dec d' Nil); [now intros->; rewrite !app_int_nil_r|intro Hd']. + case d as [d|d]; [now simpl; intro H; apply f_equal, unorm_app_l|]. + simpl; unfold unorm. + case (uint_eq_dec (nzhead (app d d')) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply le_not_lt. + now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } + set (m := match nzhead _ with Nil => _ | _ => _ end). + intro Ha. + replace m with (nzhead (app d d')). + 2:{ now unfold m; revert Ha; case nzhead. } + intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). + case (uint_eq_dec (app (nzhead d) d') Nil). + { intros->; simpl; intro H; exfalso; revert H; apply le_not_lt, Nat.le_0_l. } + clear m; set (m := match app _ _ with Nil => _ | _ => _ end). + intro Ha'. + replace m with (Neg (app (nzhead d) d')); [|now unfold m; revert Ha'; case app]. + case (uint_eq_dec (nzhead d) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + intro Hd. + now replace m with (Neg (nzhead d)); [|unfold m; revert Hd; case nzhead]. +Qed. + +Lemma del_head_nb_digits d : del_head (nb_digits d) d = Nil. +Proof. + apply to_list_inj. + rewrite nb_digits_spec, del_head_spec_small; [|now simpl]. + now rewrite List.skipn_all. +Qed. + +Lemma del_tail_nb_digits d : del_tail (nb_digits d) d = Nil. +Proof. now unfold del_tail; rewrite <-nb_digits_rev, del_head_nb_digits. Qed. + +Lemma del_head_app n d d' : + n <= nb_digits d -> del_head n (app d d') = app (del_head n d) d'. +Proof. + rewrite nb_digits_spec; intro Hn. + apply to_list_inj. + rewrite del_head_spec_small. + 2:{ now rewrite app_spec, List.app_length; apply le_plus_trans. } + rewrite !app_spec, (del_head_spec_small _ _ Hn). + rewrite List.skipn_app. + now rewrite (proj2 (Nat.sub_0_le _ _) Hn). +Qed. + +Lemma del_tail_app n d d' : + n <= nb_digits d' -> del_tail n (app d d') = app d (del_tail n d'). +Proof. + rewrite nb_digits_spec; intro Hn. + unfold del_tail. + rewrite <-(of_list_to_list (rev (app d d'))), rev_spec, app_spec. + rewrite List.rev_app_distr, <-!rev_spec, <-app_spec, of_list_to_list. + rewrite del_head_app; [|now rewrite nb_digits_spec, rev_spec, List.rev_length]. + apply to_list_inj. + rewrite rev_spec, !app_spec, !rev_spec. + now rewrite List.rev_app_distr, List.rev_involutive. +Qed. + +Lemma del_tail_app_int n d d' : + n <= nb_digits d' -> del_tail_int n (app_int d d') = app_int d (del_tail n d'). +Proof. now case d as [d|d]; simpl; intro H; rewrite del_tail_app. Qed. + +Lemma app_del_tail_head n (d:uint) : + n <= nb_digits d -> app (del_tail n d) (del_head (nb_digits d - n) d) = d. +Proof. + rewrite nb_digits_spec; intro Hn; unfold del_tail. + rewrite <-(of_list_to_list (app _ _)), app_spec, rev_spec. + rewrite del_head_spec_small; [|now rewrite rev_spec, List.rev_length]. + rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. + rewrite rev_spec. + set (n' := _ - n). + assert (Hn' : n = length (to_list d) - n'). + { now apply plus_minus; rewrite Nat.add_comm; symmetry; apply le_plus_minus_r. } + now rewrite Hn', <-List.firstn_skipn_rev, List.firstn_skipn, of_list_to_list. +Qed. + +Lemma app_int_del_tail_head n (d:int) : + n <= nb_digits (abs d) -> + app_int (del_tail_int n d) (del_head (nb_digits (abs d) - n) (abs d)) = d. +Proof. now case d; clear d; simpl; intros u Hu; rewrite app_del_tail_head. Qed. + +Lemma del_head_app_int_exact i f : + nb_digits f < nb_digits (unorm (app (abs i) f)) -> + del_head (nb_digits (unorm (app (abs i) f)) - nb_digits f) (unorm (app (abs i) f)) = f. +Proof. + simpl; intro Hnb; generalize Hnb; rewrite (unorm_app_l _ _ Hnb); clear Hnb. + replace (_ - _) with (nb_digits (unorm (abs i))). + - now rewrite del_head_app; [rewrite del_head_nb_digits|]. + - rewrite !nb_digits_spec, app_spec, List.app_length. + now rewrite Nat.add_comm, minus_plus. +Qed. + +Lemma del_tail_app_int_exact i f : + nb_digits f < nb_digits (unorm (app (abs i) f)) -> + del_tail_int (nb_digits f) (norm (app_int i f)) = norm i. +Proof. + simpl; intro Hnb. + rewrite (norm_app_int _ _ Hnb). + rewrite del_tail_app_int; [|now simpl]. + now rewrite del_tail_nb_digits, app_int_nil_r. Qed. (** Normalization on little-endian numbers *) @@ -193,6 +494,9 @@ Proof. apply nzhead_revapp. Qed. +Lemma rev_rev d : rev (rev d) = d. +Proof. now apply to_list_inj; rewrite !rev_spec, List.rev_involutive. Qed. + Lemma rev_nztail_rev d : rev (nztail (rev d)) = nzhead d. Proof. @@ -247,47 +551,128 @@ Proof. unfold unorm. now destruct nzhead. Qed. -Lemma unorm_D0 u : unorm (D0 u) = unorm u. -Proof. reflexivity. Qed. - Lemma unorm_iter_D0 n u : unorm (Nat.iter n D0 u) = unorm u. Proof. now induction n. Qed. -Lemma nb_digits_unorm u : - u <> Nil -> nb_digits (unorm u) <= nb_digits u. +Lemma del_head_nonnil n u : + n < nb_digits u -> del_head n u <> Nil. Proof. - case u; clear u; [now simpl|intro u..]; [|now simpl..]. - intros _; unfold unorm. - case_eq (nzhead (D0 u)); [|now intros u' <-; apply nb_digits_nzhead..]. - intros _; apply le_n_S, Nat.le_0_l. + now revert n; induction u; intro n; + [|case n; [|intro n'; simpl; intro H; apply IHu, lt_S_n]..]. Qed. -Lemma nzhead_invol d : nzhead (nzhead d) = nzhead d. +Lemma del_tail_nonnil n u : + n < nb_digits u -> del_tail n u <> Nil. +Proof. + unfold del_tail. + rewrite <-nb_digits_rev. + generalize (rev u); clear u; intro u. + intros Hu H. + generalize (rev_nil_inv _ H); clear H. + now apply del_head_nonnil. +Qed. + +Lemma nzhead_involutive d : nzhead (nzhead d) = nzhead d. Proof. now induction d. Qed. +#[deprecated(since="8.13",note="Use nzhead_involutive instead.")] +Notation nzhead_invol := nzhead_involutive (only parsing). -Lemma nztail_invol d : nztail (nztail d) = nztail d. +Lemma nztail_involutive d : nztail (nztail d) = nztail d. Proof. rewrite <-(rev_rev (nztail _)), <-(rev_rev (nztail d)), <-(rev_rev d). - now rewrite !rev_nztail_rev, nzhead_invol. + now rewrite !rev_nztail_rev, nzhead_involutive. Qed. +#[deprecated(since="8.13",note="Use nztail_involutive instead.")] +Notation nztail_invol := nztail_involutive (only parsing). -Lemma unorm_invol d : unorm (unorm d) = unorm d. +Lemma unorm_involutive d : unorm (unorm d) = unorm d. Proof. unfold unorm. destruct (nzhead d) eqn:E; trivial. destruct (nzhead_nonzero _ _ E). Qed. +#[deprecated(since="8.13",note="Use unorm_involutive instead.")] +Notation unorm_invol := unorm_involutive (only parsing). -Lemma norm_invol d : norm (norm d) = norm d. +Lemma norm_involutive d : norm (norm d) = norm d. Proof. unfold norm. destruct d. - - f_equal. apply unorm_invol. + - f_equal. apply unorm_involutive. - destruct (nzhead d) eqn:E; auto. destruct (nzhead_nonzero _ _ E). Qed. +#[deprecated(since="8.13",note="Use norm_involutive instead.")] +Notation norm_invol := norm_involutive (only parsing). + +Lemma lnzhead_neq_d0_head l l' : ~(lnzhead l = cons d0 l'). +Proof. now induction l as [|h t Il]; [|case h]. Qed. + +Lemma lnzhead_head_nd0 h t : h <> d0 -> lnzhead (cons h t) = cons h t. +Proof. now case h. Qed. + +Lemma nzhead_del_tail_nzhead_eq n u : + nzhead u = u -> + n < nb_digits u -> + nzhead (del_tail n u) = del_tail n u. +Proof. + rewrite nb_digits_spec, <-List.rev_length. + intros Hu Hn. + apply to_list_inj; unfold del_tail. + rewrite nzhead_spec, rev_spec. + rewrite del_head_spec_small; [|now rewrite rev_spec; apply Nat.lt_le_incl]. + rewrite rev_spec. + rewrite List.skipn_rev, List.rev_involutive. + generalize (f_equal to_list Hu) Hn; rewrite nzhead_spec; intro Hu'. + case (to_list u) as [|h t]. + { simpl; intro H; exfalso; revert H; apply le_not_lt, Peano.le_0_n. } + intro Hn'; generalize (Nat.sub_gt _ _ Hn'); rewrite List.rev_length. + case (_ - _); [now simpl|]; intros n' _. + rewrite List.firstn_cons, lnzhead_head_nd0; [now simpl|]. + intro Hh; revert Hu'; rewrite Hh; apply lnzhead_neq_d0_head. +Qed. + +Lemma nzhead_del_tail_nzhead n u : + n < nb_digits (nzhead u) -> + nzhead (del_tail n (nzhead u)) = del_tail n (nzhead u). +Proof. apply nzhead_del_tail_nzhead_eq, nzhead_involutive. Qed. + +Lemma unorm_del_tail_unorm n u : + n < nb_digits (unorm u) -> + unorm (del_tail n (unorm u)) = del_tail n (unorm u). +Proof. + case (uint_eq_dec (nzhead u) Nil). + - unfold unorm; intros->; case n; [now simpl|]; intro n'. + now simpl; intro H; exfalso; generalize (lt_S_n _ _ H). + - unfold unorm. + set (m := match nzhead u with Nil => zero | _ => _ end). + intros H. + replace m with (nzhead u). + + intros H'. + rewrite (nzhead_del_tail_nzhead _ _ H'). + now generalize (del_tail_nonnil _ _ H'); case del_tail. + + now unfold m; revert H; case nzhead. +Qed. + +Lemma norm_del_tail_int_norm n d : + n < nb_digits (match norm d with Pos d | Neg d => d end) -> + norm (del_tail_int n (norm d)) = del_tail_int n (norm d). +Proof. + case d; clear d; intros u; simpl. + - now intro H; simpl; rewrite unorm_del_tail_unorm. + - case (uint_eq_dec (nzhead u) Nil); intro Hu. + + now rewrite Hu; case n; [|intros n' Hn'; generalize (lt_S_n _ _ Hn')]. + + set (m := match nzhead u with Nil => Pos zero | _ => _ end). + replace m with (Neg (nzhead u)); [|now unfold m; revert Hu; case nzhead]. + unfold del_tail_int. + clear m Hu. + simpl. + intro H; generalize (del_tail_nonnil _ _ H). + rewrite (nzhead_del_tail_nzhead _ _ H). + now case del_tail. +Qed. Lemma nzhead_app_nzhead d d' : nzhead (app (nzhead d) d') = nzhead (app d d'). @@ -299,7 +684,7 @@ Proof. generalize (nzhead_revapp d d'). generalize (nzhead_revapp_0 (nztail d) d'). generalize (nzhead_revapp (nztail d) d'). - rewrite nztail_invol. + rewrite nztail_involutive. now case nztail; [intros _ H _ H'; rewrite (H eq_refl), (H' eq_refl) |intros d'' H _ H' _; rewrite H; [rewrite H'|]..]. @@ -336,5 +721,5 @@ Proof. |rewrite H'; unfold r; clear m r H']; unfold norm; rewrite rev_rev, <-Hd''; - rewrite nzhead_revapp; rewrite nztail_invol; [|rewrite Hd'']..]. + rewrite nzhead_revapp; rewrite nztail_involutive; [|rewrite Hd'']..]. Qed. diff --git a/theories/Numbers/HexadecimalN.v b/theories/Numbers/HexadecimalN.v index f333e2b7f6..93ba82d14a 100644 --- a/theories/Numbers/HexadecimalN.v +++ b/theories/Numbers/HexadecimalN.v @@ -74,7 +74,7 @@ Proof. destruct (norm d) eqn:Hd; intros [= <-]. unfold N.to_hex_int. rewrite Unsigned.to_of. f_equal. revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_invol. + - intros [= <-]. apply unorm_involutive. - destruct (nzhead d); now intros [= <-]. Qed. @@ -93,7 +93,7 @@ Qed. Lemma of_int_norm d : N.of_hex_int (norm d) = N.of_hex_int d. Proof. - unfold N.of_hex_int. now rewrite norm_invol. + unfold N.of_hex_int. now rewrite norm_involutive. Qed. Lemma of_inj_pos d d' : diff --git a/theories/Numbers/HexadecimalNat.v b/theories/Numbers/HexadecimalNat.v index b05184e821..94a14b90bd 100644 --- a/theories/Numbers/HexadecimalNat.v +++ b/theories/Numbers/HexadecimalNat.v @@ -289,7 +289,7 @@ Proof. destruct (norm d) eqn:Hd; intros [= <-]. unfold Nat.to_hex_int. rewrite Unsigned.to_of. f_equal. revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_invol. + - intros [= <-]. apply unorm_involutive. - destruct (nzhead d); now intros [= <-]. Qed. @@ -308,7 +308,7 @@ Qed. Lemma of_int_norm d : Nat.of_hex_int (norm d) = Nat.of_hex_int d. Proof. - unfold Nat.of_hex_int. now rewrite norm_invol. + unfold Nat.of_hex_int. now rewrite norm_involutive. Qed. Lemma of_inj_pos d d' : diff --git a/theories/Numbers/HexadecimalQ.v b/theories/Numbers/HexadecimalQ.v index bbafa7ddc1..a32019767c 100644 --- a/theories/Numbers/HexadecimalQ.v +++ b/theories/Numbers/HexadecimalQ.v @@ -16,8 +16,109 @@ Require Import Decimal DecimalFacts DecimalPos DecimalN DecimalZ. Require Import Hexadecimal HexadecimalFacts HexadecimalPos HexadecimalN HexadecimalZ QArith. +Lemma of_IQmake_to_hexadecimal num den : + match IQmake_to_hexadecimal num den with + | None => True + | Some (HexadecimalExp _ _ _) => False + | Some (Hexadecimal i f) => of_hexadecimal (Hexadecimal i f) = IQmake (IZ_of_Z num) den + end. +Proof. + unfold IQmake_to_hexadecimal. + generalize (Unsigned.nztail_to_hex_uint den). + case Hexadecimal.nztail; intros den' e_den'. + case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. + case den'; [ |now simpl..]; clear den'. + case e_den' as [|e_den']; simpl; intro H; injection H; clear H; intros->. + { now unfold of_hexadecimal; simpl; rewrite app_int_nil_r, HexadecimalZ.of_to. } + replace (16 ^ _)%positive with (Nat.iter (S e_den') (Pos.mul 16) 1%positive). + 2:{ induction e_den' as [|n IHn]; [now simpl| ]. + now rewrite SuccNat2Pos.inj_succ, Pos.pow_succ_r, <-IHn. } + case Nat.ltb_spec; intro He_den'. + - unfold of_hexadecimal; simpl. + rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. + rewrite HexadecimalZ.of_to. + now rewrite nb_digits_del_head_sub; [|now apply Nat.lt_le_incl]. + - unfold of_hexadecimal; simpl. + rewrite nb_digits_iter_D0. + apply f_equal2. + + apply f_equal, HexadecimalZ.to_int_inj. + rewrite HexadecimalZ.to_of. + rewrite <-(HexadecimalZ.of_to num), HexadecimalZ.to_of. + case (Z.to_hex_int num); clear He_den' num; intro num; simpl. + * unfold app; simpl. + now rewrite unorm_D0, unorm_iter_D0, unorm_involutive. + * case (uint_eq_dec (nzhead num) Nil); [|intro Hn]. + { intros->; simpl; unfold app; simpl. + now rewrite unorm_D0, unorm_iter_D0. } + replace (match nzhead num with Nil => _ | _ => _ end) + with (Neg (nzhead num)); [|now revert Hn; case nzhead]. + simpl. + rewrite nzhead_iter_D0, nzhead_involutive. + now revert Hn; case nzhead. + + revert He_den'; case nb_digits as [|n]; [now simpl; rewrite Nat.add_0_r|]. + intro Hn. + rewrite Nat.add_succ_r, Nat.add_comm. + now rewrite <-le_plus_minus; [|apply le_S_n]. +Qed. + +Lemma IZ_of_Z_IZ_to_Z z z' : IZ_to_Z z = Some z' -> IZ_of_Z z' = z. +Proof. now case z as [| |p|p]; [|intro H; injection H; intros<-..]. Qed. + +Lemma of_IQmake_to_hexadecimal' num den : + match IQmake_to_hexadecimal' num den with + | None => True + | Some (HexadecimalExp _ _ _) => False + | Some (Hexadecimal i f) => of_hexadecimal (Hexadecimal i f) = IQmake num den + end. +Proof. + unfold IQmake_to_hexadecimal'. + case_eq (IZ_to_Z num); [intros num' Hnum'|now simpl]. + generalize (of_IQmake_to_hexadecimal num' den). + case IQmake_to_hexadecimal as [d|]; [|now simpl]. + case d as [i f|]; [|now simpl]. + now rewrite (IZ_of_Z_IZ_to_Z _ _ Hnum'). +Qed. + Lemma of_to (q:IQ) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. -Admitted. +Proof. + intro d. + case q as [num den|q q'|q q']; simpl. + - generalize (of_IQmake_to_hexadecimal' num den). + case IQmake_to_hexadecimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + now intros H H'; injection H'; clear H'; intros <-. + - case q as [num den| |]; [|now simpl..]. + case q' as [num' den'| |]; [|now simpl..]. + case num' as [z p| | |]; [|now simpl..]. + case (Z.eq_dec z 2); [intros->|]. + 2:{ case z; [now simpl| |now simpl]; intro pz'. + case pz'; [intros d0..| ]; [now simpl| |now simpl]. + now case d0. } + case (Pos.eq_dec den' 1%positive); [intros->|now case den']. + generalize (of_IQmake_to_hexadecimal' num den). + case IQmake_to_hexadecimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros <-; clear num den. + intros H; injection H; clear H; intros<-. + unfold of_hexadecimal; simpl. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + - case q as [num den| |]; [|now simpl..]. + case q' as [num' den'| |]; [|now simpl..]. + case num' as [z p| | |]; [|now simpl..]. + case (Z.eq_dec z 2); [intros->|]. + 2:{ case z; [now simpl| |now simpl]; intro pz'. + case pz'; [intros d0..| ]; [now simpl| |now simpl]. + now case d0. } + case (Pos.eq_dec den' 1%positive); [intros->|now case den']. + generalize (of_IQmake_to_hexadecimal' num den). + case IQmake_to_hexadecimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros <-; clear num den. + intros H; injection H; clear H; intros<-. + unfold of_hexadecimal; simpl. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. +Qed. + Definition dnorm (d:hexadecimal) : hexadecimal := let norm_i i f := @@ -44,13 +145,50 @@ Lemma dnorm_spec_i d : (i' = Neg (unorm i) /\ (nzhead i <> Nil \/ nzhead f <> Nil)) \/ (i' = Pos zero /\ (nzhead i = Nil /\ nzhead f = Nil)) end. -Admitted. +Proof. + case d as [i f|i f e]; case i as [i|i]. + - now simpl. + - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. + + rewrite Ha; right; split; [now simpl|split]. + * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). + * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). + + left; split; [now revert Ha; case nzhead|]. + case (uint_eq_dec (nzhead i) Nil). + * intro Hi; right; intro Hf; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now intro H; left. + - simpl; case (Decimal.norm e); clear e; intro e; [|now simpl]. + now case e; clear e; [|intro e..]; [|case e|..]. + - simpl. + set (m := match nzhead _ with Nil => _ | _ => _ end). + set (m' := match _ with Hexadecimal _ _ => _ | _ => _ end). + replace m' with m. + 2:{ unfold m'; case (Decimal.norm e); clear m' e; intro e; [|now simpl]. + now case e; clear e; [|intro e..]; [|case e|..]. } + unfold m; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. + + rewrite Ha; right; split; [now simpl|split]. + * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). + * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). + + left; split; [now revert Ha; case nzhead|]. + case (uint_eq_dec (nzhead i) Nil). + * intro Hi; right; intro Hf; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now intro H; left. +Qed. Lemma dnorm_spec_f d : let f := match d with Hexadecimal _ f => f | HexadecimalExp _ f _ => f end in let f' := match dnorm d with Hexadecimal _ f => f | HexadecimalExp _ f _ => f end in f' = f. -Admitted. +Proof. + case d as [i f|i f e]; [now simpl|]. + simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); [now intros->|intro He]. + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + replace m with (HexadecimalExp i' f (Decimal.norm e)); [now simpl|]. + unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. +Qed. Lemma dnorm_spec_e d : match d, dnorm d with @@ -61,24 +199,241 @@ Lemma dnorm_spec_e d : e' = Decimal.norm e /\ e' <> Decimal.Pos Decimal.zero | Hexadecimal _ _, HexadecimalExp _ _ _ => False end. -Admitted. +Proof. + case d as [i f|i f e]; [now simpl|]. + simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); [now intros->|intro He]. + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + replace m with (HexadecimalExp i' f (Decimal.norm e)); [now simpl|]. + unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. +Qed. -Lemma dnorm_invol d : dnorm (dnorm d) = dnorm d. -Admitted. +Lemma dnorm_involutive d : dnorm (dnorm d) = dnorm d. +Proof. + case d as [i f|i f e]; case i as [i|i]. + - now simpl; rewrite unorm_involutive. + - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + set (m := match nzhead _ with Nil =>_ | _ => _ end). + replace m with (Neg (unorm i)). + 2:{ now unfold m; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + + unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + * intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now case nzhead. + + rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. + - simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); intro He. + + now rewrite He; simpl; rewrite unorm_involutive. + + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + replace m with (HexadecimalExp (Pos (unorm i)) f (Decimal.norm e)). + 2:{ unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + simpl; rewrite DecimalFacts.norm_involutive, unorm_involutive. + revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. + - simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); intro He. + + rewrite He; simpl. + case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + set (m := match nzhead _ with Nil =>_ | _ => _ end). + replace m with (Neg (unorm i)). + 2:{ now unfold m; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + * unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + -- intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + -- now case nzhead. + * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. + + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + pose (i' := match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end). + replace m with (HexadecimalExp i' f (Decimal.norm e)). + 2:{ unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + simpl; rewrite DecimalFacts.norm_involutive. + set (i'' := match i' with Pos _ => _ | _ => _ end). + clear m; set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + replace m with (HexadecimalExp i'' f (Decimal.norm e)). + 2:{ unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + unfold i'', i'. + case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + fold i'; replace i' with (Neg (unorm i)). + 2:{ now unfold i'; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + * unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + -- intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + -- now case nzhead. + * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. +Qed. + +Lemma IZ_to_Z_IZ_of_Z z : IZ_to_Z (IZ_of_Z z) = Some z. +Proof. now case z. Qed. + +Lemma dnorm_i_exact i f : + (nb_digits f < nb_digits (unorm (app (abs i) f)))%nat -> + match i with + | Pos i => Pos (unorm i) + | Neg i => + match nzhead (app i f) with + | Nil => Pos zero + | _ => Neg (unorm i) + end + end = norm i. +Proof. + case i as [ni|ni]; [now simpl|]; simpl. + case (uint_eq_dec (nzhead (app ni f)) Nil); intro Ha. + { now rewrite Ha, (nzhead_app_nil_l _ _ Ha). } + rewrite (unorm_nzhead _ Ha). + set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (unorm ni)); [|now unfold m; revert Ha; case nzhead]. + case (uint_eq_dec (nzhead ni) Nil); intro Hni. + { rewrite <-nzhead_app_nzhead, Hni, app_nil_l. + intro H; exfalso; revert H; apply le_not_lt, nb_digits_nzhead. } + clear m; set (m := match nzhead ni with Nil => _ | _ => _ end). + replace m with (Neg (nzhead ni)); [|now unfold m; revert Hni; case nzhead]. + now rewrite (unorm_nzhead _ Hni). +Qed. + +Lemma dnorm_i_exact' i f : + (nb_digits (unorm (app (abs i) f)) <= nb_digits f)%nat -> + match i with + | Pos i => Pos (unorm i) + | Neg i => + match nzhead (app i f) with + | Nil => Pos zero + | _ => Neg (unorm i) + end + end = + match norm (app_int i f) with + | Pos _ => Pos zero + | Neg _ => Neg zero + end. +Proof. + case i as [ni|ni]; simpl. + { now intro Hnb; rewrite (unorm_app_zero _ _ Hnb). } + unfold unorm. + case (uint_eq_dec (nzhead (app ni f)) Nil); intro Hn. + { now rewrite Hn. } + set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (nzhead (app ni f)). + 2:{ now unfold m; revert Hn; case nzhead. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (unorm ni)). + 2:{ now unfold m, unorm; revert Hn; case nzhead. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (nzhead (app ni f))). + 2:{ now unfold m; revert Hn; case nzhead. } + rewrite <-(unorm_nzhead _ Hn). + now intro H; rewrite (unorm_app_zero _ _ H). +Qed. Lemma to_of (d:hexadecimal) : to_hexadecimal (of_hexadecimal d) = Some (dnorm d). -Admitted. +Proof. + case d as [i f|i f e]. + - unfold of_hexadecimal; simpl; unfold IQmake_to_hexadecimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_hexadecimal; simpl. + change (fun _ : positive => _) with (Pos.mul 16). + rewrite nztail_to_hex_uint_pow16, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + + rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + + rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + * rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + * rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + - unfold of_hexadecimal; simpl. + rewrite <-DecimalZ.to_of. + case (Z.of_int e); clear e; [|intro e..]; simpl. + + unfold IQmake_to_hexadecimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_hexadecimal; simpl. + change (fun _ : positive => _) with (Pos.mul 16). + rewrite nztail_to_hex_uint_pow16, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + + unfold IQmake_to_hexadecimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_hexadecimal; simpl. + change (fun _ : positive => _) with (Pos.mul 16). + rewrite nztail_to_hex_uint_pow16, to_of. + generalize (DecimalPos.Unsigned.to_uint_nonzero e); intro He. + set (dnorm_i := match i with Pos _ => _ | _ => _ end). + set (m := match Pos.to_uint e with Decimal.Nil => _ | _ => _ end). + replace m with (HexadecimalExp dnorm_i f (Decimal.Pos (Pos.to_uint e))). + 2:{ now unfold m; revert He; case (Pos.to_uint e); [|intro u; case u|..]. } + clear m; unfold dnorm_i. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + + unfold IQmake_to_hexadecimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_hexadecimal; simpl. + change (fun _ : positive => _) with (Pos.mul 16). + rewrite nztail_to_hex_uint_pow16, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. +Qed. (** Some consequences *) Lemma to_hexadecimal_inj q q' : to_hexadecimal q <> None -> to_hexadecimal q = to_hexadecimal q' -> q = q'. Proof. -intros Hnone EQ. -generalize (of_to q) (of_to q'). -rewrite <-EQ. -revert Hnone; case to_hexadecimal; [|now simpl]. -now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). + intros Hnone EQ. + generalize (of_to q) (of_to q'). + rewrite <-EQ. + revert Hnone; case to_hexadecimal; [|now simpl]. + now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). Qed. Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (dnorm d). @@ -87,18 +442,18 @@ Proof. Qed. Lemma of_hexadecimal_dnorm d : of_hexadecimal (dnorm d) = of_hexadecimal d. -Proof. now apply to_hexadecimal_inj; rewrite !to_of; [|rewrite dnorm_invol]. Qed. +Proof. now apply to_hexadecimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. Lemma of_inj d d' : of_hexadecimal d = of_hexadecimal d' -> dnorm d = dnorm d'. Proof. -intro H. -apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) - (Some (dnorm d)) (Some (dnorm d'))). -now rewrite <- !to_of, H. + intro H. + apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). + now rewrite <- !to_of, H. Qed. Lemma of_iff d d' : of_hexadecimal d = of_hexadecimal d' <-> dnorm d = dnorm d'. Proof. -split. apply of_inj. intros E. rewrite <- of_hexadecimal_dnorm, E. -apply of_hexadecimal_dnorm. + split. apply of_inj. intros E. rewrite <- of_hexadecimal_dnorm, E. + apply of_hexadecimal_dnorm. Qed. diff --git a/theories/Numbers/HexadecimalZ.v b/theories/Numbers/HexadecimalZ.v index c5ed0b5b28..1d78ad1ad2 100644 --- a/theories/Numbers/HexadecimalZ.v +++ b/theories/Numbers/HexadecimalZ.v @@ -80,9 +80,11 @@ Lemma of_hex_uint_iter_D0 d n : Z.of_hex_uint (app d (Nat.iter n D0 Nil)) = Nat.iter n (Z.mul 0x10) (Z.of_hex_uint d). Proof. - unfold Z.of_hex_uint. - unfold app; rewrite <-rev_revapp. - rewrite Unsigned.of_lu_rev, Unsigned.of_lu_revapp. + rewrite <-(rev_rev (app _ _)), <-(of_list_to_list (rev (app _ _))). + rewrite rev_spec, app_spec, List.rev_app_distr. + rewrite <-!rev_spec, <-app_spec, of_list_to_list. + unfold Z.of_hex_uint; rewrite Unsigned.of_lu_rev. + unfold app; rewrite Unsigned.of_lu_revapp, !rev_rev. rewrite <-!Unsigned.of_lu_rev, !rev_rev. assert (H' : Pos.of_hex_uint (Nat.iter n D0 Nil) = 0%N). { now induction n; [|rewrite Unsigned.nat_iter_S]. } @@ -140,3 +142,22 @@ Qed. Lemma double_to_hex_int n : double (Z.to_hex_int n) = Z.to_hex_int (Z.double n). Proof. now rewrite <-(of_to n), <-of_hex_int_double, !to_of, double_norm. Qed. + +Lemma nztail_to_hex_uint_pow16 n : + Hexadecimal.nztail (Pos.to_hex_uint (Nat.iter n (Pos.mul 16) 1%positive)) + = (D1 Nil, n). +Proof. + case n as [|n]; [now simpl|]. + rewrite <-(Nat2Pos.id (S n)); [|now simpl]. + generalize (Pos.of_nat (S n)); clear n; intro p. + induction (Pos.to_nat p); [now simpl|]. + rewrite Unsigned.nat_iter_S. + unfold Pos.to_hex_uint. + change (Pos.to_little_hex_uint _) + with (Unsigned.to_lu (16 * N.pos (Nat.iter n (Pos.mul 16) 1%positive))). + rewrite Unsigned.to_lhex_tenfold. + revert IHn; unfold Pos.to_hex_uint. + unfold Hexadecimal.nztail; rewrite !rev_rev; simpl. + set (f'' := _ (Pos.to_little_hex_uint _)). + now case f''; intros r n' H; inversion H. +Qed. -- cgit v1.2.3 From b6c13afd432ce1957315e94c1ce8c06aa848fe5a Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:19:00 +0200 Subject: [numeral notation] R Previously real constants were parsed by an unproved OCaml code. The parser and printer are now implemented in Coq, which will enable a proof and hopefully make it easier to maintain / make evolve. Previously reals were all parsed as an integer, an integer multiplied by a power of ten or an integer divided by a power of ten. This means 1.02 and 102e-2 were both parsed as 102 / 100 and could not be tell apart when printing. So the printer had to choose between two representations : without exponent or without decimal dot. The choice was made heuristically toward a most compact representation. Now, decimal dot is parsed as a rational and exponents are parsed as a product or division by a power of ten. For instance, 1.02 is parsed as Q2R (102 # 100) whereas 102e-2 is parsed as IZR 102 / IZR (Z.pow_pos 10 2). 1.02 and 102e-2 remain equal (proved by reflexivity) but 1.02e1 = Q2R (102 # 100) * 10 and 10.2 = Q2R (102 # 10) no longer are. --- Makefile.common | 1 - plugins/syntax/dune | 7 -- plugins/syntax/r_syntax.ml | 214 ---------------------------------- plugins/syntax/r_syntax.mli | 9 -- plugins/syntax/r_syntax_plugin.mlpack | 1 - test-suite/output/RealSyntax.out | 101 +++++++++++----- test-suite/output/RealSyntax.v | 44 +++++-- theories/QArith/Qreals.v | 2 - theories/Reals/Rdefinitions.v | 155 +++++++++++++++++++++++- theories/Reals/Rregisternames.v | 4 +- theories/dune | 1 - 11 files changed, 266 insertions(+), 273 deletions(-) delete mode 100644 plugins/syntax/r_syntax.ml delete mode 100644 plugins/syntax/r_syntax.mli delete mode 100644 plugins/syntax/r_syntax_plugin.mlpack diff --git a/Makefile.common b/Makefile.common index a482b9b963..29020dc4ad 100644 --- a/Makefile.common +++ b/Makefile.common @@ -149,7 +149,6 @@ CCCMO:=plugins/cc/cc_plugin.cmo BTAUTOCMO:=plugins/btauto/btauto_plugin.cmo RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo SYNTAXCMO:=$(addprefix plugins/syntax/, \ - r_syntax_plugin.cmo \ int63_syntax_plugin.cmo \ float_syntax_plugin.cmo \ numeral_notation_plugin.cmo \ diff --git a/plugins/syntax/dune b/plugins/syntax/dune index b395695c8a..1b3d7598da 100644 --- a/plugins/syntax/dune +++ b/plugins/syntax/dune @@ -12,13 +12,6 @@ (modules g_string string_notation) (libraries coq.vernac)) -(library - (name r_syntax_plugin) - (public_name coq.plugins.r_syntax) - (synopsis "Coq syntax plugin: reals") - (modules r_syntax) - (libraries coq.vernac)) - (library (name int63_syntax_plugin) (public_name coq.plugins.int63_syntax) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml deleted file mode 100644 index d66b9537b4..0000000000 --- a/plugins/syntax/r_syntax.ml +++ /dev/null @@ -1,214 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* GlobRef.equal r gr -| _ -> false - -let positive_modpath = MPfile (make_dir binnums) - -let positive_kn = MutInd.make2 positive_modpath (Label.make "positive") -let path_of_xI = ((positive_kn,0),1) -let path_of_xO = ((positive_kn,0),2) -let path_of_xH = ((positive_kn,0),3) -let glob_xI = GlobRef.ConstructRef path_of_xI -let glob_xO = GlobRef.ConstructRef path_of_xO -let glob_xH = GlobRef.ConstructRef path_of_xH - -let pos_of_bignat ?loc x = - let ref_xI = DAst.make @@ GRef (glob_xI, None) in - let ref_xH = DAst.make @@ GRef (glob_xH, None) in - let ref_xO = DAst.make @@ GRef (glob_xO, None) in - let rec pos_of x = - match Z.(div_rem x (of_int 2)) with - | (q,rem) when rem = Z.zero -> DAst.make @@ GApp (ref_xO,[pos_of q]) - | (q,_) when not Z.(equal q zero) -> DAst.make @@ GApp (ref_xI,[pos_of q]) - | (q,_) -> ref_xH - in - pos_of x - -(**********************************************************************) -(* Printing positive via scopes *) -(**********************************************************************) - -let rec bignat_of_pos c = match DAst.get c with - | GApp (r, [a]) when is_gr r glob_xO -> Z.mul Z.(of_int 2) (bignat_of_pos a) - | GApp (r, [a]) when is_gr r glob_xI -> Z.add Z.one Z.(mul (of_int 2) (bignat_of_pos a)) - | GRef (a, _) when GlobRef.equal a glob_xH -> Z.one - | _ -> raise Non_closed_number - -(**********************************************************************) -(* Parsing Z via scopes *) -(**********************************************************************) - -let z_kn = MutInd.make2 positive_modpath (Label.make "Z") -let path_of_ZERO = ((z_kn,0),1) -let path_of_POS = ((z_kn,0),2) -let path_of_NEG = ((z_kn,0),3) -let glob_ZERO = GlobRef.ConstructRef path_of_ZERO -let glob_POS = GlobRef.ConstructRef path_of_POS -let glob_NEG = GlobRef.ConstructRef path_of_NEG - -let z_of_int ?loc n = - if not Z.(equal n zero) then - let sgn, n = - if Z.(leq zero n) then glob_POS, n else glob_NEG, Z.neg n in - DAst.make @@ GApp(DAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) - else - DAst.make @@ GRef (glob_ZERO, None) - -(**********************************************************************) -(* Printing Z via scopes *) -(**********************************************************************) - -let bigint_of_z c = match DAst.get c with - | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a - | GApp (r,[a]) when is_gr r glob_NEG -> Z.neg (bignat_of_pos a) - | GRef (a, _) when GlobRef.equal a glob_ZERO -> Z.zero - | _ -> raise Non_closed_number - -(**********************************************************************) -(* Parsing R via scopes *) -(**********************************************************************) - -let rdefinitions = ["Coq";"Reals";"Rdefinitions"] -let r_modpath = MPfile (make_dir rdefinitions) -let r_base_modpath = MPdot (r_modpath, Label.make "RbaseSymbolsImpl") -let r_path = make_path ["Coq";"Reals";"Rdefinitions";"RbaseSymbolsImpl"] "R" - -let glob_IZR = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") -let glob_Rmult = GlobRef.ConstRef (Constant.make2 r_base_modpath @@ Label.make "Rmult") -let glob_Rdiv = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "Rdiv") - -let binintdef = ["Coq";"ZArith";"BinIntDef"] -let z_modpath = MPdot (MPfile (make_dir binintdef), Label.make "Z") - -let glob_pow_pos = GlobRef.ConstRef (Constant.make2 z_modpath @@ Label.make "pow_pos") - -let r_of_rawnum ?loc n = - let n,e = NumTok.Signed.to_bigint_and_exponent n in - let e,p = NumTok.(match e with EDec e -> e, 10 | EBin e -> e, 2) in - let izr z = - DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z]) in - let rmult r r' = - DAst.make @@ GApp (DAst.make @@ GRef(glob_Rmult,None), [r; r']) in - let rdiv r r' = - DAst.make @@ GApp (DAst.make @@ GRef(glob_Rdiv,None), [r; r']) in - let pow p e = - let p = z_of_int ?loc (Z.of_int p) in - let e = pos_of_bignat e in - DAst.make @@ GApp (DAst.make @@ GRef(glob_pow_pos,None), [p; e]) in - let n = - izr (z_of_int ?loc n) in - if Int.equal (Z.sign e) 1 then rmult n (izr (pow p e)) - else if Int.equal (Z.sign e) (-1) then rdiv n (izr (pow p (Z.neg e))) - else n (* e = 0 *) - -(**********************************************************************) -(* Printing R via scopes *) -(**********************************************************************) - -let rawnum_of_r c = - (* print i * 10^e, precondition: e <> 0 *) - let numTok_of_int_exp i e = - (* choose between 123e-2 and 1.23, this is purely heuristic - and doesn't play any soundness role *) - let choose_exponent = - if Int.equal (Z.sign e) 1 then - true (* don't print 12 * 10^2 as 1200 to distinguish them *) - else - let i = Z.to_string i in - let li = if i.[0] = '-' then String.length i - 1 else String.length i in - let e = Z.neg e in - let le = String.length (Z.to_string e) in - Z.(lt (add (of_int li) (of_int le)) e) in - (* print 123 * 10^-2 as 123e-2 *) - let numTok_exponent () = - NumTok.Signed.of_bigint_and_exponent i (NumTok.EDec e) in - (* print 123 * 10^-2 as 1.23, precondition e < 0 *) - let numTok_dot () = - let s, i = - if Z.sign i >= 0 then NumTok.SPlus, Z.to_string i - else NumTok.SMinus, Z.(to_string (neg i)) in - let ni = String.length i in - let e = - (Z.to_int e) in - assert (e > 0); - let i, f = - if e < ni then String.sub i 0 (ni - e), String.sub i (ni - e) e - else "0", String.make (e - ni) '0' ^ i in - let i = s, NumTok.UnsignedNat.of_string i in - let f = NumTok.UnsignedNat.of_string f in - NumTok.Signed.of_int_frac_and_exponent i (Some f) None in - if choose_exponent then numTok_exponent () else numTok_dot () in - match DAst.get c with - | GApp (r, [a]) when is_gr r glob_IZR -> - let n = bigint_of_z a in - NumTok.(Signed.of_bigint CDec n) - | GApp (md, [l; r]) when is_gr md glob_Rmult || is_gr md glob_Rdiv -> - begin match DAst.get l, DAst.get r with - | GApp (i, [l]), GApp (i', [r]) - when is_gr i glob_IZR && is_gr i' glob_IZR -> - begin match DAst.get r with - | GApp (p, [t; e]) when is_gr p glob_pow_pos -> - let t = bigint_of_z t in - if not (Z.(equal t (of_int 10))) then - raise Non_closed_number - else - let i = bigint_of_z l in - let e = bignat_of_pos e in - let e = if is_gr md glob_Rdiv then Z.neg e else e in - numTok_of_int_exp i e - | _ -> raise Non_closed_number - end - | _ -> raise Non_closed_number - end - | _ -> raise Non_closed_number - -let uninterp_r (AnyGlobConstr p) = - try - Some (rawnum_of_r p) - with Non_closed_number -> - None - -open Notation - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -let r_scope = "R_scope" - -let _ = - register_rawnumeral_interpretation r_scope (r_of_rawnum,uninterp_r); - at_declare_ml_module enable_prim_token_interpretation - { pt_local = false; - pt_scope = r_scope; - pt_interp_info = Uid r_scope; - pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); - pt_refs = [glob_IZR; glob_Rmult; glob_Rdiv]; - pt_in_match = false } diff --git a/plugins/syntax/r_syntax.mli b/plugins/syntax/r_syntax.mli deleted file mode 100644 index b72d544151..0000000000 --- a/plugins/syntax/r_syntax.mli +++ /dev/null @@ -1,9 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* 0%R. Proof. intros. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index affa129771..a4809a7513 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -22,11 +22,12 @@ Require Import ConstructiveRcomplete. Require Import ClassicalDedekindReals. -(* Declare primitive numeral notations for Scope R_scope *) +(* Declare primitive number notations for Scope R_scope *) +Declare Scope hex_R_scope. Declare Scope R_scope. -Declare ML Module "r_syntax_plugin". (* Declare Scope R_scope with Key R *) +Delimit Scope hex_R_scope with xR. Delimit Scope R_scope with R. Local Open Scope R_scope. @@ -224,3 +225,153 @@ Proof. - (* x = n-1 *) exact n. - exact (Z.pred n). Defined. + +(** Injection of rational numbers into real numbers. *) + +Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R. + +(**********************************************************) +(** * Number notation for constants *) +(**********************************************************) + +Inductive IR := + | IRZ : IZ -> IR + | IRQ : Q -> IR + | IRmult : IR -> IR -> IR + | IRdiv : IR -> IR -> IR. + +Definition of_decimal (d : Decimal.decimal) : IR := + let '(i, f, e) := + match d with + | Decimal.Decimal i f => (i, f, Decimal.Pos Decimal.Nil) + | Decimal.DecimalExp i f e => (i, f, e) + end in + let zq := match f with + | Decimal.Nil => IRZ (IZ_of_Z (Z.of_int i)) + | _ => + let num := Z.of_int (Decimal.app_int i f) in + let den := Nat.iter (Decimal.nb_digits f) (Pos.mul 10) 1%positive in + IRQ (Qmake num den) end in + let e := Z.of_int e in + match e with + | Z0 => zq + | Zpos e => IRmult zq (IRZ (IZpow_pos 10 e)) + | Zneg e => IRdiv zq (IRZ (IZpow_pos 10 e)) + end. + +Definition of_hexadecimal (d : Hexadecimal.hexadecimal) : IR := + let '(i, f, e) := + match d with + | Hexadecimal.Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) + | Hexadecimal.HexadecimalExp i f e => (i, f, e) + end in + let zq := match f with + | Hexadecimal.Nil => IRZ (IZ_of_Z (Z.of_hex_int i)) + | _ => + let num := Z.of_hex_int (Hexadecimal.app_int i f) in + let den := Nat.iter (Hexadecimal.nb_digits f) (Pos.mul 16) 1%positive in + IRQ (Qmake num den) end in + let e := Z.of_int e in + match e with + | Z0 => zq + | Zpos e => IRmult zq (IRZ (IZpow_pos 2 e)) + | Zneg e => IRdiv zq (IRZ (IZpow_pos 2 e)) + end. + +Definition of_number (n : Number.number) : IR := + match n with + | Number.Dec d => of_decimal d + | Number.Hex h => of_hexadecimal h + end. + +Definition to_decimal (n : IR) : option Decimal.decimal := + match n with + | IRZ z => + match IZ_to_Z z with + | Some z => Some (Decimal.Decimal (Z.to_int z) Decimal.Nil) + | None => None + end + | IRQ (Qmake num den) => IQmake_to_decimal num den + | IRmult (IRZ z) (IRZ (IZpow_pos 10 e)) => + match IZ_to_Z z with + | Some z => + Some (Decimal.DecimalExp (Z.to_int z) Decimal.Nil (Pos.to_int e)) + | None => None + end + | IRmult (IRQ (Qmake num den)) (IRZ (IZpow_pos 10 e)) => + match IQmake_to_decimal num den with + | Some (Decimal.Decimal i f) => + Some (Decimal.DecimalExp i f (Pos.to_int e)) + | _ => None + end + | IRdiv (IRZ z) (IRZ (IZpow_pos 10 e)) => + match IZ_to_Z z with + | Some z => + Some (Decimal.DecimalExp (Z.to_int z) Decimal.Nil (Decimal.Neg (Pos.to_uint e))) + | None => None + end + | IRdiv (IRQ (Qmake num den)) (IRZ (IZpow_pos 10 e)) => + match IQmake_to_decimal num den with + | Some (Decimal.Decimal i f) => + Some (Decimal.DecimalExp i f (Decimal.Neg (Pos.to_uint e))) + | _ => None + end + | _ => None + end. + +Definition to_hexadecimal (n : IR) : option Hexadecimal.hexadecimal := + match n with + | IRZ z => + match IZ_to_Z z with + | Some z => Some (Hexadecimal.Hexadecimal (Z.to_hex_int z) Hexadecimal.Nil) + | None => None + end + | IRQ (Qmake num den) => IQmake_to_hexadecimal num den + | IRmult (IRZ z) (IRZ (IZpow_pos 2 e)) => + match IZ_to_Z z with + | Some z => + Some (Hexadecimal.HexadecimalExp (Z.to_hex_int z) Hexadecimal.Nil (Pos.to_int e)) + | None => None + end + | IRmult (IRQ (Qmake num den)) (IRZ (IZpow_pos 2 e)) => + match IQmake_to_hexadecimal num den with + | Some (Hexadecimal.Hexadecimal i f) => + Some (Hexadecimal.HexadecimalExp i f (Pos.to_int e)) + | _ => None + end + | IRdiv (IRZ z) (IRZ (IZpow_pos 2 e)) => + match IZ_to_Z z with + | Some z => + Some (Hexadecimal.HexadecimalExp (Z.to_hex_int z) Hexadecimal.Nil (Decimal.Neg (Pos.to_uint e))) + | None => None + end + | IRdiv (IRQ (Qmake num den)) (IRZ (IZpow_pos 2 e)) => + match IQmake_to_hexadecimal num den with + | Some (Hexadecimal.Hexadecimal i f) => + Some (Hexadecimal.HexadecimalExp i f (Decimal.Neg (Pos.to_uint e))) + | _ => None + end + | _ => None + end. + +Definition to_number q := + match to_decimal q with + | None => None + | Some q => Some (Number.Dec q) + end. + +Definition to_hex_number q := + match to_hexadecimal q with + | None => None + | Some q => Some (Number.Hex q) + end. + +Number Notation R of_number to_hex_number (via IR + mapping [IZR => IRZ, Q2R => IRQ, Rmult => IRmult, Rdiv => IRdiv, + Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) + : hex_R_scope. + +Number Notation R of_number to_number (via IR + mapping [IZR => IRZ, Q2R => IRQ, Rmult => IRmult, Rdiv => IRdiv, + Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) + : R_scope. diff --git a/theories/Reals/Rregisternames.v b/theories/Reals/Rregisternames.v index 8b078f2cf3..8117d975fe 100644 --- a/theories/Reals/Rregisternames.v +++ b/theories/Reals/Rregisternames.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Raxioms Rfunctions Qreals. +Require Import Raxioms Rfunctions. (*****************************************************************) (** Register names for use in plugins *) @@ -31,4 +31,4 @@ Register IZR as reals.R.IZR. Register Rabs as reals.R.Rabs. Register powerRZ as reals.R.powerRZ. Register pow as reals.R.pow. -Register Qreals.Q2R as reals.R.Q2R. +Register Q2R as reals.R.Q2R. diff --git a/theories/dune b/theories/dune index c2d8197ee4..e7e4ba9981 100644 --- a/theories/dune +++ b/theories/dune @@ -17,7 +17,6 @@ coq.plugins.numeral_notation coq.plugins.string_notation coq.plugins.int63_syntax - coq.plugins.r_syntax coq.plugins.float_syntax coq.plugins.btauto -- cgit v1.2.3 From edea770457aea05a7e6a64c1217f66dfc6930419 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:20:00 +0200 Subject: [numeral notation] Specify R --- doc/stdlib/index-list.html.template | 2 ++ theories/Numbers/DecimalR.v | 56 +++++++++++++++++++++++++++++++++++ theories/Numbers/HexadecimalR.v | 58 +++++++++++++++++++++++++++++++++++++ theories/Reals/Rdefinitions.v | 12 ++++++++ 4 files changed, 128 insertions(+) create mode 100644 theories/Numbers/DecimalR.v create mode 100644 theories/Numbers/HexadecimalR.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index e42066d2ce..b08d7e9d2c 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -238,6 +238,7 @@ through the Require Import command.

theories/Numbers/DecimalN.v theories/Numbers/DecimalZ.v theories/Numbers/DecimalQ.v + theories/Numbers/DecimalR.v theories/Numbers/DecimalString.v theories/Numbers/HexadecimalFacts.v theories/Numbers/HexadecimalNat.v @@ -245,6 +246,7 @@ through the Require Import command.

theories/Numbers/HexadecimalN.v theories/Numbers/HexadecimalZ.v theories/Numbers/HexadecimalQ.v + theories/Numbers/HexadecimalR.v theories/Numbers/HexadecimalString.v diff --git a/theories/Numbers/DecimalR.v b/theories/Numbers/DecimalR.v new file mode 100644 index 0000000000..409ca88f1a --- /dev/null +++ b/theories/Numbers/DecimalR.v @@ -0,0 +1,56 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* of_decimal d = q. +Admitted. + +Lemma to_of (d:decimal) : to_decimal (of_decimal d) = Some (dnorm d). +Admitted. + +(** Some consequences *) + +Lemma to_decimal_inj q q' : + to_decimal q <> None -> to_decimal q = to_decimal q' -> q = q'. +Proof. +intros Hnone EQ. +generalize (of_to q) (of_to q'). +rewrite <-EQ. +revert Hnone; case to_decimal; [|now simpl]. +now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). +Qed. + +Lemma to_decimal_surj d : exists q, to_decimal q = Some (dnorm d). +Proof. + exists (of_decimal d). apply to_of. +Qed. + +Lemma of_decimal_dnorm d : of_decimal (dnorm d) = of_decimal d. +Proof. now apply to_decimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. + +Lemma of_inj d d' : of_decimal d = of_decimal d' -> dnorm d = dnorm d'. +Proof. +intro H. +apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). +now rewrite <- !to_of, H. +Qed. + +Lemma of_iff d d' : of_decimal d = of_decimal d' <-> dnorm d = dnorm d'. +Proof. +split. apply of_inj. intros E. rewrite <- of_decimal_dnorm, E. +apply of_decimal_dnorm. +Qed. diff --git a/theories/Numbers/HexadecimalR.v b/theories/Numbers/HexadecimalR.v new file mode 100644 index 0000000000..3a6e2c4992 --- /dev/null +++ b/theories/Numbers/HexadecimalR.v @@ -0,0 +1,58 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* of_hexadecimal d = q. +Admitted. + +Lemma to_of (d:hexadecimal) : to_hexadecimal (of_hexadecimal d) = Some (dnorm d). +Admitted. + +(** Some consequences *) + +Lemma to_hexadecimal_inj q q' : + to_hexadecimal q <> None -> to_hexadecimal q = to_hexadecimal q' -> q = q'. +Proof. +intros Hnone EQ. +generalize (of_to q) (of_to q'). +rewrite <-EQ. +revert Hnone; case to_hexadecimal; [|now simpl]. +now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). +Qed. + +Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (dnorm d). +Proof. + exists (of_hexadecimal d). apply to_of. +Qed. + +Lemma of_hexadecimal_dnorm d : of_hexadecimal (dnorm d) = of_hexadecimal d. +Proof. now apply to_hexadecimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. + +Lemma of_inj d d' : of_hexadecimal d = of_hexadecimal d' -> dnorm d = dnorm d'. +Proof. +intro H. +apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). +now rewrite <- !to_of, H. +Qed. + +Lemma of_iff d d' : of_hexadecimal d = of_hexadecimal d' <-> dnorm d = dnorm d'. +Proof. +split. apply of_inj. intros E. rewrite <- of_hexadecimal_dnorm, E. +apply of_hexadecimal_dnorm. +Qed. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index a4809a7513..ac82216474 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -284,6 +284,12 @@ Definition of_number (n : Number.number) : IR := | Number.Hex h => of_hexadecimal h end. +Definition IQmake_to_decimal num den := + match den with + | 1%positive => None (* this should be encoded as IRZ *) + | _ => IQmake_to_decimal num den + end. + Definition to_decimal (n : IR) : option Decimal.decimal := match n with | IRZ z => @@ -319,6 +325,12 @@ Definition to_decimal (n : IR) : option Decimal.decimal := | _ => None end. +Definition IQmake_to_hexadecimal num den := + match den with + | 1%positive => None (* this should be encoded as IRZ *) + | _ => IQmake_to_hexadecimal num den + end. + Definition to_hexadecimal (n : IR) : option Hexadecimal.hexadecimal := match n with | IRZ z => -- cgit v1.2.3 From b51a8a0257aa18a503f59decc729e1d59650fce2 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:21:00 +0200 Subject: [numeral notation] Prove R --- theories/Numbers/DecimalR.v | 282 ++++++++++++++++++++++++++++++++++++++-- theories/Numbers/HexadecimalR.v | 270 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 526 insertions(+), 26 deletions(-) diff --git a/theories/Numbers/DecimalR.v b/theories/Numbers/DecimalR.v index 409ca88f1a..9b65a7dc20 100644 --- a/theories/Numbers/DecimalR.v +++ b/theories/Numbers/DecimalR.v @@ -15,22 +15,278 @@ Require Import Decimal DecimalFacts DecimalPos DecimalZ DecimalQ Rdefinitions. +Lemma of_IQmake_to_decimal num den : + match IQmake_to_decimal num den with + | None => True + | Some (DecimalExp _ _ _) => False + | Some (Decimal i f) => + of_decimal (Decimal i f) = IRQ (QArith_base.Qmake num den) + end. +Proof. + unfold IQmake_to_decimal. + case (Pos.eq_dec den 1); [now intros->|intro Hden]. + assert (Hf : match QArith_base.IQmake_to_decimal num den with + | Some (Decimal i f) => f <> Nil + | _ => True + end). + { unfold QArith_base.IQmake_to_decimal; simpl. + generalize (Unsigned.nztail_to_uint den). + case Decimal.nztail as [den' e_den']. + case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. + case den'; [ |now simpl..]; clear den'. + case e_den' as [|e_den']; [now simpl; intros H _; apply Hden; injection H|]. + intros _. + case Nat.ltb_spec; intro He_den'. + - apply del_head_nonnil. + revert He_den'; case nb_digits as [|n]; [now simpl|]. + now intro H; simpl; apply le_lt_n_Sm, Nat.le_sub_l. + - apply nb_digits_n0. + now rewrite nb_digits_iter_D0, Nat.sub_add. } + replace (match den with 1%positive => _ | _ => _ end) + with (QArith_base.IQmake_to_decimal num den); [|now revert Hden; case den]. + generalize (of_IQmake_to_decimal num den). + case QArith_base.IQmake_to_decimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + unfold of_decimal; simpl. + intro H; injection H; clear H; intros <-. + intro H; generalize (f_equal QArith_base.IZ_to_Z H); clear H. + rewrite !IZ_to_Z_IZ_of_Z; intro H; injection H; clear H; intros<-. + now revert Hf; case f. +Qed. + Lemma of_to (q:IR) : forall d, to_decimal q = Some d -> of_decimal d = q. -Admitted. +Proof. + intro d. + case q as [z|q|r r'|r r']; simpl. + - case z as [z p| |p|p]. + + now simpl. + + now simpl; intro H; injection H; clear H; intros<-. + + simpl; intro H; injection H; clear H; intros<-. + now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. + + simpl; intro H; injection H; clear H; intros<-. + now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. + - case q as [num den]. + generalize (of_IQmake_to_decimal num den). + case IQmake_to_decimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + now intros H H'; injection H'; intros<-. + - case r as [z|q| |]; [|case q as[num den]|now simpl..]; + (case r' as [z'| | |]; [|now simpl..]); + (case z' as [p e| | |]; [|now simpl..]). + + case (Z.eq_dec p 10); [intros->|intro Hp]. + 2:{ revert Hp; case p; [now simpl|intro d0..]; + (case d0; [intro d1..|]; [now simpl| |now simpl]; + case d1; [intro d2..|]; [|now simpl..]; + case d2; [intro d3..|]; [now simpl| |now simpl]; + now case d3). } + case z as [| |p|p]; [now simpl|..]; intro H; injection H; intros<-. + * now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. + * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. + now rewrite Unsigned.of_to. + * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. + now rewrite Unsigned.of_to. + + case (Z.eq_dec p 10); [intros->|intro Hp]. + 2:{ revert Hp; case p; [now simpl|intro d0..]; + (case d0; [intro d1..|]; [now simpl| |now simpl]; + case d1; [intro d2..|]; [|now simpl..]; + case d2; [intro d3..|]; [now simpl| |now simpl]; + now case d3). } + generalize (of_IQmake_to_decimal num den). + case IQmake_to_decimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros H H'; injection H'; clear H'; intros<-. + unfold of_decimal; simpl. + change (match f with Nil => _ | _ => _ end) with (of_decimal (Decimal i f)). + rewrite H; clear H. + now unfold Z.of_uint; rewrite Unsigned.of_to. + - case r as [z|q| |]; [|case q as[num den]|now simpl..]; + (case r' as [z'| | |]; [|now simpl..]); + (case z' as [p e| | |]; [|now simpl..]). + + case (Z.eq_dec p 10); [intros->|intro Hp]. + 2:{ revert Hp; case p; [now simpl|intro d0..]; + (case d0; [intro d1..|]; [now simpl| |now simpl]; + case d1; [intro d2..|]; [|now simpl..]; + case d2; [intro d3..|]; [now simpl| |now simpl]; + now case d3). } + case z as [| |p|p]; [now simpl|..]; intro H; injection H; intros<-. + * now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. + * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. + now rewrite Unsigned.of_to. + * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. + now rewrite Unsigned.of_to. + + case (Z.eq_dec p 10); [intros->|intro Hp]. + 2:{ revert Hp; case p; [now simpl|intro d0..]; + (case d0; [intro d1..|]; [now simpl| |now simpl]; + case d1; [intro d2..|]; [|now simpl..]; + case d2; [intro d3..|]; [now simpl| |now simpl]; + now case d3). } + generalize (of_IQmake_to_decimal num den). + case IQmake_to_decimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros H H'; injection H'; clear H'; intros<-. + unfold of_decimal; simpl. + change (match f with Nil => _ | _ => _ end) with (of_decimal (Decimal i f)). + rewrite H; clear H. + now unfold Z.of_uint; rewrite Unsigned.of_to. +Qed. Lemma to_of (d:decimal) : to_decimal (of_decimal d) = Some (dnorm d). -Admitted. +Proof. + case d as [i f|i f e]. + - unfold of_decimal; simpl. + case (uint_eq_dec f Nil); intro Hf. + + rewrite Hf; clear f Hf. + unfold to_decimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + + set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_decimal; simpl. + unfold IQmake_to_decimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_decimal, n; simpl. + rewrite nztail_to_uint_pow10. + clear r; set (r := if _ _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite DecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + * rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + * rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + - unfold of_decimal; simpl. + rewrite <-(DecimalZ.to_of e). + case (Z.of_int e); clear e; [|intro e..]; simpl. + + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_decimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_decimal; simpl. + unfold IQmake_to_decimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_decimal, n; simpl. + rewrite nztail_to_uint_pow10. + clear r; set (r := if _ _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite DecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match Pos.to_uint e with Nil => _ | _ => _ end). + replace m with (DecimalExp i' f (Pos (Pos.to_uint e))). + 2:{ unfold m; generalize (Unsigned.to_uint_nonzero e). + now case Pos.to_uint; [|intro u; case u|..]. } + unfold i'; clear i' m. + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_decimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_decimal; simpl. + unfold IQmake_to_decimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_decimal, n; simpl. + rewrite nztail_to_uint_pow10. + clear r; set (r := if _ _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite DecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_decimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_decimal; simpl. + unfold IQmake_to_decimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_decimal, n; simpl. + rewrite nztail_to_uint_pow10. + clear r; set (r := if _ _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite DecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. +Qed. (** Some consequences *) Lemma to_decimal_inj q q' : to_decimal q <> None -> to_decimal q = to_decimal q' -> q = q'. Proof. -intros Hnone EQ. -generalize (of_to q) (of_to q'). -rewrite <-EQ. -revert Hnone; case to_decimal; [|now simpl]. -now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). + intros Hnone EQ. + generalize (of_to q) (of_to q'). + rewrite <-EQ. + revert Hnone; case to_decimal; [|now simpl]. + now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). Qed. Lemma to_decimal_surj d : exists q, to_decimal q = Some (dnorm d). @@ -43,14 +299,14 @@ Proof. now apply to_decimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qe Lemma of_inj d d' : of_decimal d = of_decimal d' -> dnorm d = dnorm d'. Proof. -intro H. -apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) - (Some (dnorm d)) (Some (dnorm d'))). -now rewrite <- !to_of, H. + intro H. + apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). + now rewrite <- !to_of, H. Qed. Lemma of_iff d d' : of_decimal d = of_decimal d' <-> dnorm d = dnorm d'. Proof. -split. apply of_inj. intros E. rewrite <- of_decimal_dnorm, E. -apply of_decimal_dnorm. + split. apply of_inj. intros E. rewrite <- of_decimal_dnorm, E. + apply of_decimal_dnorm. Qed. diff --git a/theories/Numbers/HexadecimalR.v b/theories/Numbers/HexadecimalR.v index 3a6e2c4992..2deecc5847 100644 --- a/theories/Numbers/HexadecimalR.v +++ b/theories/Numbers/HexadecimalR.v @@ -17,22 +17,266 @@ Require Import Decimal DecimalFacts. Require Import Hexadecimal HexadecimalFacts HexadecimalPos HexadecimalZ. Require Import HexadecimalQ Rdefinitions. +Lemma of_IQmake_to_hexadecimal num den : + match IQmake_to_hexadecimal num den with + | None => True + | Some (HexadecimalExp _ _ _) => False + | Some (Hexadecimal i f) => + of_hexadecimal (Hexadecimal i f) = IRQ (QArith_base.Qmake num den) + end. +Proof. + unfold IQmake_to_hexadecimal. + case (Pos.eq_dec den 1); [now intros->|intro Hden]. + assert (Hf : match QArith_base.IQmake_to_hexadecimal num den with + | Some (Hexadecimal i f) => f <> Nil + | _ => True + end). + { unfold QArith_base.IQmake_to_hexadecimal; simpl. + generalize (Unsigned.nztail_to_hex_uint den). + case Hexadecimal.nztail as [den' e_den']. + case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. + case den'; [ |now simpl..]; clear den'. + case e_den' as [|e_den']; [now simpl; intros H _; apply Hden; injection H|]. + intros _. + case Nat.ltb_spec; intro He_den'. + - apply del_head_nonnil. + revert He_den'; case nb_digits as [|n]; [now simpl|]. + now intro H; simpl; apply le_lt_n_Sm, Nat.le_sub_l. + - apply nb_digits_n0. + now rewrite nb_digits_iter_D0, Nat.sub_add. } + replace (match den with 1%positive => _ | _ => _ end) + with (QArith_base.IQmake_to_hexadecimal num den); [|now revert Hden; case den]. + generalize (of_IQmake_to_hexadecimal num den). + case QArith_base.IQmake_to_hexadecimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + unfold of_hexadecimal; simpl. + intro H; injection H; clear H; intros <-. + intro H; generalize (f_equal QArith_base.IZ_to_Z H); clear H. + rewrite !IZ_to_Z_IZ_of_Z; intro H; injection H; clear H; intros<-. + now revert Hf; case f. +Qed. + Lemma of_to (q:IR) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. -Admitted. +Proof. + intro d. + case q as [z|q|r r'|r r']; simpl. + - case z as [z p| |p|p]. + + now simpl. + + now simpl; intro H; injection H; clear H; intros<-. + + simpl; intro H; injection H; clear H; intros<-. + now unfold of_hexadecimal; simpl; unfold Z.of_hex_uint; rewrite Unsigned.of_to. + + simpl; intro H; injection H; clear H; intros<-. + now unfold of_hexadecimal; simpl; unfold Z.of_hex_uint; rewrite Unsigned.of_to. + - case q as [num den]. + generalize (of_IQmake_to_hexadecimal num den). + case IQmake_to_hexadecimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + now intros H H'; injection H'; intros<-. + - case r as [z|q| |]; [|case q as[num den]|now simpl..]; + (case r' as [z'| | |]; [|now simpl..]); + (case z' as [p e| | |]; [|now simpl..]). + + case (Z.eq_dec p 2); [intros->|intro Hp]. + 2:{ now revert Hp; case p; + [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } + case z as [| |p|p]; [now simpl|..]; intro H; injection H; intros<-. + * now unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. + * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + now unfold Z.of_hex_uint; rewrite Unsigned.of_to. + * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + now unfold Z.of_hex_uint; rewrite Unsigned.of_to. + + case (Z.eq_dec p 2); [intros->|intro Hp]. + 2:{ now revert Hp; case p; + [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } + generalize (of_IQmake_to_hexadecimal num den). + case IQmake_to_hexadecimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros H H'; injection H'; clear H'; intros<-. + unfold of_hexadecimal; simpl. + change (match f with Nil => _ | _ => _ end) with (of_hexadecimal (Hexadecimal i f)). + rewrite H; clear H. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. + - case r as [z|q| |]; [|case q as[num den]|now simpl..]; + (case r' as [z'| | |]; [|now simpl..]); + (case z' as [p e| | |]; [|now simpl..]). + + case (Z.eq_dec p 2); [intros->|intro Hp]. + 2:{ now revert Hp; case p; + [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } + case z as [| |p|p]; [now simpl|..]; intro H; injection H; intros<-. + * now unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. + * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + now unfold Z.of_hex_uint; rewrite Unsigned.of_to. + * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + now unfold Z.of_hex_uint; rewrite Unsigned.of_to. + + case (Z.eq_dec p 2); [intros->|intro Hp]. + 2:{ now revert Hp; case p; + [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } + generalize (of_IQmake_to_hexadecimal num den). + case IQmake_to_hexadecimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros H H'; injection H'; clear H'; intros<-. + unfold of_hexadecimal; simpl. + change (match f with Nil => _ | _ => _ end) with (of_hexadecimal (Hexadecimal i f)). + rewrite H; clear H. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. +Qed. Lemma to_of (d:hexadecimal) : to_hexadecimal (of_hexadecimal d) = Some (dnorm d). -Admitted. +Proof. + case d as [i f|i f e]. + - unfold of_hexadecimal; simpl. + case (uint_eq_dec f Nil); intro Hf. + + rewrite Hf; clear f Hf. + unfold to_hexadecimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + + set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_hexadecimal; simpl. + unfold IQmake_to_hexadecimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_hexadecimal, n; simpl. + rewrite nztail_to_hex_uint_pow16. + clear r; set (r := if _ _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + * rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + * rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + - unfold of_hexadecimal; simpl. + rewrite <-(DecimalZ.to_of e). + case (Z.of_int e); clear e; [|intro e..]; simpl. + + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_hexadecimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_hexadecimal; simpl. + unfold IQmake_to_hexadecimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_hexadecimal, n; simpl. + rewrite nztail_to_hex_uint_pow16. + clear r; set (r := if _ _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match Pos.to_uint e with Decimal.Nil => _ | _ => _ end). + replace m with (HexadecimalExp i' f (Decimal.Pos (Pos.to_uint e))). + 2:{ unfold m; generalize (DecimalPos.Unsigned.to_uint_nonzero e). + now case Pos.to_uint; [|intro u; case u|..]. } + unfold i'; clear i' m. + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_hexadecimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_hexadecimal; simpl. + unfold IQmake_to_hexadecimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_hexadecimal, n; simpl. + rewrite nztail_to_hex_uint_pow16. + clear r; set (r := if _ _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_hexadecimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_hexadecimal; simpl. + unfold IQmake_to_hexadecimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_hexadecimal, n; simpl. + rewrite nztail_to_hex_uint_pow16. + clear r; set (r := if _ _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. +Qed. (** Some consequences *) Lemma to_hexadecimal_inj q q' : to_hexadecimal q <> None -> to_hexadecimal q = to_hexadecimal q' -> q = q'. Proof. -intros Hnone EQ. -generalize (of_to q) (of_to q'). -rewrite <-EQ. -revert Hnone; case to_hexadecimal; [|now simpl]. -now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). + intros Hnone EQ. + generalize (of_to q) (of_to q'). + rewrite <-EQ. + revert Hnone; case to_hexadecimal; [|now simpl]. + now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). Qed. Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (dnorm d). @@ -45,14 +289,14 @@ Proof. now apply to_hexadecimal_inj; rewrite !to_of; [|rewrite dnorm_involutive] Lemma of_inj d d' : of_hexadecimal d = of_hexadecimal d' -> dnorm d = dnorm d'. Proof. -intro H. -apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) - (Some (dnorm d)) (Some (dnorm d'))). -now rewrite <- !to_of, H. + intro H. + apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). + now rewrite <- !to_of, H. Qed. Lemma of_iff d d' : of_hexadecimal d = of_hexadecimal d' <-> dnorm d = dnorm d'. Proof. -split. apply of_inj. intros E. rewrite <- of_hexadecimal_dnorm, E. -apply of_hexadecimal_dnorm. + split. apply of_inj. intros E. rewrite <- of_hexadecimal_dnorm, E. + apply of_hexadecimal_dnorm. Qed. -- cgit v1.2.3 From 9082af80f5bb70ff2b75117f9e5cc3165b1c8b42 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:22:00 +0200 Subject: [numeral notation] Allow to put/ignore holes during pre/postprocessing This will enable to handle implicit arguments by ignoring them during preprocessing (before uninterpreting (i.e., printing)) and remplace them with holes `_` during postprocessing (after interpreting (i.e., parsing)). --- interp/notation.ml | 22 +++++++++++++++------- interp/notation.mli | 4 +++- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/interp/notation.ml b/interp/notation.ml index 073a1d24fc..0f149c5f50 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -552,8 +552,10 @@ type 'target conversion_kind = 'target * option_kind are translated acording to [args] where [ToPostCopy] means that the argument is kept unchanged and [ToPostAs k] means that the argument is recursively translated according to [l_k]. + [ToPostHole] introduces an additional implicit argument hole + (in the reverse translation, the corresponding argument is removed). When [n] is null, no translation is performed. *) -type to_post_arg = ToPostCopy | ToPostAs of int +type to_post_arg = ToPostCopy | ToPostAs of int | ToPostHole type ('target, 'warning) prim_token_notation_obj = { to_kind : 'target conversion_kind; to_ty : GlobRef.t; @@ -625,8 +627,9 @@ let rec constr_of_glob to_post post env sigma g = match DAst.get g with | None -> constr_of_globref false env sigma r | Some (r, _, a) -> (* [g] is not a GApp so check that [post] - does not expect any argument (i.e., a = []) *) - if a <> [] then raise NotAValidPrimToken; + does not expect any actual argument + (i.e., [a] contains only ToPostHole since they mean "ignore arg") *) + if List.exists ((<>) ToPostHole) a then raise NotAValidPrimToken; constr_of_globref true env sigma r end | Glob_term.GApp (gc, gcl) -> @@ -650,6 +653,7 @@ let rec constr_of_glob to_post post env sigma g = match DAst.get g with let sigma,c = constr_of_glob to_post to_post.(i) env sigma gc in let sigma,cl = aux sigma a gcl in sigma, c :: cl + | ToPostHole :: post, _ :: gcl -> aux sigma post gcl | [], _ :: _ | _ :: _, [] -> raise NotAValidPrimToken in let sigma,cl = aux sigma a gcl in @@ -695,15 +699,19 @@ let rec postprocess token_kind ?loc ty to_post post g = List.find_opt (fun (r',_,_) -> GlobRef.equal r r') post | _ -> None in match o with None -> g | Some (_, r, a) -> - let rec f a gl = match a, gl with + let rec f n a gl = match a, gl with | [], [] -> [] - | ToPostCopy :: a, g :: gl -> g :: f a gl + | ToPostHole :: a, gl -> + let e = Evar_kinds.ImplicitArg (r, (n, None), true) in + let h = DAst.make ?loc (Glob_term.GHole (e, Namegen.IntroAnonymous, None)) in + h :: f (n+1) a gl + | ToPostCopy :: a, g :: gl -> g :: f (n+1) a gl | ToPostAs c :: a, g :: gl -> - postprocess token_kind ?loc ty to_post to_post.(c) g :: f a gl + postprocess token_kind ?loc ty to_post to_post.(c) g :: f (n+1) a gl | [], _::_ | _::_, [] -> no_such_prim_token token_kind ?loc ty in - let gl = f a gl in + let gl = f 1 a gl in let g = DAst.make ?loc (Glob_term.GRef (r, None)) in DAst.make ?loc (Glob_term.GApp (g, gl)) diff --git a/interp/notation.mli b/interp/notation.mli index 44143e392f..012aaac8f0 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -164,8 +164,10 @@ type 'target conversion_kind = 'target * option_kind are translated acording to [args] where [ToPostCopy] means that the argument is kept unchanged and [ToPostAs k] means that the argument is recursively translated according to [l_k]. + [ToPostHole] introduces an additional implicit argument hole + (in the reverse translation, the corresponding argument is removed). When [n] is null, no translation is performed. *) -type to_post_arg = ToPostCopy | ToPostAs of int +type to_post_arg = ToPostCopy | ToPostAs of int | ToPostHole type ('target, 'warning) prim_token_notation_obj = { to_kind : 'target conversion_kind; to_ty : GlobRef.t; -- cgit v1.2.3 From 0520decfdc94d52a2f8658b9cf6a730e6d333f8f Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:23:00 +0200 Subject: [numeral notation] Handle implicit arguments --- doc/sphinx/user-extensions/syntax-extensions.rst | 74 +++++++++++++++++++++++- doc/tools/docgram/fullGrammar | 1 + doc/tools/docgram/orderedGrammar | 2 +- plugins/syntax/g_numeral.mlg | 12 +++- plugins/syntax/numeral.ml | 51 ++++++++++------ plugins/syntax/numeral.mli | 2 +- 6 files changed, 118 insertions(+), 24 deletions(-) diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index f07eb02946..4c6d300b13 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1562,7 +1562,7 @@ Number notations number_modifier ::= warning after @bignat | abstract after @bignat | @number_via - number_via ::= via @qualid mapping [ {+, @qualid => @qualid } ] + number_via ::= via @qualid mapping [ {+, {| @qualid => @qualid | [ @qualid ] => @qualid } } ] This command allows the user to customize the way number literals are parsed and printed. @@ -1619,6 +1619,26 @@ Number notations :n:`@qualid__type` is then replaced by :n:`@qualid__ind` in the above parser and printer types. + When :n:`@qualid__constant` is surrounded by square brackets, + all the implicit arguments of :n:`@qualid__constant` (whether maximally inserted or not) are ignored + when translating to :n:`@qualid__constructor` (i.e., before + applying :n:`@qualid__print`) and replaced with implicit + argument holes :g:`_` when translating from + :n:`@qualid__constructor` to :n:`@qualid__constant` (after + :n:`@qualid__parse`). See below for an :ref:`example `. + + .. note:: + The implicit status of the arguments is considered + only at notation declaration time, any further + modification of this status has no impact + on the previously declared notations. + + .. note:: + In case of multiple implicit options (for instance + :g:`Arguments eq_refl {A}%type_scope {x}, [_] _`), an + argument is considered implicit when it is implicit in any of the + options. + .. note:: To use a :token:`sort` as the target type :n:`@qualid__type`, use an :ref:`abbreviation ` as in the :ref:`example below `. @@ -1775,6 +1795,58 @@ Number notations Set Printing All. Check 3. + .. _example-number-notation-implicit-args: + + .. example:: Number Notation with implicit arguments + + The following example parses and prints natural numbers between + :g:`0` and :g:`n-1` as terms of type :g:`Fin.t n`. + + .. coqtop:: all reset + + Require Import Vector. + Print Fin.t. + + Note the implicit arguments of :g:`Fin.F1` and :g:`Fin.FS`, + which won't appear in the corresponding inductive type. + + .. coqtop:: in + + Inductive I := I1 : I | IS : I -> I. + + Definition of_uint (x : Number.uint) : I := + let fix f n := match n with O => I1 | S n => IS (f n) end in + f (Nat.of_num_uint x). + + Definition to_uint (x : I) : Number.uint := + let fix f i := match i with I1 => O | IS n => S (f n) end in + Nat.to_num_uint (f x). + + Declare Scope fin_scope. + Delimit Scope fin_scope with fin. + Local Open Scope fin_scope. + Number Notation Fin.t of_uint to_uint (via I + mapping [[Fin.F1] => I1, [Fin.FS] => IS]) : fin_scope. + + Now :g:`2` is parsed as :g:`Fin.FS (Fin.FS Fin.F1)`, that is + :g:`@Fin.FS _ (@Fin.FS _ (@Fin.F1 _))`. + + .. coqtop:: all + + Check 2. + + which can be of type :g:`Fin.t 3` (numbers :g:`0`, :g:`1` and :g:`2`) + + .. coqtop:: all + + Check 2 : Fin.t 3. + + but cannot be of type :g:`Fin.t 2` (only :g:`0` and :g:`1`) + + .. coqtop:: all fail + + Check 2 : Fin.t 2. + .. _string-notations: String notations diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 17fc220f6c..3a0c3a8bc7 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -2557,6 +2557,7 @@ deprecated_number_modifier: [ number_mapping: [ | reference "=>" reference +| "[" reference "]" "=>" reference ] number_via: [ diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 3d1041e592..13d8979208 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -1282,7 +1282,7 @@ number_modifier: [ ] number_via: [ -| "via" qualid "mapping" "[" LIST1 ( qualid "=>" qualid ) SEP "," "]" +| "via" qualid "mapping" "[" LIST1 [ qualid "=>" qualid | "[" qualid "]" "=>" qualid ] SEP "," "]" ] hints_path: [ diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index e60ae45b01..a3cc786a4a 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -31,8 +31,13 @@ let warn_deprecated_numeral_notation = (fun () -> strbrk "Numeral Notation is deprecated, please use Number Notation instead.") -let pr_number_mapping (n, n') = - Libnames.pr_qualid n ++ spc () ++ str "=>" ++ spc () ++ Libnames.pr_qualid n' +let pr_number_mapping (b, n, n') = + if b then + str "[" ++ Libnames.pr_qualid n ++ str "]" ++ spc () ++ str "=>" ++ spc () + ++ Libnames.pr_qualid n' + else + Libnames.pr_qualid n ++ spc () ++ str "=>" ++ spc () + ++ Libnames.pr_qualid n' let pr_number_via (n, l) = str "via " ++ Libnames.pr_qualid n ++ str " mapping [" @@ -56,7 +61,8 @@ END VERNAC ARGUMENT EXTEND number_mapping PRINTED BY { pr_number_mapping } -| [ reference(n) "=>" reference(n') ] -> { n, n' } +| [ reference(n) "=>" reference(n') ] -> { false, n, n' } +| [ "[" reference(n) "]" "=>" reference(n') ] -> { true, n, n' } END VERNAC ARGUMENT EXTEND number_via diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 316ca456a4..1efe6b77d1 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -21,7 +21,7 @@ module CMap = CMap.Make (Constr) (** * Number notation *) -type number_string_via = qualid * (qualid * qualid) list +type number_string_via = qualid * (bool * qualid * qualid) list type number_option = | After of numnot_option | Via of number_string_via @@ -231,9 +231,10 @@ let elaborate_to_post env sigma ty_name ty_ind l = For each constant [cnst] and inductive constructor [indc] in [l], retrieve: * its location: [lcnst] and [lindc] * its GlobRef: [cnst] and [indc] - * its type: [tcnst] and [tindc] (decomposed in product by [get_type] above) *) + * its type: [tcnst] and [tindc] (decomposed in product by [get_type] above) + * [impls] are the implicit arguments of [cnst] *) let l = - let read (cnst, indc) = + let read (consider_implicits, cnst, indc) = let lcnst, lindc = cnst.CAst.loc, indc.CAst.loc in let cnst, ccnst = locate_global_constructor_inductive_or_constant cnst in let indc, cindc = @@ -247,13 +248,16 @@ let elaborate_to_post env sigma ty_name ty_ind l = let lc, tc = get_type env sigma c in List.map (fun (n, c) -> n, rm_params c) lc, rm_params tc in let tcnst, tindc = get_type_wo_params ccnst, get_type_wo_params cindc in - lcnst, cnst, tcnst, lindc, indc, tindc in + let impls = + if not consider_implicits then [] else + Impargs.(select_stronger_impargs (implicits_of_global cnst)) in + lcnst, cnst, tcnst, lindc, indc, tindc, impls in List.map read l in - let eq_indc indc (_, _, _, _, indc', _) = GlobRef.equal indc indc' in + let eq_indc indc (_, _, _, _, indc', _, _) = GlobRef.equal indc indc' in (* Collect all inductive types involved. That is [ty_ind] and all final codomains of [tindc] above. *) let inds = - List.fold_left (fun s (_, _, _, _, _, tindc) -> CSet.add (snd tindc) s) + List.fold_left (fun s (_, _, _, _, _, tindc, _) -> CSet.add (snd tindc) s) (CSet.singleton ty_ind) l in (* And for each inductive, retrieve its constructors. *) let constructors = @@ -264,7 +268,7 @@ let elaborate_to_post env sigma ty_name ty_ind l = (* Error if one [constructor] in some inductive in [inds] doesn't appear exactly once in [l] *) let _ = (* check_for duplicate constructor and error *) - List.fold_left (fun already_seen (_, cnst, _, loc, indc, _) -> + List.fold_left (fun already_seen (_, cnst, _, loc, indc, _, _) -> try let cnst' = List.assoc_f GlobRef.equal indc already_seen in remapping_error ?loc indc cnst' cnst @@ -289,16 +293,23 @@ let elaborate_to_post env sigma ty_name ty_ind l = warn_via_remapping ?loc (env, sigma, ckey, old_cval, cval); m in List.fold_left - (fun (ind2ty, ty2ind) (lcnst, _, (_, tcnst), lindc, _, (_, tindc)) -> + (fun (ind2ty, ty2ind) (lcnst, _, (_, tcnst), lindc, _, (_, tindc), _) -> add lcnst tindc tcnst ind2ty, add lindc tcnst tindc ty2ind) CMap.(singleton ty_ind ty_name, singleton ty_name ty_ind) l in (* check that type of constants and constructors mapped in [l] match modulo [ind2ty] *) + let rm_impls impls (l, t) = + let rec aux impls l = match impls, l with + | Some _ :: impls, _ :: b -> aux impls b + | None :: impls, (n, a) :: b -> (n, a) :: aux impls b + | _ -> l in + aux impls l, t in let replace m (l, t) = let apply_m c = try CMap.find c m with Not_found -> c in List.fold_right (fun (na, a) b -> Constr.mkProd (na, (apply_m a), b)) l (apply_m t) in - List.iter (fun (_, cnst, tcnst, loc, indc, tindc) -> + List.iter (fun (_, cnst, tcnst, loc, indc, tindc, impls) -> + let tcnst = rm_impls impls tcnst in let tcnst' = replace CMap.empty tcnst in if not (Constr.equal tcnst' (replace ind2ty tindc)) then let actual = replace CMap.empty tindc in @@ -313,17 +324,21 @@ let elaborate_to_post env sigma ty_name ty_ind l = (CMap.singleton ty_ind 0, Int.Map.singleton 0 ty_ind, 1) in (* Finally elaborate [to_post] *) let to_post = - let rec map_prod = function - | [] -> [] - | (_, a) :: b -> - let t = match CMap.find_opt a ind2num with - | Some i -> ToPostAs i - | None -> ToPostCopy in - t :: map_prod b in + let rec map_prod impls tindc = match impls with + | Some _ :: impls -> ToPostHole :: map_prod impls tindc + | _ -> + match tindc with + | [] -> [] + | (_, a) :: b -> + let t = match CMap.find_opt a ind2num with + | Some i -> ToPostAs i + | None -> ToPostCopy in + let impls = match impls with [] -> [] | _ :: t -> t in + t :: map_prod impls b in Array.init nb_ind (fun i -> List.map (fun indc -> - let _, cnst, _, _, _, tindc = List.find (eq_indc indc) l in - indc, cnst, map_prod (fst tindc)) + let _, cnst, _, _, _, tindc, impls = List.find (eq_indc indc) l in + indc, cnst, map_prod impls (fst tindc)) (CMap.find (Int.Map.find i num2ind) constructors)) in (* and use constants mapped to constructors of [ty_ind] as triggers. *) let pt_refs = List.map (fun (_, cnst, _) -> cnst) (to_post.(0)) in diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli index 1f6896d549..5a13d1068b 100644 --- a/plugins/syntax/numeral.mli +++ b/plugins/syntax/numeral.mli @@ -14,7 +14,7 @@ open Notation (** * Number notation *) -type number_string_via = qualid * (qualid * qualid) list +type number_string_via = qualid * (bool * qualid * qualid) list type number_option = | After of numnot_option | Via of number_string_via -- cgit v1.2.3 From 036117fa4992debb42e8346a48f6259f504793d3 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:24:00 +0200 Subject: [numeral notation] Add tests for implicit arguments --- test-suite/output/NumberNotations.out | 169 +++++++++++++++++++++++++++++++++ test-suite/output/NumberNotations.v | 173 ++++++++++++++++++++++++++++++++++ 2 files changed, 342 insertions(+) diff --git a/test-suite/output/NumberNotations.out b/test-suite/output/NumberNotations.out index 3d9d03ef1a..357119f74e 100644 --- a/test-suite/output/NumberNotations.out +++ b/test-suite/output/NumberNotations.out @@ -276,6 +276,71 @@ This might yield ill typed terms when using the notation. [via-type-mismatch,numbers] The command has indeed failed with message: 'via' and 'abstract' cannot be used together. +File "stdin", line 659, characters 21-23: +Warning: Type of I1 seems incompatible with the type of Fin.F1. +Expected type is: (nat -> I) instead of I. +This might yield ill typed terms when using the notation. +[via-type-mismatch,numbers] +File "stdin", line 659, characters 35-37: +Warning: Type of IS seems incompatible with the type of Fin.FS. +Expected type is: (nat -> I -> I) instead of (I -> I). +This might yield ill typed terms when using the notation. +[via-type-mismatch,numbers] +The command has indeed failed with message: +The term "0" has type "forall n : nat, Fin.t (S n)" +while it is expected to have type "nat". +0 + : Fin.t (S ?n) +where +?n : [ |- nat] +1 + : Fin.t (S (S ?n)) +where +?n : [ |- nat] +2 + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat] +3 + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat] +0 : Fin.t 3 + : Fin.t 3 +1 : Fin.t 3 + : Fin.t 3 +2 : Fin.t 3 + : Fin.t 3 +The command has indeed failed with message: +The term "3" has type "Fin.t (S (S (S (S ?n))))" +while it is expected to have type "Fin.t 3". +@Fin.F1 ?n + : Fin.t (S ?n) +where +?n : [ |- nat] +@Fin.FS (S ?n) (@Fin.F1 ?n) + : Fin.t (S (S ?n)) +where +?n : [ |- nat] +@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)) + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat] +@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n))) + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat] +@Fin.F1 (S (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.F1 (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.FS (S O) (@Fin.F1 O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +The command has indeed failed with message: +The term + "@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)))" +has type "Fin.t (S (S (S (S ?n))))" while it is expected to have type + "Fin.t (S (S (S O)))". 0 : Set 1 @@ -292,3 +357,107 @@ sum unit unit : Set sum unit (sum unit unit) : Set +0 + : Fin.t (S ?n) +where +?n : [ |- nat] +1 + : Fin.t (S (S ?n)) +where +?n : [ |- nat] +2 + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat] +3 + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat] +0 : Fin.t 3 + : Fin.t 3 +1 : Fin.t 3 + : Fin.t 3 +2 : Fin.t 3 + : Fin.t 3 +The command has indeed failed with message: +The term "3" has type "Fin.t (S (S (S (S ?n))))" +while it is expected to have type "Fin.t 3". +@Fin.F1 ?n + : Fin.t (S ?n) +where +?n : [ |- nat] +@Fin.FS (S ?n) (@Fin.F1 ?n) + : Fin.t (S (S ?n)) +where +?n : [ |- nat] +@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)) + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat] +@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n))) + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat] +@Fin.F1 (S (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.F1 (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.FS (S O) (@Fin.F1 O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +The command has indeed failed with message: +The term + "@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)))" +has type "Fin.t (S (S (S (S ?n))))" while it is expected to have type + "Fin.t (S (S (S O)))". +0 + : Fin.t (S ?n) +where +?n : [ |- nat : Set] +1 + : Fin.t (S (S ?n)) +where +?n : [ |- nat : Set] +2 + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat : Set] +3 + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat : Set] +0 : Fin.t 3 + : Fin.t 3 +1 : Fin.t 3 + : Fin.t 3 +2 : Fin.t 3 + : Fin.t 3 +The command has indeed failed with message: +The term "3" has type "Fin.t (S (S (S (S ?n))))" +while it is expected to have type "Fin.t 3". +@Fin.F1 ?n + : Fin.t (S ?n) +where +?n : [ |- nat : Set] +@Fin.FS (S ?n) (@Fin.F1 ?n) + : Fin.t (S (S ?n)) +where +?n : [ |- nat : Set] +@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)) + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat : Set] +@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n))) + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat : Set] +@Fin.F1 (S (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.F1 (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.FS (S O) (@Fin.F1 O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +The command has indeed failed with message: +The term + "@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)))" +has type "Fin.t (S (S (S (S ?n))))" while it is expected to have type + "Fin.t (S (S (S O)))". diff --git a/test-suite/output/NumberNotations.v b/test-suite/output/NumberNotations.v index 88dc41f4e9..bfcad2621a 100644 --- a/test-suite/output/NumberNotations.v +++ b/test-suite/output/NumberNotations.v @@ -626,6 +626,66 @@ Number Notation foo'' foo''_of_uint foo''_to_uint (via foo'' mapping [bar'' => b End Test23. +(* Test the via ... mapping ... option with implicit arguments *) +Require Vector. +Module Test24. + +Import Vector. + +Inductive I := +| I1 : I +| IS : I -> I. + +Definition of_uint (x : Number.uint) : I := + let fix f n := + match n with + | O => I1 + | S n => IS (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : I) : Number.uint := + let fix f i := + match i with + | I1 => O + | IS n => S (f n) + end in + Nat.to_num_uint (f x). + +Local Open Scope type_scope. + +(* ignoring implicit arguments doesn't work *) +Number Notation Fin.t of_uint to_uint (via I + mapping [Fin.F1 => I1, Fin.FS => IS]) + : type_scope. + +Fail Check 1. + +Number Notation Fin.t of_uint to_uint (via I + mapping [[Fin.F1] => I1, [Fin.FS] => IS]) + : type_scope. + +Check Fin.F1. +Check Fin.FS Fin.F1. +Check Fin.FS (Fin.FS Fin.F1). +Check Fin.FS (Fin.FS (Fin.FS Fin.F1)). +Check Fin.F1 : Fin.t 3. +Check Fin.FS Fin.F1 : Fin.t 3. +Check Fin.FS (Fin.FS Fin.F1) : Fin.t 3. +Fail Check Fin.FS (Fin.FS (Fin.FS Fin.F1)) : Fin.t 3. +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Check 0 : Fin.t 3. +Check 1 : Fin.t 3. +Check 2 : Fin.t 3. +Fail Check 3 : Fin.t 3. +Unset Printing All. + +End Test24. + (* Test the via ... mapping ... option with let-binders, beta-redexes, delta-redexes, etc *) Module Test26. @@ -672,3 +732,116 @@ Check 2. Check 3. Unset Printing All. End Test26. + +(* Test the via ... mapping ... option with implicit arguments with let binders, etc *) +Module Test27. + +Module Fin. +Inductive t0 (x:=O) := +with + t (x:=O) : forall y : nat, let z := y in Set := +| F1 (y:=O) {n} : match y with O => t (S n) | _ => Empty_set end +| FS (y:=x) {n} (v:=n+y) (m:=n) : id (match y with O => id (t n) | _ => Empty_set end -> (fun x => x) t (S m)) +with t' (x:=O) := . +End Fin. + +Inductive I (dummy:=O) := +| I1 : I +| IS : let x := I in id x -> I. + +Definition of_uint (x : Number.uint) : I := + let fix f n := + match n with + | O => I1 + | S n => IS (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : I) : Number.uint := + let fix f i := + match i with + | I1 => O + | IS n => S (f n) + end in + Nat.to_num_uint (f x). + +Local Open Scope type_scope. + +Number Notation Fin.t of_uint to_uint (via I + mapping [[Fin.F1] => I1, [Fin.FS] => IS]) + : type_scope. + +Check Fin.F1. +Check Fin.FS Fin.F1. +Check Fin.FS (Fin.FS Fin.F1). +Check Fin.FS (Fin.FS (Fin.FS Fin.F1)). +Check Fin.F1 : Fin.t 3. +Check Fin.FS Fin.F1 : Fin.t 3. +Check Fin.FS (Fin.FS Fin.F1) : Fin.t 3. +Fail Check Fin.FS (Fin.FS (Fin.FS Fin.F1)) : Fin.t 3. +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Check 0 : Fin.t 3. +Check 1 : Fin.t 3. +Check 2 : Fin.t 3. +Fail Check 3 : Fin.t 3. +Unset Printing All. + +End Test27. + +Module Test28. +Module Fin. +Inductive t : nat -> Set := +| F1 {n : (nat : Set)} : (t (S n) : Set) +| FS {n : (nat : Set)} : (t n : Set) -> (t (S n) : Set). +End Fin. + +Inductive I := +| I1 : I +| IS : I -> I. + +Definition of_uint (x : Number.uint) : I := + let fix f n := + match n with + | O => I1 + | S n => IS (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : I) : Number.uint := + let fix f i := + match i with + | I1 => O + | IS n => S (f n) + end in + Nat.to_num_uint (f x). + +Local Open Scope type_scope. + +Number Notation Fin.t of_uint to_uint (via I + mapping [[Fin.F1] => I1, [Fin.FS] => IS]) + : type_scope. + +Check Fin.F1. +Check Fin.FS Fin.F1. +Check Fin.FS (Fin.FS Fin.F1). +Check Fin.FS (Fin.FS (Fin.FS Fin.F1)). +Check Fin.F1 : Fin.t 3. +Check Fin.FS Fin.F1 : Fin.t 3. +Check Fin.FS (Fin.FS Fin.F1) : Fin.t 3. +Fail Check Fin.FS (Fin.FS (Fin.FS Fin.F1)) : Fin.t 3. +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Check 0 : Fin.t 3. +Check 1 : Fin.t 3. +Check 2 : Fin.t 3. +Fail Check 3 : Fin.t 3. +Unset Printing All. + +End Test28. -- cgit v1.2.3 From e728a1ef0f8b5fdc4b1815a7d0349c67db15f9b4 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:25:00 +0200 Subject: [numeral notation] Add support for parameterized inductives --- doc/sphinx/user-extensions/syntax-extensions.rst | 28 ++++- interp/notation.ml | 27 +++-- interp/notation.mli | 4 +- plugins/syntax/numeral.ml | 66 ++++++++++-- test-suite/output/NumberNotations.out | 52 ++++++++++ test-suite/output/NumberNotations.v | 127 +++++++++++++++++++++++ 6 files changed, 284 insertions(+), 20 deletions(-) diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 4c6d300b13..60fbd68687 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1608,6 +1608,12 @@ Number notations function application, constructors, inductive type families, sorts, and primitive integers) will be considered for printing. + .. note:: + Number notations for parameterized inductive types can be + added by declaring an :ref:`abbreviation ` + for the inductive which instantiates all parameters. See + example below. + :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` When using this option, :n:`@qualid__type` no longer needs to be an inductive type and is instead mapped to the @@ -1847,6 +1853,24 @@ Number notations Check 2 : Fin.t 2. + .. example:: Number Notation with a parameterized inductive type + + .. coqtop:: in reset + + Definition of_uint u : list unit := + let fix f n := match n with O => nil | S n => cons tt (f n) end in + f (Nat.of_num_uint u). + Definition to_uint (l : list unit) := Nat.to_num_uint (length l). + + The parameter :g:`unit` for the parameterized inductive type + :g:`list` is given through an :ref:`abbreviation + `. + + .. coqtop:: in + + Notation list_unit := (list unit) (only parsing). + Number Notation list_unit of_uint to_uint : nat_scope. + .. _string-notations: String notations @@ -1917,8 +1941,8 @@ The following errors apply to both string and number notations: .. exn:: @type is not an inductive type. - String and number notations can only be declared for inductive types with no - arguments. Declare numeral notations for non-inductive types using :n:`@number_via`. + String and number notations can only be declared for inductive types. + Declare number notations for non-inductive types using :n:`@number_via`. .. exn:: Cannot interpret in @scope_name because @qualid could not be found in the current environment. diff --git a/interp/notation.ml b/interp/notation.ml index 0f149c5f50..1839e287d7 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -554,8 +554,10 @@ type 'target conversion_kind = 'target * option_kind argument is recursively translated according to [l_k]. [ToPostHole] introduces an additional implicit argument hole (in the reverse translation, the corresponding argument is removed). + [ToPostCheck r] behaves as [ToPostCopy] except in the reverse + translation which fails if the copied term is not [r]. When [n] is null, no translation is performed. *) -type to_post_arg = ToPostCopy | ToPostAs of int | ToPostHole +type to_post_arg = ToPostCopy | ToPostAs of int | ToPostHole | ToPostCheck of GlobRef.t type ('target, 'warning) prim_token_notation_obj = { to_kind : 'target conversion_kind; to_ty : GlobRef.t; @@ -620,11 +622,11 @@ let constr_of_globref allow_constant env sigma = function sigma,mkConstU c | _ -> raise NotAValidPrimToken -let rec constr_of_glob to_post post env sigma g = match DAst.get g with +let rec constr_of_glob allow_constant to_post post env sigma g = match DAst.get g with | Glob_term.GRef (r, _) -> let o = List.find_opt (fun (_,r',_) -> GlobRef.equal r r') post in begin match o with - | None -> constr_of_globref false env sigma r + | None -> constr_of_globref allow_constant env sigma r | Some (r, _, a) -> (* [g] is not a GApp so check that [post] does not expect any actual argument @@ -638,19 +640,26 @@ let rec constr_of_glob to_post post env sigma g = match DAst.get g with | _ -> None in begin match o with | None -> - let sigma,c = constr_of_glob to_post post env sigma gc in - let sigma,cl = List.fold_left_map (constr_of_glob to_post post env) sigma gcl in + let sigma,c = constr_of_glob allow_constant to_post post env sigma gc in + let sigma,cl = List.fold_left_map (constr_of_glob allow_constant to_post post env) sigma gcl in sigma,mkApp (c, Array.of_list cl) | Some (r, _, a) -> let sigma,c = constr_of_globref true env sigma r in let rec aux sigma a gcl = match a, gcl with | [], [] -> sigma,[] | ToPostCopy :: a, gc :: gcl -> - let sigma,c = constr_of_glob [||] [] env sigma gc in + let sigma,c = constr_of_glob allow_constant [||] [] env sigma gc in + let sigma,cl = aux sigma a gcl in + sigma, c :: cl + | ToPostCheck r :: a, gc :: gcl -> + let () = match DAst.get gc with + | Glob_term.GRef (r', _) when GlobRef.equal r r' -> () + | _ -> raise NotAValidPrimToken in + let sigma,c = constr_of_glob true [||] [] env sigma gc in let sigma,cl = aux sigma a gcl in sigma, c :: cl | ToPostAs i :: a, gc :: gcl -> - let sigma,c = constr_of_glob to_post to_post.(i) env sigma gc in + let sigma,c = constr_of_glob allow_constant to_post to_post.(i) env sigma gc in let sigma,cl = aux sigma a gcl in sigma, c :: cl | ToPostHole :: post, _ :: gcl -> aux sigma post gcl @@ -668,7 +677,7 @@ let rec constr_of_glob to_post post env sigma g = match DAst.get g with let constr_of_glob to_post env sigma (Glob_term.AnyGlobConstr g) = let post = match to_post with [||] -> [] | _ -> to_post.(0) in - constr_of_glob to_post post env sigma g + constr_of_glob false to_post post env sigma g let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with | App (c, ca) -> @@ -705,7 +714,7 @@ let rec postprocess token_kind ?loc ty to_post post g = let e = Evar_kinds.ImplicitArg (r, (n, None), true) in let h = DAst.make ?loc (Glob_term.GHole (e, Namegen.IntroAnonymous, None)) in h :: f (n+1) a gl - | ToPostCopy :: a, g :: gl -> g :: f (n+1) a gl + | (ToPostCopy | ToPostCheck _) :: a, g :: gl -> g :: f (n+1) a gl | ToPostAs c :: a, g :: gl -> postprocess token_kind ?loc ty to_post to_post.(c) g :: f (n+1) a gl | [], _::_ | _::_, [] -> diff --git a/interp/notation.mli b/interp/notation.mli index 012aaac8f0..acca7b262b 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -166,8 +166,10 @@ type 'target conversion_kind = 'target * option_kind argument is recursively translated according to [l_k]. [ToPostHole] introduces an additional implicit argument hole (in the reverse translation, the corresponding argument is removed). + [ToPostCheck r] behaves as [ToPostCopy] except in the reverse + translation which fails if the copied term is not [r]. When [n] is null, no translation is performed. *) -type to_post_arg = ToPostCopy | ToPostAs of int | ToPostHole +type to_post_arg = ToPostCopy | ToPostAs of int | ToPostHole | ToPostCheck of GlobRef.t type ('target, 'warning) prim_token_notation_obj = { to_kind : 'target conversion_kind; to_ty : GlobRef.t; diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 1efe6b77d1..89d757a72a 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -136,6 +136,11 @@ let warn_deprecated_decimal = Decimal.int or Decimal.decimal. Use Number.uint, \ Number.int or Number.number respectively.") +let error_params ind = + CErrors.user_err + (str "Wrong number of parameters for inductive" ++ spc () + ++ Printer.pr_global (GlobRef.IndRef ind) ++ str ".") + let remapping_error ?loc ty ty' ty'' = CErrors.user_err ?loc (Printer.pr_global ty @@ -219,11 +224,43 @@ let get_type env sigma c = List.map (fun (na, a) -> na, EConstr.Unsafe.to_constr a) l, EConstr.Unsafe.to_constr t -(* [elaborate_to_post env sigma ty_name ty_ind l] builds the [to_post] +(* [elaborate_to_post_params env sigma ty_ind params] builds the + [to_post] translation (c.f., interp/notation.mli) for the numeral + notation to parse/print type [ty_ind]. This translation is the + identity ([ToPostCopy]) except that it checks ([ToPostCheck]) that + the parameters of the inductive type [ty_ind] match the ones given + in [params]. *) +let elaborate_to_post_params env sigma ty_ind params = + let to_post_for_constructor indc = + let sigma, c = match indc with + | GlobRef.ConstructRef c -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma, Constr.mkConstructU c + | _ -> assert false in (* c.f. get_constructors *) + let args, t = get_type env sigma c in + let params_indc = match Constr.kind t with + | Constr.App (_, a) -> Array.to_list a | _ -> [] in + let sz = List.length args in + let a = Array.make sz ToPostCopy in + if List.length params <> List.length params_indc then error_params ty_ind; + List.iter2 (fun param param_indc -> + match param, Constr.kind param_indc with + | Some p, Constr.Rel i when i <= sz -> a.(sz - i) <- ToPostCheck p + | _ -> ()) + params params_indc; + indc, indc, Array.to_list a in + let pt_refs = get_constructors ty_ind in + let to_post_0 = List.map to_post_for_constructor pt_refs in + let to_post = + let only_copy (_, _, args) = List.for_all ((=) ToPostCopy) args in + if (List.for_all only_copy to_post_0) then [||] else [|to_post_0|] in + to_post, pt_refs + +(* [elaborate_to_post_via env sigma ty_name ty_ind l] builds the [to_post] translation (c.f., interp/notation.mli) for the number notation to parse/print type [ty_name] through the inductive [ty_ind] according to the pairs [constant, constructor] in the list [l]. *) -let elaborate_to_post env sigma ty_name ty_ind l = +let elaborate_to_post_via env sigma ty_name ty_ind l = let sigma, ty_name = locate_global_sort_inductive_or_constant sigma ty_name in let ty_ind = Constr.mkInd ty_ind in @@ -344,10 +381,21 @@ let elaborate_to_post env sigma ty_name ty_ind l = let pt_refs = List.map (fun (_, cnst, _) -> cnst) (to_post.(0)) in to_post, pt_refs -let elaborate_to_post env sigma ty_ind via = - match via with - | None -> [||], get_constructors ty_ind - | Some (ty_name, l) -> elaborate_to_post env sigma ty_name ty_ind l +let locate_global_inductive allow_params qid = + let locate_param_inductive qid = + match Nametab.locate_extended qid with + | Globnames.TrueGlobal _ -> raise Not_found + | Globnames.SynDef kn -> + match Syntax_def.search_syntactic_definition kn with + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i), l)) when allow_params -> + i, + List.map (function + | Notation_term.NRef r -> Some r + | Notation_term.NHole _ -> None + | _ -> raise Not_found) l + | _ -> raise Not_found in + try locate_param_inductive qid + with Not_found -> Smartlocate.global_inductive_with_alias qid, [] let vernac_number_notation local ty f g opts scope = let rec parse_opts = function @@ -373,7 +421,7 @@ let vernac_number_notation local ty f g opts scope = let ty_name = ty in let ty, via = match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in - let tyc = Smartlocate.global_inductive_with_alias ty in + let tyc, params = locate_global_inductive (via = None) ty in let to_ty = Smartlocate.global_with_alias f in let of_ty = Smartlocate.global_with_alias g in let cty = mkRefC ty in @@ -437,7 +485,9 @@ let vernac_number_notation local ty f g opts scope = | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> warn_deprecated_decimal () | _ -> ()); - let to_post, pt_refs = elaborate_to_post env sigma tyc via in + let to_post, pt_refs = match via with + | None -> elaborate_to_post_params env sigma tyc params + | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; warning = opts } in diff --git a/test-suite/output/NumberNotations.out b/test-suite/output/NumberNotations.out index 357119f74e..57206772c8 100644 --- a/test-suite/output/NumberNotations.out +++ b/test-suite/output/NumberNotations.out @@ -341,6 +341,58 @@ The term "@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)))" has type "Fin.t (S (S (S (S ?n))))" while it is expected to have type "Fin.t (S (S (S O)))". +0 + : list unit +1 + : list unit +2 + : list unit +2 + : list unit +0 :: 0 :: nil + : list nat +0 + : Ip nat bool +1 + : Ip nat bool +2 + : Ip nat bool +3 + : Ip nat bool +1 + : Ip nat bool +1 + : Ip nat bool +1 + : Ip nat bool +1 + : Ip nat bool +Ip0 nat nat 1 + : Ip nat nat +Ip0 bool bool 1 + : Ip bool bool +Ip1 nat nat 1 + : Ip nat nat +Ip3 1 nat nat + : Ip nat nat +Ip0 nat bool O + : Ip nat bool +Ip1 bool nat (S O) + : Ip nat bool +Ip2 nat (S (S O)) bool + : Ip nat bool +Ip3 (S (S (S O))) nat bool + : Ip nat bool +0 + : 0 = 0 +eq_refl + : 1 = 1 +0 + : 1 = 1 +2 + : extra_list_unit +cons O unit tt (cons O unit tt (nil O unit)) + : extra_list unit 0 : Set 1 diff --git a/test-suite/output/NumberNotations.v b/test-suite/output/NumberNotations.v index bfcad2621a..556cf929b4 100644 --- a/test-suite/output/NumberNotations.v +++ b/test-suite/output/NumberNotations.v @@ -686,6 +686,133 @@ Unset Printing All. End Test24. +(* Test number notations for parameterized inductives *) +Module Test25. + +Definition of_uint (u : Number.uint) : list unit := + let fix f n := + match n with + | O => nil + | S n => cons tt (f n) + end in + f (Nat.of_num_uint u). + +Definition to_uint (l : list unit) : Number.uint := + let fix f n := + match n with + | nil => O + | cons tt l => S (f l) + end in + Nat.to_num_uint (f l). + +Notation listunit := (list unit) (only parsing). +Number Notation listunit of_uint to_uint : nat_scope. + +Check 0. +Check 1. +Check 2. + +Check cons tt (cons tt nil). +Check cons O (cons O nil). (* printer not called on list nat *) + +(* inductive with multiple parameters that are not the first + parameters and not in the same order for each constructor *) +Inductive Ip : Type -> Type -> Type := +| Ip0 : forall T T', nat -> Ip T T' +| Ip1 : forall T' T, nat -> Ip T T' +| Ip2 : forall T, nat -> forall T', Ip T T' +| Ip3 : nat -> forall T T', Ip T T'. + +Definition Ip_of_uint (u : Number.uint) : option (Ip nat bool) := + let f n := + match n with + | O => Some (Ip0 nat bool O) + | S O => Some (Ip1 bool nat (S O)) + | S (S O) => Some (Ip2 nat (S (S O)) bool) + | S (S (S O)) => Some (Ip3 (S (S (S O))) nat bool) + | _ => None + end in + f (Nat.of_num_uint u). + +Definition Ip_to_uint (l : Ip nat bool) : Number.uint := + let f n := + match n with + | Ip0 _ _ n => n + | Ip1 _ _ n => n + | Ip2 _ n _ => n + | Ip3 n _ _ => n + end in + Nat.to_num_uint (f l). + +Notation Ip_nat_bool := (Ip nat bool) (only parsing). +Number Notation Ip_nat_bool Ip_of_uint Ip_to_uint : nat_scope. + +Check 0. +Check 1. +Check 2. +Check 3. +Check Ip0 nat bool (S O). +Check Ip1 bool nat (S O). +Check Ip2 nat (S O) bool. +Check Ip3 (S O) nat bool. +Check Ip0 nat nat (S O). (* not printed *) +Check Ip0 bool bool (S O). (* not printed *) +Check Ip1 nat nat (S O). (* not printed *) +Check Ip3 (S O) nat nat. (* not printed *) +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Unset Printing All. + +Notation eqO := (eq _ O) (only parsing). +Definition eqO_of_uint (x : Number.uint) : eqO := eq_refl O. +Definition eqO_to_uint (x : O = O) : Number.uint := + match x with + | eq_refl _ => Nat.to_num_uint O + end. +Number Notation eqO eqO_of_uint eqO_to_uint : nat_scope. + +Check 42. +Check eq_refl (S O). (* doesn't match eq _ O, printer not called *) + +Notation eq_ := (eq _ _) (only parsing). +Number Notation eq_ eqO_of_uint eqO_to_uint : nat_scope. + +Check eq_refl (S O). (* matches eq _ _, printer called *) + +Inductive extra_list : Type -> Type := +| nil (n : nat) (v : Type) : extra_list v +| cons (n : nat) (t : Type) (x : t) : extra_list t -> extra_list t. + +Definition extra_list_unit_of_uint (x : Number.uint) : extra_list unit := + let fix f n := + match n with + | O => nil O unit + | S n => cons O unit tt (f n) + end in + f (Nat.of_num_uint x). + +Definition extra_list_unit_to_uint (x : extra_list unit) : Number.uint := + let fix f T (x : extra_list T) := + match x with + | nil _ _ => O + | cons _ T _ x => S (f T x) + end in + Nat.to_num_uint (f unit x). + +Notation extra_list_unit := (extra_list unit). +Number Notation extra_list_unit + extra_list_unit_of_uint extra_list_unit_to_uint : nat_scope. + +Check 2. +Set Printing All. +Check 2. +Unset Printing All. + +End Test25. + (* Test the via ... mapping ... option with let-binders, beta-redexes, delta-redexes, etc *) Module Test26. -- cgit v1.2.3 From 3b766fd8859b692e3e93cf83bf87d393e32c572e Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:26:00 +0200 Subject: Merge numeral and string notation plugins --- Makefile.common | 3 +- doc/tools/docgram/doc_grammar.ml | 3 +- plugins/syntax/dune | 17 +- plugins/syntax/g_number_string.mlg | 102 +++++ plugins/syntax/g_numeral.mlg | 95 ---- plugins/syntax/g_string.mlg | 25 - plugins/syntax/number.ml | 505 +++++++++++++++++++++ plugins/syntax/number.mli | 26 ++ .../syntax/number_string_notation_plugin.mlpack | 3 + plugins/syntax/numeral.ml | 505 --------------------- plugins/syntax/numeral.mli | 26 -- plugins/syntax/numeral_notation_plugin.mlpack | 2 - plugins/syntax/string_notation.ml | 1 - plugins/syntax/string_notation_plugin.mlpack | 2 - theories/Init/Byte.v | 2 +- theories/Init/Prelude.v | 2 - theories/dune | 3 +- 17 files changed, 645 insertions(+), 677 deletions(-) create mode 100644 plugins/syntax/g_number_string.mlg delete mode 100644 plugins/syntax/g_numeral.mlg delete mode 100644 plugins/syntax/g_string.mlg create mode 100644 plugins/syntax/number.ml create mode 100644 plugins/syntax/number.mli create mode 100644 plugins/syntax/number_string_notation_plugin.mlpack delete mode 100644 plugins/syntax/numeral.ml delete mode 100644 plugins/syntax/numeral.mli delete mode 100644 plugins/syntax/numeral_notation_plugin.mlpack delete mode 100644 plugins/syntax/string_notation_plugin.mlpack diff --git a/Makefile.common b/Makefile.common index 29020dc4ad..caf1821ce5 100644 --- a/Makefile.common +++ b/Makefile.common @@ -151,8 +151,7 @@ RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo SYNTAXCMO:=$(addprefix plugins/syntax/, \ int63_syntax_plugin.cmo \ float_syntax_plugin.cmo \ - numeral_notation_plugin.cmo \ - string_notation_plugin.cmo) + number_string_notation_plugin.cmo) DERIVECMO:=plugins/derive/derive_plugin.cmo LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index b7f1e18d2b..92bcd51528 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -538,12 +538,11 @@ let autoloaded_mlgs = [ (* in the order they are loaded by Coq *) "plugins/ltac/g_eqdecide.mlg"; "plugins/ltac/g_tactic.mlg"; "plugins/ltac/g_ltac.mlg"; - "plugins/syntax/g_string.mlg"; "plugins/btauto/g_btauto.mlg"; "plugins/rtauto/g_rtauto.mlg"; "plugins/cc/g_congruence.mlg"; "plugins/firstorder/g_ground.mlg"; - "plugins/syntax/g_numeral.mlg"; + "plugins/syntax/g_number_string.mlg"; ] diff --git a/plugins/syntax/dune b/plugins/syntax/dune index 1b3d7598da..f930fc265a 100644 --- a/plugins/syntax/dune +++ b/plugins/syntax/dune @@ -1,15 +1,8 @@ (library - (name numeral_notation_plugin) - (public_name coq.plugins.numeral_notation) - (synopsis "Coq numeral notation plugin") - (modules g_numeral numeral) - (libraries coq.vernac)) - -(library - (name string_notation_plugin) - (public_name coq.plugins.string_notation) - (synopsis "Coq string notation plugin") - (modules g_string string_notation) + (name number_string_notation_plugin) + (public_name coq.plugins.number_string_notation) + (synopsis "Coq number and string notation plugin") + (modules g_number_string string_notation number) (libraries coq.vernac)) (library @@ -26,4 +19,4 @@ (modules float_syntax) (libraries coq.vernac)) -(coq.pp (modules g_numeral g_string)) +(coq.pp (modules g_number_string)) diff --git a/plugins/syntax/g_number_string.mlg b/plugins/syntax/g_number_string.mlg new file mode 100644 index 0000000000..b584505530 --- /dev/null +++ b/plugins/syntax/g_number_string.mlg @@ -0,0 +1,102 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* mt () + | Warning n -> str "warning after " ++ NumTok.UnsignedNat.print n + | Abstract n -> str "abstract after " ++ NumTok.UnsignedNat.print n + +let pr_deprecated_number_modifier m = str "(" ++ pr_number_after m ++ str ")" + +let warn_deprecated_numeral_notation = + CWarnings.create ~name:"numeral-notation" ~category:"deprecated" + (fun () -> + strbrk "Numeral Notation is deprecated, please use Number Notation instead.") + +let pr_number_mapping (b, n, n') = + if b then + str "[" ++ Libnames.pr_qualid n ++ str "]" ++ spc () ++ str "=>" ++ spc () + ++ Libnames.pr_qualid n' + else + Libnames.pr_qualid n ++ spc () ++ str "=>" ++ spc () + ++ Libnames.pr_qualid n' + +let pr_number_via (n, l) = + str "via " ++ Libnames.pr_qualid n ++ str " mapping [" + ++ prlist_with_sep pr_comma pr_number_mapping l ++ str "]" + +let pr_number_modifier = function + | After a -> pr_number_after a + | Via nl -> pr_number_via nl + +let pr_number_options l = + str "(" ++ prlist_with_sep pr_comma pr_number_modifier l ++ str ")" + +} + +VERNAC ARGUMENT EXTEND deprecated_number_modifier + PRINTED BY { pr_deprecated_number_modifier } +| [ ] -> { Nop } +| [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } +| [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } +END + +VERNAC ARGUMENT EXTEND number_mapping + PRINTED BY { pr_number_mapping } +| [ reference(n) "=>" reference(n') ] -> { false, n, n' } +| [ "[" reference(n) "]" "=>" reference(n') ] -> { true, n, n' } +END + +VERNAC ARGUMENT EXTEND number_via + PRINTED BY { pr_number_via } +| [ "via" reference(n) "mapping" "[" ne_number_mapping_list_sep(l, ",") "]" ] -> { n, l } +END + +VERNAC ARGUMENT EXTEND number_modifier + PRINTED BY { pr_number_modifier } +| [ "warning" "after" bignat(waft) ] -> { After (Warning (NumTok.UnsignedNat.of_string waft)) } +| [ "abstract" "after" bignat(n) ] -> { After (Abstract (NumTok.UnsignedNat.of_string n)) } +| [ number_via(v) ] -> { Via v } +END + +VERNAC ARGUMENT EXTEND number_options + PRINTED BY { pr_number_options } +| [ "(" ne_number_modifier_list_sep(l, ",") ")" ] -> { l } +END + +VERNAC COMMAND EXTEND NumberNotation CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) number_options_opt(nl) ":" + ident(sc) ] -> + + { vernac_number_notation (Locality.make_module_locality locality) ty f g (Option.default [] nl) (Id.to_string sc) } + | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + ident(sc) deprecated_number_modifier(o) ] -> + + { warn_deprecated_numeral_notation (); + vernac_number_notation (Locality.make_module_locality locality) ty f g [After o] (Id.to_string sc) } +END + +VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" + ident(sc) ] -> + { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } +END diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg deleted file mode 100644 index a3cc786a4a..0000000000 --- a/plugins/syntax/g_numeral.mlg +++ /dev/null @@ -1,95 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* mt () - | Warning n -> str "warning after " ++ NumTok.UnsignedNat.print n - | Abstract n -> str "abstract after " ++ NumTok.UnsignedNat.print n - -let pr_deprecated_number_modifier m = str "(" ++ pr_number_after m ++ str ")" - -let warn_deprecated_numeral_notation = - CWarnings.create ~name:"numeral-notation" ~category:"deprecated" - (fun () -> - strbrk "Numeral Notation is deprecated, please use Number Notation instead.") - -let pr_number_mapping (b, n, n') = - if b then - str "[" ++ Libnames.pr_qualid n ++ str "]" ++ spc () ++ str "=>" ++ spc () - ++ Libnames.pr_qualid n' - else - Libnames.pr_qualid n ++ spc () ++ str "=>" ++ spc () - ++ Libnames.pr_qualid n' - -let pr_number_via (n, l) = - str "via " ++ Libnames.pr_qualid n ++ str " mapping [" - ++ prlist_with_sep pr_comma pr_number_mapping l ++ str "]" - -let pr_number_modifier = function - | After a -> pr_number_after a - | Via nl -> pr_number_via nl - -let pr_number_options l = - str "(" ++ prlist_with_sep pr_comma pr_number_modifier l ++ str ")" - -} - -VERNAC ARGUMENT EXTEND deprecated_number_modifier - PRINTED BY { pr_deprecated_number_modifier } -| [ ] -> { Nop } -| [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } -| [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } -END - -VERNAC ARGUMENT EXTEND number_mapping - PRINTED BY { pr_number_mapping } -| [ reference(n) "=>" reference(n') ] -> { false, n, n' } -| [ "[" reference(n) "]" "=>" reference(n') ] -> { true, n, n' } -END - -VERNAC ARGUMENT EXTEND number_via - PRINTED BY { pr_number_via } -| [ "via" reference(n) "mapping" "[" ne_number_mapping_list_sep(l, ",") "]" ] -> { n, l } -END - -VERNAC ARGUMENT EXTEND number_modifier - PRINTED BY { pr_number_modifier } -| [ "warning" "after" bignat(waft) ] -> { After (Warning (NumTok.UnsignedNat.of_string waft)) } -| [ "abstract" "after" bignat(n) ] -> { After (Abstract (NumTok.UnsignedNat.of_string n)) } -| [ number_via(v) ] -> { Via v } -END - -VERNAC ARGUMENT EXTEND number_options - PRINTED BY { pr_number_options } -| [ "(" ne_number_modifier_list_sep(l, ",") ")" ] -> { l } -END - -VERNAC COMMAND EXTEND NumberNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) number_options_opt(nl) ":" - ident(sc) ] -> - - { vernac_number_notation (Locality.make_module_locality locality) ty f g (Option.default [] nl) (Id.to_string sc) } - | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) deprecated_number_modifier(o) ] -> - - { warn_deprecated_numeral_notation (); - vernac_number_notation (Locality.make_module_locality locality) ty f g [After o] (Id.to_string sc) } -END diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg deleted file mode 100644 index 788f9e011d..0000000000 --- a/plugins/syntax/g_string.mlg +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } -END diff --git a/plugins/syntax/number.ml b/plugins/syntax/number.ml new file mode 100644 index 0000000000..89d757a72a --- /dev/null +++ b/plugins/syntax/number.ml @@ -0,0 +1,505 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* + strbrk "The 'abstract after' directive has no effect when " ++ + strbrk "the parsing function (" ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ + strbrk "option type.") + +let get_constructors ind = + let mib,oib = Global.lookup_inductive ind in + let mc = oib.Declarations.mind_consnames in + Array.to_list + (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) + +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_option () = qualid_of_ref "core.option.type" + +let unsafe_locate_ind q = + match Nametab.locate q with + | GlobRef.IndRef i -> i + | _ -> raise Not_found + +let locate_z () = + let zn = "num.Z.type" in + let pn = "num.pos.type" in + if Coqlib.has_ref zn && Coqlib.has_ref pn + then + let q_z = qualid_of_ref zn in + let q_pos = qualid_of_ref pn in + Some ({ + z_ty = unsafe_locate_ind q_z; + pos_ty = unsafe_locate_ind q_pos; + }, mkRefC q_z) + else None + +let locate_number () = + let dint = "num.int.type" in + let duint = "num.uint.type" in + let dec = "num.decimal.type" in + let hint = "num.hexadecimal_int.type" in + let huint = "num.hexadecimal_uint.type" in + let hex = "num.hexadecimal.type" in + let int = "num.num_int.type" in + let uint = "num.num_uint.type" in + let num = "num.number.type" in + if Coqlib.has_ref dint && Coqlib.has_ref duint && Coqlib.has_ref dec + && Coqlib.has_ref hint && Coqlib.has_ref huint && Coqlib.has_ref hex + && Coqlib.has_ref int && Coqlib.has_ref uint && Coqlib.has_ref num + then + let q_dint = qualid_of_ref dint in + let q_duint = qualid_of_ref duint in + let q_dec = qualid_of_ref dec in + let q_hint = qualid_of_ref hint in + let q_huint = qualid_of_ref huint in + let q_hex = qualid_of_ref hex in + let q_int = qualid_of_ref int in + let q_uint = qualid_of_ref uint in + let q_num = qualid_of_ref num in + let int_ty = { + dec_int = unsafe_locate_ind q_dint; + dec_uint = unsafe_locate_ind q_duint; + hex_int = unsafe_locate_ind q_hint; + hex_uint = unsafe_locate_ind q_huint; + int = unsafe_locate_ind q_int; + uint = unsafe_locate_ind q_uint; + } in + let num_ty = { + int = int_ty; + decimal = unsafe_locate_ind q_dec; + hexadecimal = unsafe_locate_ind q_hex; + number = unsafe_locate_ind q_num; + } in + Some (int_ty, mkRefC q_int, mkRefC q_uint, mkRefC q_dint, mkRefC q_duint, + num_ty, mkRefC q_num, mkRefC q_dec) + else None + +let locate_int63 () = + let int63n = "num.int63.type" in + if Coqlib.has_ref int63n + then + let q_int63 = qualid_of_ref int63n in + Some (mkRefC q_int63) + else None + +let has_type env sigma f ty = + let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in + try let _ = Constrintern.interp_constr env sigma c in true + with Pretype_errors.PretypeError _ -> false + +let type_error_to f ty = + CErrors.user_err + (pr_qualid f ++ str " should go from Number.int to " ++ + pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ + fnl () ++ str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") + +let type_error_of g ty = + CErrors.user_err + (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ + str " to Number.int or (option Number.int)." ++ fnl () ++ + str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") + +let warn_deprecated_decimal = + CWarnings.create ~name:"decimal-numeral-notation" ~category:"deprecated" + (fun () -> + strbrk "Deprecated Number Notation for Decimal.uint, \ + Decimal.int or Decimal.decimal. Use Number.uint, \ + Number.int or Number.number respectively.") + +let error_params ind = + CErrors.user_err + (str "Wrong number of parameters for inductive" ++ spc () + ++ Printer.pr_global (GlobRef.IndRef ind) ++ str ".") + +let remapping_error ?loc ty ty' ty'' = + CErrors.user_err ?loc + (Printer.pr_global ty + ++ str " was already mapped to" ++ spc () ++ Printer.pr_global ty' + ++ str " and cannot be remapped to" ++ spc () ++ Printer.pr_global ty'' + ++ str ".") + +let error_missing c = + CErrors.user_err + (str "Missing mapping for constructor " ++ Printer.pr_global c ++ str ".") + +let pr_constr env sigma c = + let c = Constrextern.extern_constr env sigma (EConstr.of_constr c) in + Ppconstr.pr_constr_expr env sigma c + +let warn_via_remapping = + CWarnings.create ~name:"via-type-remapping" ~category:"numbers" + (fun (env, sigma, ty, ty', ty'') -> + let constr = pr_constr env sigma in + constr ty ++ str " was already mapped to" ++ spc () ++ constr ty' + ++ str ", mapping it also to" ++ spc () ++ constr ty'' + ++ str " might yield ill typed terms when using the notation.") + +let warn_via_type_mismatch = + CWarnings.create ~name:"via-type-mismatch" ~category:"numbers" + (fun (env, sigma, g, g', exp, actual) -> + let constr = pr_constr env sigma in + str "Type of" ++ spc() ++ Printer.pr_global g + ++ str " seems incompatible with the type of" ++ spc () + ++ Printer.pr_global g' ++ str "." ++ spc () + ++ str "Expected type is: " ++ constr exp ++ spc () + ++ str "instead of " ++ constr actual ++ str "." ++ spc () + ++ str "This might yield ill typed terms when using the notation.") + +let multiple_via_error () = + CErrors.user_err (Pp.str "Multiple 'via' options.") + +let multiple_after_error () = + CErrors.user_err (Pp.str "Multiple 'warning after' or 'abstract after' options.") + +let via_abstract_error () = + CErrors.user_err (Pp.str "'via' and 'abstract' cannot be used together.") + +let locate_global_sort_inductive_or_constant sigma qid = + let locate_sort qid = + match Nametab.locate_extended qid with + | Globnames.TrueGlobal _ -> raise Not_found + | Globnames.SynDef kn -> + match Syntax_def.search_syntactic_definition kn with + | [], Notation_term.NSort r -> + let sigma,c = Evd.fresh_sort_in_family sigma (Glob_ops.glob_sort_family r) in + sigma,Constr.mkSort c + | _ -> raise Not_found in + try locate_sort qid + with Not_found -> + match Smartlocate.global_with_alias qid with + | GlobRef.IndRef i -> sigma, Constr.mkInd i + | _ -> sigma, Constr.mkConst (Smartlocate.global_constant_with_alias qid) + +let locate_global_constructor_inductive_or_constant qid = + let g = Smartlocate.global_with_alias qid in + match g with + | GlobRef.ConstructRef c -> g, Constr.mkConstruct c + | GlobRef.IndRef i -> g, Constr.mkInd i + | _ -> g, Constr.mkConst (Smartlocate.global_constant_with_alias qid) + +(* [get_type env sigma c] retrieves the type of [c] and returns a pair + [l, t] such that [c : l_0 -> ... -> l_n -> t]. *) +let get_type env sigma c = + (* inspired from [compute_implicit_names] in "interp/impargs.ml" *) + let rec aux env acc t = + let t = Reductionops.whd_all env sigma t in + match EConstr.kind sigma t with + | Constr.Prod (na, a, b) -> + let a = Reductionops.whd_all env sigma a in + let rel = Context.Rel.Declaration.LocalAssum (na, a) in + aux (EConstr.push_rel rel env) ((na, a) :: acc) b + | _ -> List.rev acc, t in + let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let l, t = aux env [] t in + List.map (fun (na, a) -> na, EConstr.Unsafe.to_constr a) l, + EConstr.Unsafe.to_constr t + +(* [elaborate_to_post_params env sigma ty_ind params] builds the + [to_post] translation (c.f., interp/notation.mli) for the numeral + notation to parse/print type [ty_ind]. This translation is the + identity ([ToPostCopy]) except that it checks ([ToPostCheck]) that + the parameters of the inductive type [ty_ind] match the ones given + in [params]. *) +let elaborate_to_post_params env sigma ty_ind params = + let to_post_for_constructor indc = + let sigma, c = match indc with + | GlobRef.ConstructRef c -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma, Constr.mkConstructU c + | _ -> assert false in (* c.f. get_constructors *) + let args, t = get_type env sigma c in + let params_indc = match Constr.kind t with + | Constr.App (_, a) -> Array.to_list a | _ -> [] in + let sz = List.length args in + let a = Array.make sz ToPostCopy in + if List.length params <> List.length params_indc then error_params ty_ind; + List.iter2 (fun param param_indc -> + match param, Constr.kind param_indc with + | Some p, Constr.Rel i when i <= sz -> a.(sz - i) <- ToPostCheck p + | _ -> ()) + params params_indc; + indc, indc, Array.to_list a in + let pt_refs = get_constructors ty_ind in + let to_post_0 = List.map to_post_for_constructor pt_refs in + let to_post = + let only_copy (_, _, args) = List.for_all ((=) ToPostCopy) args in + if (List.for_all only_copy to_post_0) then [||] else [|to_post_0|] in + to_post, pt_refs + +(* [elaborate_to_post_via env sigma ty_name ty_ind l] builds the [to_post] + translation (c.f., interp/notation.mli) for the number notation to + parse/print type [ty_name] through the inductive [ty_ind] according + to the pairs [constant, constructor] in the list [l]. *) +let elaborate_to_post_via env sigma ty_name ty_ind l = + let sigma, ty_name = + locate_global_sort_inductive_or_constant sigma ty_name in + let ty_ind = Constr.mkInd ty_ind in + (* Retrieve constants and constructors mappings and their type. + For each constant [cnst] and inductive constructor [indc] in [l], retrieve: + * its location: [lcnst] and [lindc] + * its GlobRef: [cnst] and [indc] + * its type: [tcnst] and [tindc] (decomposed in product by [get_type] above) + * [impls] are the implicit arguments of [cnst] *) + let l = + let read (consider_implicits, cnst, indc) = + let lcnst, lindc = cnst.CAst.loc, indc.CAst.loc in + let cnst, ccnst = locate_global_constructor_inductive_or_constant cnst in + let indc, cindc = + let indc = Smartlocate.global_constructor_with_alias indc in + GlobRef.ConstructRef indc, Constr.mkConstruct indc in + let get_type_wo_params c = + (* ignore parameters of inductive types *) + let rm_params c = match Constr.kind c with + | Constr.App (c, _) when Constr.isInd c -> c + | _ -> c in + let lc, tc = get_type env sigma c in + List.map (fun (n, c) -> n, rm_params c) lc, rm_params tc in + let tcnst, tindc = get_type_wo_params ccnst, get_type_wo_params cindc in + let impls = + if not consider_implicits then [] else + Impargs.(select_stronger_impargs (implicits_of_global cnst)) in + lcnst, cnst, tcnst, lindc, indc, tindc, impls in + List.map read l in + let eq_indc indc (_, _, _, _, indc', _, _) = GlobRef.equal indc indc' in + (* Collect all inductive types involved. + That is [ty_ind] and all final codomains of [tindc] above. *) + let inds = + List.fold_left (fun s (_, _, _, _, _, tindc, _) -> CSet.add (snd tindc) s) + (CSet.singleton ty_ind) l in + (* And for each inductive, retrieve its constructors. *) + let constructors = + CSet.fold (fun ind m -> + let inductive, _ = Constr.destInd ind in + CMap.add ind (get_constructors inductive) m) + inds CMap.empty in + (* Error if one [constructor] in some inductive in [inds] + doesn't appear exactly once in [l] *) + let _ = (* check_for duplicate constructor and error *) + List.fold_left (fun already_seen (_, cnst, _, loc, indc, _, _) -> + try + let cnst' = List.assoc_f GlobRef.equal indc already_seen in + remapping_error ?loc indc cnst' cnst + with Not_found -> (indc, cnst) :: already_seen) + [] l in + let () = (* check for missing constructor and error *) + CMap.iter (fun _ -> + List.iter (fun cstr -> + if not (List.exists (eq_indc cstr) l) then error_missing cstr)) + constructors in + (* Perform some checks on types and warn if they look strange. + These checks are neither sound nor complete, so we only warn. *) + let () = + (* associate inductives to types, and check that this mapping is one to one + and maps [ty_ind] to [ty_name] *) + let ind2ty, ty2ind = + let add loc ckey cval m = + match CMap.find_opt ckey m with + | None -> CMap.add ckey cval m + | Some old_cval -> + if not (Constr.equal old_cval cval) then + warn_via_remapping ?loc (env, sigma, ckey, old_cval, cval); + m in + List.fold_left + (fun (ind2ty, ty2ind) (lcnst, _, (_, tcnst), lindc, _, (_, tindc), _) -> + add lcnst tindc tcnst ind2ty, add lindc tcnst tindc ty2ind) + CMap.(singleton ty_ind ty_name, singleton ty_name ty_ind) l in + (* check that type of constants and constructors mapped in [l] + match modulo [ind2ty] *) + let rm_impls impls (l, t) = + let rec aux impls l = match impls, l with + | Some _ :: impls, _ :: b -> aux impls b + | None :: impls, (n, a) :: b -> (n, a) :: aux impls b + | _ -> l in + aux impls l, t in + let replace m (l, t) = + let apply_m c = try CMap.find c m with Not_found -> c in + List.fold_right (fun (na, a) b -> Constr.mkProd (na, (apply_m a), b)) + l (apply_m t) in + List.iter (fun (_, cnst, tcnst, loc, indc, tindc, impls) -> + let tcnst = rm_impls impls tcnst in + let tcnst' = replace CMap.empty tcnst in + if not (Constr.equal tcnst' (replace ind2ty tindc)) then + let actual = replace CMap.empty tindc in + let expected = replace ty2ind tcnst in + warn_via_type_mismatch ?loc (env, sigma, indc, cnst, expected, actual)) + l in + (* Associate an index to each inductive, starting from 0 for [ty_ind]. *) + let ind2num, num2ind, nb_ind = + CMap.fold (fun ind _ (ind2num, num2ind, i) -> + CMap.add ind i ind2num, Int.Map.add i ind num2ind, i + 1) + (CMap.remove ty_ind constructors) + (CMap.singleton ty_ind 0, Int.Map.singleton 0 ty_ind, 1) in + (* Finally elaborate [to_post] *) + let to_post = + let rec map_prod impls tindc = match impls with + | Some _ :: impls -> ToPostHole :: map_prod impls tindc + | _ -> + match tindc with + | [] -> [] + | (_, a) :: b -> + let t = match CMap.find_opt a ind2num with + | Some i -> ToPostAs i + | None -> ToPostCopy in + let impls = match impls with [] -> [] | _ :: t -> t in + t :: map_prod impls b in + Array.init nb_ind (fun i -> + List.map (fun indc -> + let _, cnst, _, _, _, tindc, impls = List.find (eq_indc indc) l in + indc, cnst, map_prod impls (fst tindc)) + (CMap.find (Int.Map.find i num2ind) constructors)) in + (* and use constants mapped to constructors of [ty_ind] as triggers. *) + let pt_refs = List.map (fun (_, cnst, _) -> cnst) (to_post.(0)) in + to_post, pt_refs + +let locate_global_inductive allow_params qid = + let locate_param_inductive qid = + match Nametab.locate_extended qid with + | Globnames.TrueGlobal _ -> raise Not_found + | Globnames.SynDef kn -> + match Syntax_def.search_syntactic_definition kn with + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i), l)) when allow_params -> + i, + List.map (function + | Notation_term.NRef r -> Some r + | Notation_term.NHole _ -> None + | _ -> raise Not_found) l + | _ -> raise Not_found in + try locate_param_inductive qid + with Not_found -> Smartlocate.global_inductive_with_alias qid, [] + +let vernac_number_notation local ty f g opts scope = + let rec parse_opts = function + | [] -> None, Nop + | h :: opts -> + let via, opts = parse_opts opts in + let via = match h, via with + | Via _, Some _ -> multiple_via_error () + | Via v, None -> Some v + | _ -> via in + let opts = match h, opts with + | After _, (Warning _ | Abstract _) -> multiple_after_error () + | After a, Nop -> a + | _ -> opts in + via, opts in + let via, opts = parse_opts opts in + (match via, opts with Some _, Abstract _ -> via_abstract_error () | _ -> ()); + let env = Global.env () in + let sigma = Evd.from_env env in + let num_ty = locate_number () in + let z_pos_ty = locate_z () in + let int63_ty = locate_int63 () in + let ty_name = ty in + let ty, via = + match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in + let tyc, params = locate_global_inductive (via = None) ty in + let to_ty = Smartlocate.global_with_alias f in + let of_ty = Smartlocate.global_with_alias g in + let cty = mkRefC ty in + let app x y = mkAppC (x,[y]) in + let arrow x y = + mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) + in + let opt r = app (mkRefC (q_option ())) r in + (* Check the type of f *) + let to_kind = + match num_ty with + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint cty) -> UInt int_ty, Direct + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty, Option + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Number num_ty, Direct + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Number num_ty, Option + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint cty) -> DecimalInt int_ty, Direct + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> DecimalInt int_ty, Option + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint cty) -> DecimalUInt int_ty, Direct + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> DecimalUInt int_ty, Option + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal num_ty, Direct + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal num_ty, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option + | _ -> + match int63_ty with + | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct + | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option + | _ -> type_error_to f ty + in + (* Check the type of g *) + let of_kind = + match num_ty with + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty cuint) -> UInt int_ty, Direct + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty, Option + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Number num_ty, Direct + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Number num_ty, Option + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty cint) -> DecimalInt int_ty, Direct + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> DecimalInt int_ty, Option + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty cuint) -> DecimalUInt int_ty, Direct + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> DecimalUInt int_ty, Option + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal num_ty, Direct + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal num_ty, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option + | _ -> + match int63_ty with + | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct + | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option + | _ -> type_error_of g ty + in + (match to_kind, of_kind with + | ((DecimalInt _ | DecimalUInt _ | Decimal _), _), _ + | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> + warn_deprecated_decimal () + | _ -> ()); + let to_post, pt_refs = match via with + | None -> elaborate_to_post_params env sigma tyc params + | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; + warning = opts } + in + (match opts, to_kind with + | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty + | _ -> ()); + let i = + { pt_local = local; + pt_scope = scope; + pt_interp_info = NumberNotation o; + pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; + pt_refs; + pt_in_match = true } + in + enable_prim_token_interpretation i diff --git a/plugins/syntax/number.mli b/plugins/syntax/number.mli new file mode 100644 index 0000000000..5a13d1068b --- /dev/null +++ b/plugins/syntax/number.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* + qualid -> + qualid -> qualid -> + number_option list -> + Notation_term.scope_name -> unit diff --git a/plugins/syntax/number_string_notation_plugin.mlpack b/plugins/syntax/number_string_notation_plugin.mlpack new file mode 100644 index 0000000000..74c32d3a53 --- /dev/null +++ b/plugins/syntax/number_string_notation_plugin.mlpack @@ -0,0 +1,3 @@ +Number +String_notation +G_number_string diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml deleted file mode 100644 index 89d757a72a..0000000000 --- a/plugins/syntax/numeral.ml +++ /dev/null @@ -1,505 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - strbrk "The 'abstract after' directive has no effect when " ++ - strbrk "the parsing function (" ++ - Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ - strbrk "option type.") - -let get_constructors ind = - let mib,oib = Global.lookup_inductive ind in - let mc = oib.Declarations.mind_consnames in - Array.to_list - (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) - -let qualid_of_ref n = - n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty - -let q_option () = qualid_of_ref "core.option.type" - -let unsafe_locate_ind q = - match Nametab.locate q with - | GlobRef.IndRef i -> i - | _ -> raise Not_found - -let locate_z () = - let zn = "num.Z.type" in - let pn = "num.pos.type" in - if Coqlib.has_ref zn && Coqlib.has_ref pn - then - let q_z = qualid_of_ref zn in - let q_pos = qualid_of_ref pn in - Some ({ - z_ty = unsafe_locate_ind q_z; - pos_ty = unsafe_locate_ind q_pos; - }, mkRefC q_z) - else None - -let locate_number () = - let dint = "num.int.type" in - let duint = "num.uint.type" in - let dec = "num.decimal.type" in - let hint = "num.hexadecimal_int.type" in - let huint = "num.hexadecimal_uint.type" in - let hex = "num.hexadecimal.type" in - let int = "num.num_int.type" in - let uint = "num.num_uint.type" in - let num = "num.number.type" in - if Coqlib.has_ref dint && Coqlib.has_ref duint && Coqlib.has_ref dec - && Coqlib.has_ref hint && Coqlib.has_ref huint && Coqlib.has_ref hex - && Coqlib.has_ref int && Coqlib.has_ref uint && Coqlib.has_ref num - then - let q_dint = qualid_of_ref dint in - let q_duint = qualid_of_ref duint in - let q_dec = qualid_of_ref dec in - let q_hint = qualid_of_ref hint in - let q_huint = qualid_of_ref huint in - let q_hex = qualid_of_ref hex in - let q_int = qualid_of_ref int in - let q_uint = qualid_of_ref uint in - let q_num = qualid_of_ref num in - let int_ty = { - dec_int = unsafe_locate_ind q_dint; - dec_uint = unsafe_locate_ind q_duint; - hex_int = unsafe_locate_ind q_hint; - hex_uint = unsafe_locate_ind q_huint; - int = unsafe_locate_ind q_int; - uint = unsafe_locate_ind q_uint; - } in - let num_ty = { - int = int_ty; - decimal = unsafe_locate_ind q_dec; - hexadecimal = unsafe_locate_ind q_hex; - number = unsafe_locate_ind q_num; - } in - Some (int_ty, mkRefC q_int, mkRefC q_uint, mkRefC q_dint, mkRefC q_duint, - num_ty, mkRefC q_num, mkRefC q_dec) - else None - -let locate_int63 () = - let int63n = "num.int63.type" in - if Coqlib.has_ref int63n - then - let q_int63 = qualid_of_ref int63n in - Some (mkRefC q_int63) - else None - -let has_type env sigma f ty = - let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in - try let _ = Constrintern.interp_constr env sigma c in true - with Pretype_errors.PretypeError _ -> false - -let type_error_to f ty = - CErrors.user_err - (pr_qualid f ++ str " should go from Number.int to " ++ - pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") - -let type_error_of g ty = - CErrors.user_err - (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ - str " to Number.int or (option Number.int)." ++ fnl () ++ - str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") - -let warn_deprecated_decimal = - CWarnings.create ~name:"decimal-numeral-notation" ~category:"deprecated" - (fun () -> - strbrk "Deprecated Number Notation for Decimal.uint, \ - Decimal.int or Decimal.decimal. Use Number.uint, \ - Number.int or Number.number respectively.") - -let error_params ind = - CErrors.user_err - (str "Wrong number of parameters for inductive" ++ spc () - ++ Printer.pr_global (GlobRef.IndRef ind) ++ str ".") - -let remapping_error ?loc ty ty' ty'' = - CErrors.user_err ?loc - (Printer.pr_global ty - ++ str " was already mapped to" ++ spc () ++ Printer.pr_global ty' - ++ str " and cannot be remapped to" ++ spc () ++ Printer.pr_global ty'' - ++ str ".") - -let error_missing c = - CErrors.user_err - (str "Missing mapping for constructor " ++ Printer.pr_global c ++ str ".") - -let pr_constr env sigma c = - let c = Constrextern.extern_constr env sigma (EConstr.of_constr c) in - Ppconstr.pr_constr_expr env sigma c - -let warn_via_remapping = - CWarnings.create ~name:"via-type-remapping" ~category:"numbers" - (fun (env, sigma, ty, ty', ty'') -> - let constr = pr_constr env sigma in - constr ty ++ str " was already mapped to" ++ spc () ++ constr ty' - ++ str ", mapping it also to" ++ spc () ++ constr ty'' - ++ str " might yield ill typed terms when using the notation.") - -let warn_via_type_mismatch = - CWarnings.create ~name:"via-type-mismatch" ~category:"numbers" - (fun (env, sigma, g, g', exp, actual) -> - let constr = pr_constr env sigma in - str "Type of" ++ spc() ++ Printer.pr_global g - ++ str " seems incompatible with the type of" ++ spc () - ++ Printer.pr_global g' ++ str "." ++ spc () - ++ str "Expected type is: " ++ constr exp ++ spc () - ++ str "instead of " ++ constr actual ++ str "." ++ spc () - ++ str "This might yield ill typed terms when using the notation.") - -let multiple_via_error () = - CErrors.user_err (Pp.str "Multiple 'via' options.") - -let multiple_after_error () = - CErrors.user_err (Pp.str "Multiple 'warning after' or 'abstract after' options.") - -let via_abstract_error () = - CErrors.user_err (Pp.str "'via' and 'abstract' cannot be used together.") - -let locate_global_sort_inductive_or_constant sigma qid = - let locate_sort qid = - match Nametab.locate_extended qid with - | Globnames.TrueGlobal _ -> raise Not_found - | Globnames.SynDef kn -> - match Syntax_def.search_syntactic_definition kn with - | [], Notation_term.NSort r -> - let sigma,c = Evd.fresh_sort_in_family sigma (Glob_ops.glob_sort_family r) in - sigma,Constr.mkSort c - | _ -> raise Not_found in - try locate_sort qid - with Not_found -> - match Smartlocate.global_with_alias qid with - | GlobRef.IndRef i -> sigma, Constr.mkInd i - | _ -> sigma, Constr.mkConst (Smartlocate.global_constant_with_alias qid) - -let locate_global_constructor_inductive_or_constant qid = - let g = Smartlocate.global_with_alias qid in - match g with - | GlobRef.ConstructRef c -> g, Constr.mkConstruct c - | GlobRef.IndRef i -> g, Constr.mkInd i - | _ -> g, Constr.mkConst (Smartlocate.global_constant_with_alias qid) - -(* [get_type env sigma c] retrieves the type of [c] and returns a pair - [l, t] such that [c : l_0 -> ... -> l_n -> t]. *) -let get_type env sigma c = - (* inspired from [compute_implicit_names] in "interp/impargs.ml" *) - let rec aux env acc t = - let t = Reductionops.whd_all env sigma t in - match EConstr.kind sigma t with - | Constr.Prod (na, a, b) -> - let a = Reductionops.whd_all env sigma a in - let rel = Context.Rel.Declaration.LocalAssum (na, a) in - aux (EConstr.push_rel rel env) ((na, a) :: acc) b - | _ -> List.rev acc, t in - let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in - let l, t = aux env [] t in - List.map (fun (na, a) -> na, EConstr.Unsafe.to_constr a) l, - EConstr.Unsafe.to_constr t - -(* [elaborate_to_post_params env sigma ty_ind params] builds the - [to_post] translation (c.f., interp/notation.mli) for the numeral - notation to parse/print type [ty_ind]. This translation is the - identity ([ToPostCopy]) except that it checks ([ToPostCheck]) that - the parameters of the inductive type [ty_ind] match the ones given - in [params]. *) -let elaborate_to_post_params env sigma ty_ind params = - let to_post_for_constructor indc = - let sigma, c = match indc with - | GlobRef.ConstructRef c -> - let sigma,c = Evd.fresh_constructor_instance env sigma c in - sigma, Constr.mkConstructU c - | _ -> assert false in (* c.f. get_constructors *) - let args, t = get_type env sigma c in - let params_indc = match Constr.kind t with - | Constr.App (_, a) -> Array.to_list a | _ -> [] in - let sz = List.length args in - let a = Array.make sz ToPostCopy in - if List.length params <> List.length params_indc then error_params ty_ind; - List.iter2 (fun param param_indc -> - match param, Constr.kind param_indc with - | Some p, Constr.Rel i when i <= sz -> a.(sz - i) <- ToPostCheck p - | _ -> ()) - params params_indc; - indc, indc, Array.to_list a in - let pt_refs = get_constructors ty_ind in - let to_post_0 = List.map to_post_for_constructor pt_refs in - let to_post = - let only_copy (_, _, args) = List.for_all ((=) ToPostCopy) args in - if (List.for_all only_copy to_post_0) then [||] else [|to_post_0|] in - to_post, pt_refs - -(* [elaborate_to_post_via env sigma ty_name ty_ind l] builds the [to_post] - translation (c.f., interp/notation.mli) for the number notation to - parse/print type [ty_name] through the inductive [ty_ind] according - to the pairs [constant, constructor] in the list [l]. *) -let elaborate_to_post_via env sigma ty_name ty_ind l = - let sigma, ty_name = - locate_global_sort_inductive_or_constant sigma ty_name in - let ty_ind = Constr.mkInd ty_ind in - (* Retrieve constants and constructors mappings and their type. - For each constant [cnst] and inductive constructor [indc] in [l], retrieve: - * its location: [lcnst] and [lindc] - * its GlobRef: [cnst] and [indc] - * its type: [tcnst] and [tindc] (decomposed in product by [get_type] above) - * [impls] are the implicit arguments of [cnst] *) - let l = - let read (consider_implicits, cnst, indc) = - let lcnst, lindc = cnst.CAst.loc, indc.CAst.loc in - let cnst, ccnst = locate_global_constructor_inductive_or_constant cnst in - let indc, cindc = - let indc = Smartlocate.global_constructor_with_alias indc in - GlobRef.ConstructRef indc, Constr.mkConstruct indc in - let get_type_wo_params c = - (* ignore parameters of inductive types *) - let rm_params c = match Constr.kind c with - | Constr.App (c, _) when Constr.isInd c -> c - | _ -> c in - let lc, tc = get_type env sigma c in - List.map (fun (n, c) -> n, rm_params c) lc, rm_params tc in - let tcnst, tindc = get_type_wo_params ccnst, get_type_wo_params cindc in - let impls = - if not consider_implicits then [] else - Impargs.(select_stronger_impargs (implicits_of_global cnst)) in - lcnst, cnst, tcnst, lindc, indc, tindc, impls in - List.map read l in - let eq_indc indc (_, _, _, _, indc', _, _) = GlobRef.equal indc indc' in - (* Collect all inductive types involved. - That is [ty_ind] and all final codomains of [tindc] above. *) - let inds = - List.fold_left (fun s (_, _, _, _, _, tindc, _) -> CSet.add (snd tindc) s) - (CSet.singleton ty_ind) l in - (* And for each inductive, retrieve its constructors. *) - let constructors = - CSet.fold (fun ind m -> - let inductive, _ = Constr.destInd ind in - CMap.add ind (get_constructors inductive) m) - inds CMap.empty in - (* Error if one [constructor] in some inductive in [inds] - doesn't appear exactly once in [l] *) - let _ = (* check_for duplicate constructor and error *) - List.fold_left (fun already_seen (_, cnst, _, loc, indc, _, _) -> - try - let cnst' = List.assoc_f GlobRef.equal indc already_seen in - remapping_error ?loc indc cnst' cnst - with Not_found -> (indc, cnst) :: already_seen) - [] l in - let () = (* check for missing constructor and error *) - CMap.iter (fun _ -> - List.iter (fun cstr -> - if not (List.exists (eq_indc cstr) l) then error_missing cstr)) - constructors in - (* Perform some checks on types and warn if they look strange. - These checks are neither sound nor complete, so we only warn. *) - let () = - (* associate inductives to types, and check that this mapping is one to one - and maps [ty_ind] to [ty_name] *) - let ind2ty, ty2ind = - let add loc ckey cval m = - match CMap.find_opt ckey m with - | None -> CMap.add ckey cval m - | Some old_cval -> - if not (Constr.equal old_cval cval) then - warn_via_remapping ?loc (env, sigma, ckey, old_cval, cval); - m in - List.fold_left - (fun (ind2ty, ty2ind) (lcnst, _, (_, tcnst), lindc, _, (_, tindc), _) -> - add lcnst tindc tcnst ind2ty, add lindc tcnst tindc ty2ind) - CMap.(singleton ty_ind ty_name, singleton ty_name ty_ind) l in - (* check that type of constants and constructors mapped in [l] - match modulo [ind2ty] *) - let rm_impls impls (l, t) = - let rec aux impls l = match impls, l with - | Some _ :: impls, _ :: b -> aux impls b - | None :: impls, (n, a) :: b -> (n, a) :: aux impls b - | _ -> l in - aux impls l, t in - let replace m (l, t) = - let apply_m c = try CMap.find c m with Not_found -> c in - List.fold_right (fun (na, a) b -> Constr.mkProd (na, (apply_m a), b)) - l (apply_m t) in - List.iter (fun (_, cnst, tcnst, loc, indc, tindc, impls) -> - let tcnst = rm_impls impls tcnst in - let tcnst' = replace CMap.empty tcnst in - if not (Constr.equal tcnst' (replace ind2ty tindc)) then - let actual = replace CMap.empty tindc in - let expected = replace ty2ind tcnst in - warn_via_type_mismatch ?loc (env, sigma, indc, cnst, expected, actual)) - l in - (* Associate an index to each inductive, starting from 0 for [ty_ind]. *) - let ind2num, num2ind, nb_ind = - CMap.fold (fun ind _ (ind2num, num2ind, i) -> - CMap.add ind i ind2num, Int.Map.add i ind num2ind, i + 1) - (CMap.remove ty_ind constructors) - (CMap.singleton ty_ind 0, Int.Map.singleton 0 ty_ind, 1) in - (* Finally elaborate [to_post] *) - let to_post = - let rec map_prod impls tindc = match impls with - | Some _ :: impls -> ToPostHole :: map_prod impls tindc - | _ -> - match tindc with - | [] -> [] - | (_, a) :: b -> - let t = match CMap.find_opt a ind2num with - | Some i -> ToPostAs i - | None -> ToPostCopy in - let impls = match impls with [] -> [] | _ :: t -> t in - t :: map_prod impls b in - Array.init nb_ind (fun i -> - List.map (fun indc -> - let _, cnst, _, _, _, tindc, impls = List.find (eq_indc indc) l in - indc, cnst, map_prod impls (fst tindc)) - (CMap.find (Int.Map.find i num2ind) constructors)) in - (* and use constants mapped to constructors of [ty_ind] as triggers. *) - let pt_refs = List.map (fun (_, cnst, _) -> cnst) (to_post.(0)) in - to_post, pt_refs - -let locate_global_inductive allow_params qid = - let locate_param_inductive qid = - match Nametab.locate_extended qid with - | Globnames.TrueGlobal _ -> raise Not_found - | Globnames.SynDef kn -> - match Syntax_def.search_syntactic_definition kn with - | [], Notation_term.(NApp (NRef (GlobRef.IndRef i), l)) when allow_params -> - i, - List.map (function - | Notation_term.NRef r -> Some r - | Notation_term.NHole _ -> None - | _ -> raise Not_found) l - | _ -> raise Not_found in - try locate_param_inductive qid - with Not_found -> Smartlocate.global_inductive_with_alias qid, [] - -let vernac_number_notation local ty f g opts scope = - let rec parse_opts = function - | [] -> None, Nop - | h :: opts -> - let via, opts = parse_opts opts in - let via = match h, via with - | Via _, Some _ -> multiple_via_error () - | Via v, None -> Some v - | _ -> via in - let opts = match h, opts with - | After _, (Warning _ | Abstract _) -> multiple_after_error () - | After a, Nop -> a - | _ -> opts in - via, opts in - let via, opts = parse_opts opts in - (match via, opts with Some _, Abstract _ -> via_abstract_error () | _ -> ()); - let env = Global.env () in - let sigma = Evd.from_env env in - let num_ty = locate_number () in - let z_pos_ty = locate_z () in - let int63_ty = locate_int63 () in - let ty_name = ty in - let ty, via = - match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in - let tyc, params = locate_global_inductive (via = None) ty in - let to_ty = Smartlocate.global_with_alias f in - let of_ty = Smartlocate.global_with_alias g in - let cty = mkRefC ty in - let app x y = mkAppC (x,[y]) in - let arrow x y = - mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) - in - let opt r = app (mkRefC (q_option ())) r in - (* Check the type of f *) - let to_kind = - match num_ty with - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint cty) -> UInt int_ty, Direct - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty, Option - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Number num_ty, Direct - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Number num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint cty) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint cty) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal num_ty, Option - | _ -> - match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option - | _ -> - match int63_ty with - | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct - | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option - | _ -> type_error_to f ty - in - (* Check the type of g *) - let of_kind = - match num_ty with - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty cuint) -> UInt int_ty, Direct - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty, Option - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Number num_ty, Direct - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Number num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty cint) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty cuint) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal num_ty, Option - | _ -> - match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option - | _ -> - match int63_ty with - | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct - | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option - | _ -> type_error_of g ty - in - (match to_kind, of_kind with - | ((DecimalInt _ | DecimalUInt _ | Decimal _), _), _ - | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> - warn_deprecated_decimal () - | _ -> ()); - let to_post, pt_refs = match via with - | None -> elaborate_to_post_params env sigma tyc params - | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in - let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; - warning = opts } - in - (match opts, to_kind with - | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty - | _ -> ()); - let i = - { pt_local = local; - pt_scope = scope; - pt_interp_info = NumberNotation o; - pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; - pt_refs; - pt_in_match = true } - in - enable_prim_token_interpretation i diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli deleted file mode 100644 index 5a13d1068b..0000000000 --- a/plugins/syntax/numeral.mli +++ /dev/null @@ -1,26 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* - qualid -> - qualid -> qualid -> - number_option list -> - Notation_term.scope_name -> unit diff --git a/plugins/syntax/numeral_notation_plugin.mlpack b/plugins/syntax/numeral_notation_plugin.mlpack deleted file mode 100644 index f4d9cae3ff..0000000000 --- a/plugins/syntax/numeral_notation_plugin.mlpack +++ /dev/null @@ -1,2 +0,0 @@ -Numeral -G_numeral diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index dbb0e92d5c..98ea318c92 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -9,7 +9,6 @@ (************************************************************************) open Pp -open Util open Names open Libnames open Constrexpr diff --git a/plugins/syntax/string_notation_plugin.mlpack b/plugins/syntax/string_notation_plugin.mlpack deleted file mode 100644 index 6aa081dab4..0000000000 --- a/plugins/syntax/string_notation_plugin.mlpack +++ /dev/null @@ -1,2 +0,0 @@ -String_notation -G_string diff --git a/theories/Init/Byte.v b/theories/Init/Byte.v index 7449b52d76..e03820ef22 100644 --- a/theories/Init/Byte.v +++ b/theories/Init/Byte.v @@ -16,7 +16,7 @@ Require Import Coq.Init.Logic. Require Import Coq.Init.Specif. Require Coq.Init.Nat. -Declare ML Module "string_notation_plugin". +Declare ML Module "number_string_notation_plugin". (** We define an inductive for use with the [String Notation] command which contains all ascii characters. We use 256 constructors for diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 0239778bac..9f8a054b5c 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -30,8 +30,6 @@ Require Export Coq.Init.Tauto. *) Declare ML Module "cc_plugin". Declare ML Module "ground_plugin". -Declare ML Module "numeral_notation_plugin". -Declare ML Module "string_notation_plugin". (* Parsing / printing of hexadecimal numbers *) Arguments Nat.of_hex_uint d%hex_uint_scope. diff --git a/theories/dune b/theories/dune index e7e4ba9981..18e000cfe1 100644 --- a/theories/dune +++ b/theories/dune @@ -14,8 +14,7 @@ coq.plugins.cc coq.plugins.firstorder - coq.plugins.numeral_notation - coq.plugins.string_notation + coq.plugins.number_string_notation coq.plugins.int63_syntax coq.plugins.float_syntax -- cgit v1.2.3 From b6214bd4d5d3003e9b60411a717e84277feead24 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:27:00 +0200 Subject: [string notation] Handle parameterized inductives and non inductives --- doc/sphinx/user-extensions/syntax-extensions.rst | 349 ++++++++++++----------- doc/tools/docgram/common.edit_mlg | 7 +- doc/tools/docgram/fullGrammar | 14 +- doc/tools/docgram/orderedGrammar | 6 +- interp/notation.ml | 9 +- plugins/syntax/g_number_string.mlg | 32 ++- plugins/syntax/number.mli | 5 + plugins/syntax/string_notation.ml | 27 +- plugins/syntax/string_notation.mli | 4 +- test-suite/output/StringSyntax.out | 16 +- test-suite/output/StringSyntax.v | 45 +++ 11 files changed, 296 insertions(+), 218 deletions(-) diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 60fbd68687..a52d7f08f0 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1386,7 +1386,7 @@ Scopes` or :cmd:`Print Scope`. ``char_scope`` This scope includes interpretation for all strings of the form ``"c"`` where :g:`c` is an ASCII character, or of the form ``"nnn"`` where nnn is - a three-digits number (possibly with leading 0's), or of the form + a three-digit number (possibly with leading 0s), or of the form ``""""``. Their respective denotations are the ASCII code of :g:`c`, the decimal ASCII code ``nnn``, or the ascii code of the character ``"`` (i.e. the ASCII code 34), all of them being represented in the type :g:`ascii`. @@ -1556,13 +1556,13 @@ Number notations .. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print {? ( {+, @number_modifier } ) } : @scope_name :name: Number Notation - .. insertprodn number_modifier number_via + .. insertprodn number_modifier number_string_via .. prodn:: number_modifier ::= warning after @bignat | abstract after @bignat - | @number_via - number_via ::= via @qualid mapping [ {+, {| @qualid => @qualid | [ @qualid ] => @qualid } } ] + | @number_string_via + number_string_via ::= via @qualid mapping [ {+, {| @qualid => @qualid | [ @qualid ] => @qualid } } ] This command allows the user to customize the way number literals are parsed and printed. @@ -1608,11 +1608,7 @@ Number notations function application, constructors, inductive type families, sorts, and primitive integers) will be considered for printing. - .. note:: - Number notations for parameterized inductive types can be - added by declaring an :ref:`abbreviation ` - for the inductive which instantiates all parameters. See - example below. + .. _number-string-via: :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` When using this option, :n:`@qualid__type` no @@ -1649,22 +1645,6 @@ Number notations To use a :token:`sort` as the target type :n:`@qualid__type`, use an :ref:`abbreviation ` as in the :ref:`example below `. - .. exn:: @qualid was already mapped to @qualid and cannot be remapped to @qualid - - Duplicates are not allowed in the :n:`mapping` list. - - .. exn:: Missing mapping for constructor @qualid - - A mapping should be provided for :n:`@qualid` in the :n:`mapping` list. - - .. warn:: @type was already mapped to @type, mapping it also to @type might yield ill typed terms when using the notation. - - Two pairs in the :n:`mapping` list associate types that might be incompatible. - - .. warn:: Type of @qualid seems incompatible with the type of @qualid. Expected type is: @type instead of @type. This might yield ill typed terms when using the notation. - - A mapping given in the :n:`mapping` list associates a constant with a seemingly incompatible constructor. - :n:`warning after @bignat` displays a warning message about a possible stack overflow when calling :n:`@qualid__parse` to parse a literal larger than :n:`@bignat`. @@ -1748,166 +1728,47 @@ Number notations At most one :g:`warning after` or :g:`abstract after` option can be given. - .. _example-number-notation-non-inductive: - - .. example:: Number Notation for a non inductive type - - The following example encodes the terms in the form :g:`sum unit ( ... (sum unit unit) ... )` - as the number of units in the term. For instance :g:`sum unit (sum unit unit)` - is encoded as :g:`3` while :g:`unit` is :g:`1` and :g:`0` stands for :g:`Empty_set`. - The inductive :g:`I` will be used as :n:`@qualid__ind`. - - .. coqtop:: in - - Inductive I := Iempty : I | Iunit : I | Isum : I -> I -> I. - - We then define :n:`@qualid__parse` and :n:`@qualid__print` - - .. coqtop:: in - - Definition of_uint (x : Number.uint) : I := - let fix f n := match n with - | O => Iempty | S O => Iunit - | S n => Isum Iunit (f n) end in - f (Nat.of_num_uint x). - - Definition to_uint (x : I) : Number.uint := - let fix f i := match i with - | Iempty => O | Iunit => 1 - | Isum i1 i2 => f i1 + f i2 end in - Nat.to_num_uint (f x). - - Inductive sum (A : Set) (B : Set) : Set := pair : A -> B -> sum A B. - - the number notation itself - - .. coqtop:: in - - Notation nSet := Set (only parsing). - Number Notation nSet of_uint to_uint (via I - mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) : type_scope. - - and check the printer - - .. coqtop:: all - - Local Open Scope type_scope. - Check sum unit (sum unit unit). - - and the parser - - .. coqtop:: all - - Set Printing All. - Check 3. - - .. _example-number-notation-implicit-args: - - .. example:: Number Notation with implicit arguments - - The following example parses and prints natural numbers between - :g:`0` and :g:`n-1` as terms of type :g:`Fin.t n`. - - .. coqtop:: all reset - - Require Import Vector. - Print Fin.t. - - Note the implicit arguments of :g:`Fin.F1` and :g:`Fin.FS`, - which won't appear in the corresponding inductive type. - - .. coqtop:: in - - Inductive I := I1 : I | IS : I -> I. - - Definition of_uint (x : Number.uint) : I := - let fix f n := match n with O => I1 | S n => IS (f n) end in - f (Nat.of_num_uint x). - - Definition to_uint (x : I) : Number.uint := - let fix f i := match i with I1 => O | IS n => S (f n) end in - Nat.to_num_uint (f x). - - Declare Scope fin_scope. - Delimit Scope fin_scope with fin. - Local Open Scope fin_scope. - Number Notation Fin.t of_uint to_uint (via I - mapping [[Fin.F1] => I1, [Fin.FS] => IS]) : fin_scope. - - Now :g:`2` is parsed as :g:`Fin.FS (Fin.FS Fin.F1)`, that is - :g:`@Fin.FS _ (@Fin.FS _ (@Fin.F1 _))`. - - .. coqtop:: all - - Check 2. - - which can be of type :g:`Fin.t 3` (numbers :g:`0`, :g:`1` and :g:`2`) - - .. coqtop:: all - - Check 2 : Fin.t 3. - - but cannot be of type :g:`Fin.t 2` (only :g:`0` and :g:`1`) - - .. coqtop:: all fail - - Check 2 : Fin.t 2. - - .. example:: Number Notation with a parameterized inductive type - - .. coqtop:: in reset - - Definition of_uint u : list unit := - let fix f n := match n with O => nil | S n => cons tt (f n) end in - f (Nat.of_num_uint u). - Definition to_uint (l : list unit) := Nat.to_num_uint (length l). - - The parameter :g:`unit` for the parameterized inductive type - :g:`list` is given through an :ref:`abbreviation - `. - - .. coqtop:: in - - Notation list_unit := (list unit) (only parsing). - Number Notation list_unit of_uint to_uint : nat_scope. - .. _string-notations: String notations ~~~~~~~~~~~~~~~~ -.. cmd:: String Notation @qualid @qualid__parse @qualid__print : @scope_name +.. cmd:: String Notation @qualid__type @qualid__parse @qualid__print {? ( @number_string_via ) } : @scope_name :name: String Notation Allows the user to customize how strings are parsed and printed. - The token :n:`@qualid` should be the name of an inductive type, - while :n:`@qualid__parse` and :n:`@qualid__print` should be the names of the - parsing and printing functions, respectively. The parsing function - :n:`@qualid__parse` should have one of the following types: + :n:`@qualid__type` + the name of an inductive type, + while :n:`@qualid__parse` and :n:`@qualid__print` should be the names of the + parsing and printing functions, respectively. The parsing function + :n:`@qualid__parse` should have one of the following types: - * :n:`Byte.byte -> @qualid` - * :n:`Byte.byte -> option @qualid` - * :n:`list Byte.byte -> @qualid` - * :n:`list Byte.byte -> option @qualid` + * :n:`Byte.byte -> @qualid__type` + * :n:`Byte.byte -> option @qualid__type` + * :n:`list Byte.byte -> @qualid__type` + * :n:`list Byte.byte -> option @qualid__type` - The printing function :n:`@qualid__print` should have one of the - following types: + The printing function :n:`@qualid__print` should have one of the + following types: - * :n:`@qualid -> Byte.byte` - * :n:`@qualid -> option Byte.byte` - * :n:`@qualid -> list Byte.byte` - * :n:`@qualid -> option (list Byte.byte)` + * :n:`@qualid__type -> Byte.byte` + * :n:`@qualid__type -> option Byte.byte` + * :n:`@qualid__type -> list Byte.byte` + * :n:`@qualid__type -> option (list Byte.byte)` - When parsing, the application of the parsing function - :n:`@qualid__parse` to the string will be fully reduced, and universes - of the resulting term will be refreshed. + When parsing, the application of the parsing function + :n:`@qualid__parse` to the string will be fully reduced, and universes + of the resulting term will be refreshed. + + Note that only fully-reduced ground terms (terms containing only + function application, constructors, inductive type families, + sorts, and primitive integers) will be considered for printing. - Note that only fully-reduced ground terms (terms containing only - function application, constructors, inductive type families, - sorts, and primitive integers) will be considered for printing. + :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` + works as for :ref:`number notations above `. - .. exn:: Cannot interpret this string as a value of type @type + .. exn:: Cannot interpret this string as a value of type @type The string notation registered for :token:`type` does not support the given string. This error is given when the interpretation @@ -1926,7 +1787,7 @@ String notations .. exn:: Unexpected term @term while parsing a string notation. Parsing functions must always return ground terms, made up of - applications of constructors, inductive types, and primitive + function application, constructors, inductive type families, sorts and primitive integers. Parsing functions may not return terms containing axioms, bare (co)fixpoints, lambdas, etc. @@ -1937,12 +1798,33 @@ String notations concrete string expressed as a decimal. They may not return opaque constants. +.. note:: + Number or string notations for parameterized inductive types can be + added by declaring an :ref:`abbreviation ` for the + inductive which instantiates all parameters. See :ref:`example below `. + The following errors apply to both string and number notations: .. exn:: @type is not an inductive type. String and number notations can only be declared for inductive types. - Declare number notations for non-inductive types using :n:`@number_via`. + Declare string or numeral notations for non-inductive types using :n:`@number_string_via`. + + .. exn:: @qualid was already mapped to @qualid and cannot be remapped to @qualid + + Duplicates are not allowed in the :n:`mapping` list. + + .. exn:: Missing mapping for constructor @qualid + + A mapping should be provided for :n:`@qualid` in the :n:`mapping` list. + + .. warn:: @type was already mapped to @type, mapping it also to @type might yield ill typed terms when using the notation. + + Two pairs in the :n:`mapping` list associate types that might be incompatible. + + .. warn:: Type of @qualid seems incompatible with the type of @qualid. Expected type is: @type instead of @type. This might yield ill typed terms when using the notation. + + A mapping given in the :n:`mapping` list associates a constant with a seemingly incompatible constructor. .. exn:: Cannot interpret in @scope_name because @qualid could not be found in the current environment. @@ -1975,6 +1857,129 @@ The following errors apply to both string and number notations: .. todo note on "single qualified identifiers" https://github.com/coq/coq/pull/11718#discussion_r415076703 +.. _example-number-notation-non-inductive: + +.. example:: Number Notation for a non inductive type + + The following example encodes the terms in the form :g:`sum unit ( ... (sum unit unit) ... )` + as the number of units in the term. For instance :g:`sum unit (sum unit unit)` + is encoded as :g:`3` while :g:`unit` is :g:`1` and :g:`0` stands for :g:`Empty_set`. + The inductive :g:`I` will be used as :n:`@qualid__ind`. + + .. coqtop:: in + + Inductive I := Iempty : I | Iunit : I | Isum : I -> I -> I. + + We then define :n:`@qualid__parse` and :n:`@qualid__print` + + .. coqtop:: in + + Definition of_uint (x : Number.uint) : I := + let fix f n := match n with + | O => Iempty | S O => Iunit + | S n => Isum Iunit (f n) end in + f (Nat.of_num_uint x). + + Definition to_uint (x : I) : Number.uint := + let fix f i := match i with + | Iempty => O | Iunit => 1 + | Isum i1 i2 => f i1 + f i2 end in + Nat.to_num_uint (f x). + + Inductive sum (A : Set) (B : Set) : Set := pair : A -> B -> sum A B. + + the number notation itself + + .. coqtop:: in + + Notation nSet := Set (only parsing). + Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) : type_scope. + + and check the printer + + .. coqtop:: all + + Local Open Scope type_scope. + Check sum unit (sum unit unit). + + and the parser + + .. coqtop:: all + + Set Printing All. + Check 3. + +.. _example-number-notation-implicit-args: + +.. example:: Number Notation with implicit arguments + + The following example parses and prints natural numbers between + :g:`0` and :g:`n-1` as terms of type :g:`Fin.t n`. + + .. coqtop:: all reset + + Require Import Vector. + Print Fin.t. + + Note the implicit arguments of :g:`Fin.F1` and :g:`Fin.FS`, + which won't appear in the corresponding inductive type. + + .. coqtop:: in + + Inductive I := I1 : I | IS : I -> I. + + Definition of_uint (x : Number.uint) : I := + let fix f n := match n with O => I1 | S n => IS (f n) end in + f (Nat.of_num_uint x). + + Definition to_uint (x : I) : Number.uint := + let fix f i := match i with I1 => O | IS n => S (f n) end in + Nat.to_num_uint (f x). + + Declare Scope fin_scope. + Delimit Scope fin_scope with fin. + Local Open Scope fin_scope. + Number Notation Fin.t of_uint to_uint (via I + mapping [[Fin.F1] => I1, [Fin.FS] => IS]) : fin_scope. + + Now :g:`2` is parsed as :g:`Fin.FS (Fin.FS Fin.F1)`, that is + :g:`@Fin.FS _ (@Fin.FS _ (@Fin.F1 _))`. + + .. coqtop:: all + + Check 2. + + which can be of type :g:`Fin.t 3` (numbers :g:`0`, :g:`1` and :g:`2`) + + .. coqtop:: all + + Check 2 : Fin.t 3. + + but cannot be of type :g:`Fin.t 2` (only :g:`0` and :g:`1`) + + .. coqtop:: all fail + + Check 2 : Fin.t 2. + +.. _example-string-notation-parameterized-inductive: + +.. example:: String Notation with a parameterized inductive type + + The parameter :g:`Byte.byte` for the parameterized inductive type + :g:`list` is given through an :ref:`abbreviation `. + + .. coqtop:: in reset + + Notation string := (list Byte.byte) (only parsing). + Definition id_string := @id string. + + String Notation string id_string id_string : list_scope. + + .. coqtop:: all + + Check "abc"%list. + .. _TacticNotation: Tactic Notations diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index e43583de09..5de1f09c53 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -1289,8 +1289,8 @@ command: [ | WITH "Number" "Notation" reference reference reference OPT number_options ":" scope_name | REPLACE "Numeral" "Notation" reference reference reference ":" ident deprecated_number_modifier | WITH "Numeral" "Notation" reference reference reference ":" scope_name deprecated_number_modifier -| REPLACE "String" "Notation" reference reference reference ":" ident -| WITH "String" "Notation" reference reference reference ":" scope_name +| REPLACE "String" "Notation" reference reference reference OPT string_option ":" ident +| WITH "String" "Notation" reference reference reference OPT string_option ":" scope_name | DELETE "Ltac2" ltac2_entry (* was split up *) | DELETE "Add" "Zify" "InjTyp" constr (* micromega plugin *) @@ -2460,8 +2460,9 @@ SPLICE: [ | constr_with_bindings | simple_binding | ssexpr35 (* strange in mlg, ssexpr50 is after this *) -| number_mapping +| number_string_mapping | number_options +| string_option ] (* end SPLICE *) RENAME: [ diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 3a0c3a8bc7..826a0b6f36 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -688,7 +688,7 @@ command: [ | "Print" "Fields" (* ring plugin *) | "Number" "Notation" reference reference reference OPT number_options ":" ident | "Numeral" "Notation" reference reference reference ":" ident deprecated_number_modifier -| "String" "Notation" reference reference reference ":" ident +| "String" "Notation" reference reference reference OPT string_option ":" ident | "Ltac2" ltac2_entry (* Ltac2 plugin *) | "Ltac2" "Eval" ltac2_expr6 (* Ltac2 plugin *) | "Print" "Ltac2" reference (* Ltac2 plugin *) @@ -2555,25 +2555,29 @@ deprecated_number_modifier: [ | "(" "abstract" "after" bignat ")" ] -number_mapping: [ +number_string_mapping: [ | reference "=>" reference | "[" reference "]" "=>" reference ] -number_via: [ -| "via" reference "mapping" "[" LIST1 number_mapping SEP "," "]" +number_string_via: [ +| "via" reference "mapping" "[" LIST1 number_string_mapping SEP "," "]" ] number_modifier: [ | "warning" "after" bignat | "abstract" "after" bignat -| number_via +| number_string_via ] number_options: [ | "(" LIST1 number_modifier SEP "," ")" ] +string_option: [ +| "(" number_string_via ")" +] + tac2pat1: [ | Prim.qualid LIST1 tac2pat0 (* Ltac2 plugin *) | Prim.qualid (* Ltac2 plugin *) diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 13d8979208..151438bbbd 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -910,7 +910,7 @@ command: [ | "Declare" "Right" "Step" one_term | "Number" "Notation" qualid qualid qualid OPT ( "(" LIST1 number_modifier SEP "," ")" ) ":" scope_name | "Numeral" "Notation" qualid qualid qualid ":" scope_name deprecated_number_modifier -| "String" "Notation" qualid qualid qualid ":" scope_name +| "String" "Notation" qualid qualid qualid OPT ( "(" number_string_via ")" ) ":" scope_name | "SubClass" ident_decl def_body | thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] | assumption_token OPT ( "Inline" OPT ( "(" natural ")" ) ) [ LIST1 ( "(" assumpt ")" ) | assumpt ] @@ -1278,10 +1278,10 @@ deprecated_number_modifier: [ number_modifier: [ | "warning" "after" bignat | "abstract" "after" bignat -| number_via +| number_string_via ] -number_via: [ +number_string_via: [ | "via" qualid "mapping" "[" LIST1 [ qualid "=>" qualid | "[" qualid "]" "=>" qualid ] SEP "," "]" ] diff --git a/interp/notation.ml b/interp/notation.ml index 1839e287d7..5f6fd62e5c 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1107,11 +1107,12 @@ let coqbyte_of_string ?loc byte s = let p = if Int.equal (String.length s) 1 then int_of_char s.[0] else - if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] - then int_of_string s - else + let n = + if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] + then int_of_string s else 256 in + if n < 256 then n else user_err ?loc ~hdr:"coqbyte_of_string" - (str "Expects a single character or a three-digits ascii code.") in + (str "Expects a single character or a three-digit ASCII code.") in coqbyte_of_char_code byte p let coqbyte_of_char byte c = coqbyte_of_char_code byte (Char.code c) diff --git a/plugins/syntax/g_number_string.mlg b/plugins/syntax/g_number_string.mlg index b584505530..c8badd238d 100644 --- a/plugins/syntax/g_number_string.mlg +++ b/plugins/syntax/g_number_string.mlg @@ -32,7 +32,7 @@ let warn_deprecated_numeral_notation = (fun () -> strbrk "Numeral Notation is deprecated, please use Number Notation instead.") -let pr_number_mapping (b, n, n') = +let pr_number_string_mapping (b, n, n') = if b then str "[" ++ Libnames.pr_qualid n ++ str "]" ++ spc () ++ str "=>" ++ spc () ++ Libnames.pr_qualid n' @@ -40,17 +40,20 @@ let pr_number_mapping (b, n, n') = Libnames.pr_qualid n ++ spc () ++ str "=>" ++ spc () ++ Libnames.pr_qualid n' -let pr_number_via (n, l) = +let pr_number_string_via (n, l) = str "via " ++ Libnames.pr_qualid n ++ str " mapping [" - ++ prlist_with_sep pr_comma pr_number_mapping l ++ str "]" + ++ prlist_with_sep pr_comma pr_number_string_mapping l ++ str "]" let pr_number_modifier = function | After a -> pr_number_after a - | Via nl -> pr_number_via nl + | Via nl -> pr_number_string_via nl let pr_number_options l = str "(" ++ prlist_with_sep pr_comma pr_number_modifier l ++ str ")" +let pr_string_option l = + str "(" ++ pr_number_string_via l ++ str ")" + } VERNAC ARGUMENT EXTEND deprecated_number_modifier @@ -60,22 +63,22 @@ VERNAC ARGUMENT EXTEND deprecated_number_modifier | [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } END -VERNAC ARGUMENT EXTEND number_mapping - PRINTED BY { pr_number_mapping } +VERNAC ARGUMENT EXTEND number_string_mapping + PRINTED BY { pr_number_string_mapping } | [ reference(n) "=>" reference(n') ] -> { false, n, n' } | [ "[" reference(n) "]" "=>" reference(n') ] -> { true, n, n' } END -VERNAC ARGUMENT EXTEND number_via - PRINTED BY { pr_number_via } -| [ "via" reference(n) "mapping" "[" ne_number_mapping_list_sep(l, ",") "]" ] -> { n, l } +VERNAC ARGUMENT EXTEND number_string_via + PRINTED BY { pr_number_string_via } +| [ "via" reference(n) "mapping" "[" ne_number_string_mapping_list_sep(l, ",") "]" ] -> { n, l } END VERNAC ARGUMENT EXTEND number_modifier PRINTED BY { pr_number_modifier } | [ "warning" "after" bignat(waft) ] -> { After (Warning (NumTok.UnsignedNat.of_string waft)) } | [ "abstract" "after" bignat(n) ] -> { After (Abstract (NumTok.UnsignedNat.of_string n)) } -| [ number_via(v) ] -> { Via v } +| [ number_string_via(v) ] -> { Via v } END VERNAC ARGUMENT EXTEND number_options @@ -83,6 +86,11 @@ VERNAC ARGUMENT EXTEND number_options | [ "(" ne_number_modifier_list_sep(l, ",") ")" ] -> { l } END +VERNAC ARGUMENT EXTEND string_option + PRINTED BY { pr_string_option } +| [ "(" number_string_via(v) ")" ] -> { v } +END + VERNAC COMMAND EXTEND NumberNotation CLASSIFIED AS SIDEFF | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) number_options_opt(nl) ":" ident(sc) ] -> @@ -96,7 +104,7 @@ VERNAC COMMAND EXTEND NumberNotation CLASSIFIED AS SIDEFF END VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) string_option_opt(o) ":" ident(sc) ] -> - { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } + { vernac_string_notation (Locality.make_module_locality locality) ty f g o (Id.to_string sc) } END diff --git a/plugins/syntax/number.mli b/plugins/syntax/number.mli index 5a13d1068b..d7d28b29ed 100644 --- a/plugins/syntax/number.mli +++ b/plugins/syntax/number.mli @@ -24,3 +24,8 @@ val vernac_number_notation : locality_flag -> qualid -> qualid -> number_option list -> Notation_term.scope_name -> unit + +(** These are also used in string notations *) +val locate_global_inductive : bool -> Libnames.qualid -> Names.inductive * Names.GlobRef.t option list +val elaborate_to_post_params : Environ.env -> Evd.evar_map -> Names.inductive -> Names.GlobRef.t option list -> (Names.GlobRef.t * Names.GlobRef.t * Notation.to_post_arg list) list array * Names.GlobRef.t list +val elaborate_to_post_via : Environ.env -> Evd.evar_map -> Libnames.qualid -> Names.inductive -> (bool * Libnames.qualid * Libnames.qualid) list -> (Names.GlobRef.t * Names.GlobRef.t * Notation.to_post_arg list) list array * Names.GlobRef.t list diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index 98ea318c92..774d59dda3 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -14,15 +14,10 @@ open Libnames open Constrexpr open Constrexpr_ops open Notation +open Number (** * String notation *) -let get_constructors ind = - let mib,oib = Global.lookup_inductive ind in - let mc = oib.Declarations.mind_consnames in - Array.to_list - (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) - let qualid_of_ref n = n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty @@ -45,7 +40,7 @@ let type_error_of g ty = (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)).") -let vernac_string_notation local ty f g scope = +let vernac_string_notation local ty f g via scope = let env = Global.env () in let sigma = Evd.from_env env in let app x y = mkAppC (x,[y]) in @@ -55,14 +50,16 @@ let vernac_string_notation local ty f g scope = let coption = cref (q_option ()) in let opt r = app coption r in let clist_byte = app clist cbyte in - let tyc = Smartlocate.global_inductive_with_alias ty in + let ty_name = ty in + let ty, via = + match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in + let tyc, params = locate_global_inductive (via = None) ty in let to_ty = Smartlocate.global_with_alias f in let of_ty = Smartlocate.global_with_alias g in let cty = cref ty in let arrow x y = mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) in - let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = if has_type env sigma f (arrow clist_byte cty) then ListByte, Direct @@ -79,12 +76,10 @@ let vernac_string_notation local ty f g scope = else if has_type env sigma g (arrow cty (opt cbyte)) then Byte, Option else type_error_of g ty in - let o = { to_kind = to_kind; - to_ty = to_ty; - to_post = [||]; - of_kind = of_kind; - of_ty = of_ty; - ty_name = ty; + let to_post, pt_refs = match via with + | None -> elaborate_to_post_params env sigma tyc params + | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; warning = () } in let i = @@ -92,7 +87,7 @@ let vernac_string_notation local ty f g scope = pt_scope = scope; pt_interp_info = StringNotation o; pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; - pt_refs = constructors; + pt_refs; pt_in_match = true } in enable_prim_token_interpretation i diff --git a/plugins/syntax/string_notation.mli b/plugins/syntax/string_notation.mli index 0d99f98d26..f3c7c969c6 100644 --- a/plugins/syntax/string_notation.mli +++ b/plugins/syntax/string_notation.mli @@ -14,5 +14,7 @@ open Vernacexpr (** * String notation *) val vernac_string_notation : locality_flag -> - qualid -> qualid -> qualid -> + qualid -> + qualid -> qualid -> + Number.number_string_via option -> Notation_term.scope_name -> unit diff --git a/test-suite/output/StringSyntax.out b/test-suite/output/StringSyntax.out index e9cf4282dc..125c1bc927 100644 --- a/test-suite/output/StringSyntax.out +++ b/test-suite/output/StringSyntax.out @@ -1051,7 +1051,7 @@ Arguments byte_ind _%function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ "127" : byte The command has indeed failed with message: -Expects a single character or a three-digits ascii code. +Expects a single character or a three-digit ASCII code. "000" : ascii "a" @@ -1059,7 +1059,7 @@ Expects a single character or a three-digits ascii code. "127" : ascii The command has indeed failed with message: -Expects a single character or a three-digits ascii code. +Expects a single character or a three-digit ASCII code. "000" : string "a" @@ -1084,3 +1084,15 @@ Expects a single character or a three-digits ascii code. = ["000"; "001"; "002"; "003"; "004"; "005"; "006"; "007"; "008"; "009"; "010"; "011"; "012"; "013"; "014"; "015"; "016"; "017"; "018"; "019"; "020"; "021"; "022"; "023"; "024"; "025"; "026"; "027"; "028"; "029"; "030"; "031"; " "; "!"; """"; "#"; "$"; "%"; "&"; "'"; "("; ")"; "*"; "+"; ","; "-"; "."; "/"; "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; ":"; ";"; "<"; "="; ">"; "?"; "@"; "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"; "["; "\"; "]"; "^"; "_"; "`"; "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; "s"; "t"; "u"; "v"; "w"; "x"; "y"; "z"; "{"; "|"; "}"; "~"; "127"; "128"; "129"; "130"; "131"; "132"; "133"; "134"; "135"; "136"; "137"; "138"; "139"; "140"; "141"; "142"; "143"; "144"; "145"; "146"; "147"; "148"; "149"; "150"; "151"; "152"; "153"; "154"; "155"; "156"; "157"; "158"; "159"; "160"; "161"; "162"; "163"; "164"; "165"; "166"; "167"; "168"; "169"; "170"; "171"; "172"; "173"; "174"; "175"; "176"; "177"; "178"; "179"; "180"; "181"; "182"; "183"; "184"; "185"; "186"; "187"; "188"; "189"; "190"; "191"; "192"; "193"; "194"; "195"; "196"; "197"; "198"; "199"; "200"; "201"; "202"; "203"; "204"; "205"; "206"; "207"; "208"; "209"; "210"; "211"; "212"; "213"; "214"; "215"; "216"; "217"; "218"; "219"; "220"; "221"; "222"; "223"; "224"; "225"; "226"; "227"; "228"; "229"; "230"; "231"; "232"; "233"; "234"; "235"; "236"; "237"; "238"; "239"; "240"; "241"; "242"; "243"; "244"; "245"; "246"; "247"; "248"; "249"; "250"; "251"; "252"; "253"; "254"; "255"] : list ascii +"abc" + : string +"000" + : nat +"001" + : nat +"002" + : nat +"255" + : nat +The command has indeed failed with message: +Expects a single character or a three-digit ASCII code. diff --git a/test-suite/output/StringSyntax.v b/test-suite/output/StringSyntax.v index aab6e0bb03..49584487a3 100644 --- a/test-suite/output/StringSyntax.v +++ b/test-suite/output/StringSyntax.v @@ -50,3 +50,48 @@ Local Close Scope byte_scope. Local Open Scope char_scope. Compute List.map Ascii.ascii_of_nat (List.seq 0 256). Local Close Scope char_scope. + +(* Test numeral notations for parameterized inductives *) +Module Test2. + +Notation string := (list Byte.byte). +Definition id_string := @id string. + +String Notation string id_string id_string : list_scope. + +Check "abc"%list. + +End Test2. + +(* Test the via ... using ... option *) +Module Test3. + +Inductive I := +| IO : I +| IS : I -> I. + +Definition of_byte (x : Byte.byte) : I := + let fix f n := + match n with + | O => IO + | S n => IS (f n) + end in + f (Byte.to_nat x). + +Definition to_byte (x : I) : option Byte.byte := + let fix f i := + match i with + | IO => O + | IS i => S (f i) + end in + Byte.of_nat (f x). + +String Notation nat of_byte to_byte (via I mapping [O => IO, S => IS]) : nat_scope. + +Check "000". +Check "001". +Check "002". +Check "255". +Fail Check "256". + +End Test3. -- cgit v1.2.3 From da7787ff4f1b5192b5465ca17ece64f5ebd4f72a Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Tue, 20 Oct 2020 19:07:22 +0200 Subject: Allow multiple primitive notation on the same scope and triggers Until now, declaring a number or string notation on some trigger removed all previous notations on the same scope. Bug discovered by Jason Gross while reviewing #12218. --- interp/notation.ml | 1 - test-suite/output/StringSyntax.out | 6 ++++++ test-suite/output/StringSyntax.v | 20 ++++++++++++++++++++ 3 files changed, 26 insertions(+), 1 deletion(-) diff --git a/interp/notation.ml b/interp/notation.ml index 5f6fd62e5c..10e620b58a 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1246,7 +1246,6 @@ let cache_prim_token_interpretation (_,infos) = String.Map.add sc (infos.pt_required,ptii) !prim_token_interp_infos; let add_uninterp r = let l = try GlobRef.Map.find r !prim_token_uninterp_infos with Not_found -> [] in - let l = List.remove_assoc_f String.equal sc l in prim_token_uninterp_infos := GlobRef.Map.add r ((sc,(ptii,infos.pt_in_match)) :: l) !prim_token_uninterp_infos in diff --git a/test-suite/output/StringSyntax.out b/test-suite/output/StringSyntax.out index 125c1bc927..68ee7cfeb5 100644 --- a/test-suite/output/StringSyntax.out +++ b/test-suite/output/StringSyntax.out @@ -1096,3 +1096,9 @@ Expects a single character or a three-digit ASCII code. : nat The command has indeed failed with message: Expects a single character or a three-digit ASCII code. +"abc" + : string2 +"abc" : string2 + : string2 +"abc" : string1 + : string1 diff --git a/test-suite/output/StringSyntax.v b/test-suite/output/StringSyntax.v index 49584487a3..a1ffe69527 100644 --- a/test-suite/output/StringSyntax.v +++ b/test-suite/output/StringSyntax.v @@ -95,3 +95,23 @@ Check "255". Fail Check "256". End Test3. + +(* Test overlapping string notations *) +Module Test4. + +Notation string1 := (list Byte.byte). +Definition id_string1 := @id string1. + +String Notation string1 id_string1 id_string1 : list_scope. + +Notation string2 := (list Ascii.ascii). +Definition a2b := List.map byte_of_ascii. +Definition b2a := List.map ascii_of_byte. + +String Notation string2 b2a a2b : list_scope. + +Check "abc"%list. +Check ["a";"b";"c"]%char%list : string2. +Check ["a";"b";"c"]%byte%list : string1. + +End Test4. -- cgit v1.2.3 From e3593abd322acb59c512b5f2f776091546b38887 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 30 Sep 2020 13:13:25 +0200 Subject: [refman] Add an example for number notations As suggested by Jim Fehrle while reviewing #12218 --- doc/sphinx/user-extensions/syntax-extensions.rst | 71 +++++++++++++++++++++++- 1 file changed, 70 insertions(+), 1 deletion(-) diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index a52d7f08f0..2af40792df 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1857,6 +1857,75 @@ The following errors apply to both string and number notations: .. todo note on "single qualified identifiers" https://github.com/coq/coq/pull/11718#discussion_r415076703 +.. example:: Number Notation for radix 3 + + The following example parses and prints natural numbers + whose digits are :g:`0`, :g:`1` or :g:`2` as terms of the following + inductive type encoding radix 3 numbers. + + .. coqtop:: in reset + + Inductive radix3 : Set := + | x0 : radix3 + | x3 : radix3 -> radix3 + | x3p1 : radix3 -> radix3 + | x3p2 : radix3 -> radix3. + + We first define a parsing function + + .. coqtop:: in + + Definition of_uint_dec (u : Decimal.uint) : option radix3 := + let fix f u := match u with + | Decimal.Nil => Some x0 + | Decimal.D0 u => match f u with Some u => Some (x3 u) | None => None end + | Decimal.D1 u => match f u with Some u => Some (x3p1 u) | None => None end + | Decimal.D2 u => match f u with Some u => Some (x3p2 u) | None => None end + | _ => None end in + f (Decimal.rev u). + Definition of_uint (u : Number.uint) : option radix3 := + match u with Number.UIntDec u => of_uint_dec u | Number.UIntHex _ => None end. + + and a printing function + + .. coqtop:: in + + Definition to_uint_dec (x : radix3) : Decimal.uint := + let fix f x := match x with + | x0 => Decimal.Nil + | x3 x => Decimal.D0 (f x) + | x3p1 x => Decimal.D1 (f x) + | x3p2 x => Decimal.D2 (f x) end in + Decimal.rev (f x). + Definition to_uint (x : radix3) : Number.uint := Number.UIntDec (to_uint_dec x). + + before declaring the notation + + .. coqtop:: in + + Declare Scope radix3_scope. + Open Scope radix3_scope. + Number Notation radix3 of_uint to_uint : radix3_scope. + + We can check the printer + + .. coqtop:: all + + Check x3p2 (x3p1 x0). + + and the parser + + .. coqtop:: all + + Set Printing All. + Check 120. + + Digits other than :g:`0`, :g:`1` and :g:`2` are rejected. + + .. coqtop:: all fail + + Check 3. + .. _example-number-notation-non-inductive: .. example:: Number Notation for a non inductive type @@ -1866,7 +1935,7 @@ The following errors apply to both string and number notations: is encoded as :g:`3` while :g:`unit` is :g:`1` and :g:`0` stands for :g:`Empty_set`. The inductive :g:`I` will be used as :n:`@qualid__ind`. - .. coqtop:: in + .. coqtop:: in reset Inductive I := Iempty : I | Iunit : I | Isum : I -> I -> I. -- cgit v1.2.3 From 36ac26532028bfc6f84e4dfc849b51f42a3d8286 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 28 Oct 2020 10:32:58 +0100 Subject: Rename Dec and HexDec to Decimal and Hexadecimal As noted by Hugo Herbelin, Dec is rather used for "decidable". --- doc/sphinx/user-extensions/syntax-extensions.rst | 4 ++-- interp/notation.ml | 8 ++++---- test-suite/output/NumberNotations.out | 6 +++--- test-suite/output/NumberNotations.v | 2 +- test-suite/output/ZSyntax.v | 2 +- theories/Init/Nat.v | 14 +++++++------- theories/Init/Number.v | 22 +++++++++++++++++----- theories/Init/Numeral.v | 24 ++++++++++++------------ theories/NArith/BinNatDef.v | 12 ++++++------ theories/PArith/BinPosDef.v | 12 ++++++------ theories/QArith/QArith_base.v | 8 ++++---- theories/Reals/Rdefinitions.v | 8 ++++---- theories/ZArith/BinIntDef.v | 10 +++++----- 13 files changed, 72 insertions(+), 60 deletions(-) diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 2af40792df..9d1fcc160d 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1884,7 +1884,7 @@ The following errors apply to both string and number notations: | _ => None end in f (Decimal.rev u). Definition of_uint (u : Number.uint) : option radix3 := - match u with Number.UIntDec u => of_uint_dec u | Number.UIntHex _ => None end. + match u with Number.UIntDecimal u => of_uint_dec u | Number.UIntHexadecimal _ => None end. and a printing function @@ -1897,7 +1897,7 @@ The following errors apply to both string and number notations: | x3p1 x => Decimal.D1 (f x) | x3p2 x => Decimal.D2 (f x) end in Decimal.rev (f x). - Definition to_uint (x : radix3) : Number.uint := Number.UIntDec (to_uint_dec x). + Definition to_uint (x : radix3) : Number.uint := Number.UIntDecimal (to_uint_dec x). before declaring the notation diff --git a/interp/notation.ml b/interp/notation.ml index 10e620b58a..a0321aaf82 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -836,8 +836,8 @@ let coqnumber_of_rawnum inds c n = mkApp (mkConstruct (ind, 2), [|i; f; e|]) (* (D|Hexad)ecimalExp *) let mkDecHex ind c n = match c with - | CDec -> mkApp (mkConstruct (ind, 1), [|n|]) (* (UInt|Int|)Dec *) - | CHex -> mkApp (mkConstruct (ind, 2), [|n|]) (* (UInt|Int|)Hex *) + | CDec -> mkApp (mkConstruct (ind, 1), [|n|]) (* (UInt|Int|)Decimal *) + | CHex -> mkApp (mkConstruct (ind, 2), [|n|]) (* (UInt|Int|)Hexadecimal *) exception NonDecimal @@ -912,8 +912,8 @@ let rawnum_of_coqnumber cl c = let destDecHex c = match Constr.kind c with | App (c,[|c'|]) -> (match Constr.kind c with - | Construct ((_,1), _) (* (UInt|Int|)Dec *) -> CDec, c' - | Construct ((_,2), _) (* (UInt|Int|)Hex *) -> CHex, c' + | Construct ((_,1), _) (* (UInt|Int|)Decimal *) -> CDec, c' + | Construct ((_,2), _) (* (UInt|Int|)Hexadecimal *) -> CHex, c' | _ -> raise NotAValidPrimToken) | _ -> raise NotAValidPrimToken diff --git a/test-suite/output/NumberNotations.out b/test-suite/output/NumberNotations.out index 57206772c8..60682edec8 100644 --- a/test-suite/output/NumberNotations.out +++ b/test-suite/output/NumberNotations.out @@ -32,7 +32,7 @@ Warning: To avoid stack overflow, large numbers in punit are interpreted as applications of pto_punits. [abstract-large-number,numbers] The command has indeed failed with message: In environment -v := pto_punits (Number.UIntDec (Decimal.D1 Decimal.Nil)) : punit +v := pto_punits (Number.UIntDecimal (Decimal.D1 Decimal.Nil)) : punit The term "v" has type "punit@{Set}" while it is expected to have type "punit@{u}". S @@ -61,7 +61,7 @@ The command has indeed failed with message: In environment v := 0 : nat The term "v" has type "nat" while it is expected to have type "wuint". - = {| unwrap := Number.UIntDec (Decimal.D0 Decimal.Nil) |} + = {| unwrap := Number.UIntDecimal (Decimal.D0 Decimal.Nil) |} : wuint let v := 0%wuint8' in v : wuint : wuint @@ -82,7 +82,7 @@ function (of_uint) targets an option type. The command has indeed failed with message: The 'abstract after' directive has no effect when the parsing function (of_uint) targets an option type. [abstract-large-number-no-op,numbers] -let v := of_uint (Number.UIntDec (Decimal.D1 Decimal.Nil)) in v : unit +let v := of_uint (Number.UIntDecimal (Decimal.D1 Decimal.Nil)) in v : unit : unit let v := 0%test13 in v : unit : unit diff --git a/test-suite/output/NumberNotations.v b/test-suite/output/NumberNotations.v index 556cf929b4..718da13500 100644 --- a/test-suite/output/NumberNotations.v +++ b/test-suite/output/NumberNotations.v @@ -569,7 +569,7 @@ Inductive I' := | I'unit : I' | I'sum : I -> I' -> I'. Definition of_uint' (x : Number.uint) : I' := I'empty. -Definition to_uint' (x : I') : Number.uint := Number.UIntDec Decimal.Nil. +Definition to_uint' (x : I') : Number.uint := Number.UIntDecimal Decimal.Nil. Number Notation nSet of_uint' to_uint' (via I' mapping [Empty_set => I'empty, unit => I'unit, sum => I'sum]) : type_scope. diff --git a/test-suite/output/ZSyntax.v b/test-suite/output/ZSyntax.v index 219d953c97..67c4f85d5c 100644 --- a/test-suite/output/ZSyntax.v +++ b/test-suite/output/ZSyntax.v @@ -18,7 +18,7 @@ Require Import Arith. Check (0 + Z.of_nat 11)%Z. (* Check hexadecimal printing *) -Definition to_num_int n := Number.IntHex (Z.to_hex_int n). +Definition to_num_int n := Number.IntHexadecimal (Z.to_hex_int n). Number Notation Z Z.of_num_int to_num_int : Z_scope. Check 42%Z. Check (-42)%Z. diff --git a/theories/Init/Nat.v b/theories/Init/Nat.v index bc48311151..9a3a3ec99b 100644 --- a/theories/Init/Nat.v +++ b/theories/Init/Nat.v @@ -214,8 +214,8 @@ Definition of_hex_uint (d:Hexadecimal.uint) := of_hex_uint_acc d O. Definition of_num_uint (d:Number.uint) := match d with - | Number.UIntDec d => of_uint d - | Number.UIntHex d => of_hex_uint d + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d end. Fixpoint to_little_uint n acc := @@ -236,9 +236,9 @@ Fixpoint to_little_hex_uint n acc := Definition to_hex_uint n := Hexadecimal.rev (to_little_hex_uint n Hexadecimal.zero). -Definition to_num_uint n := Number.UIntDec (to_uint n). +Definition to_num_uint n := Number.UIntDecimal (to_uint n). -Definition to_num_hex_uint n := Number.UIntHex (to_hex_uint n). +Definition to_num_hex_uint n := Number.UIntHexadecimal (to_hex_uint n). Definition of_int (d:Decimal.int) : option nat := match Decimal.norm d with @@ -254,15 +254,15 @@ Definition of_hex_int (d:Hexadecimal.int) : option nat := Definition of_num_int (d:Number.int) : option nat := match d with - | Number.IntDec d => of_int d - | Number.IntHex d => of_hex_int d + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d end. Definition to_int n := Decimal.Pos (to_uint n). Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). -Definition to_num_int n := Number.IntDec (to_int n). +Definition to_num_int n := Number.IntDecimal (to_int n). (** ** Euclidean division *) diff --git a/theories/Init/Number.v b/theories/Init/Number.v index 228f84b179..eb9cc856ac 100644 --- a/theories/Init/Number.v +++ b/theories/Init/Number.v @@ -12,11 +12,23 @@ Require Import Decimal Hexadecimal. -Variant uint := UIntDec (u:Decimal.uint) | UIntHex (u:Hexadecimal.uint). - -Variant int := IntDec (i:Decimal.int) | IntHex (i:Hexadecimal.int). - -Variant number := Dec (d:Decimal.decimal) | Hex (h:Hexadecimal.hexadecimal). +Variant uint := UIntDecimal (u:Decimal.uint) | UIntHexadecimal (u:Hexadecimal.uint). +#[deprecated(since="8.13",note="Use UintDecimal instead.")] +Notation UIntDec := UIntDecimal (only parsing). +#[deprecated(since="8.13",note="Use UintHexadecimal instead.")] +Notation UIntHex := UIntHexadecimal (only parsing). + +Variant int := IntDecimal (i:Decimal.int) | IntHexadecimal (i:Hexadecimal.int). +#[deprecated(since="8.13",note="Use IntDecimal instead.")] +Notation IntDec := IntDecimal (only parsing). +#[deprecated(since="8.13",note="Use IntHexadecimal instead.")] +Notation IntHex := IntHexadecimal (only parsing). + +Variant number := Decimal (d:Decimal.decimal) | Hexadecimal (h:Hexadecimal.hexadecimal). +#[deprecated(since="8.13",note="Use Decimal instead.")] +Notation Dec := Decimal (only parsing). +#[deprecated(since="8.13",note="Use Hexadecimal instead.")] +Notation Hex := Hexadecimal (only parsing). Scheme Equality for uint. Scheme Equality for int. diff --git a/theories/Init/Numeral.v b/theories/Init/Numeral.v index c87f17ee5a..50fa312e7e 100644 --- a/theories/Init/Numeral.v +++ b/theories/Init/Numeral.v @@ -14,24 +14,24 @@ Require Import Decimal Hexadecimal Number. #[deprecated(since="8.13",note="Use Number.uint instead.")] Notation uint := uint (only parsing). -#[deprecated(since="8.13",note="Use Number.UintDec instead.")] -Notation UIntDec := UIntDec (only parsing). -#[deprecated(since="8.13",note="Use Number.UintHex instead.")] -Notation UIntHex := UIntHex (only parsing). +#[deprecated(since="8.13",note="Use Number.UintDecimal instead.")] +Notation UIntDec := UIntDecimal (only parsing). +#[deprecated(since="8.13",note="Use Number.UintHexadecimal instead.")] +Notation UIntHex := UIntHexadecimal (only parsing). #[deprecated(since="8.13",note="Use Number.int instead.")] Notation int := int (only parsing). -#[deprecated(since="8.13",note="Use Number.IntDec instead.")] -Notation IntDec := IntDec (only parsing). -#[deprecated(since="8.13",note="Use Number.IntHex instead.")] -Notation IntHex := IntHex (only parsing). +#[deprecated(since="8.13",note="Use Number.IntDecimal instead.")] +Notation IntDec := IntDecimal (only parsing). +#[deprecated(since="8.13",note="Use Number.IntHexadecimal instead.")] +Notation IntHex := IntHexadecimal (only parsing). #[deprecated(since="8.13",note="Use Number.numeral instead.")] Notation numeral := number (only parsing). -#[deprecated(since="8.13",note="Use Number.Dec instead.")] -Notation Dec := Dec (only parsing). -#[deprecated(since="8.13",note="Use Number.Hex instead.")] -Notation Hex := Hex (only parsing). +#[deprecated(since="8.13",note="Use Number.Decimal instead.")] +Notation Dec := Decimal (only parsing). +#[deprecated(since="8.13",note="Use Number.Hexadecimal instead.")] +Notation Hex := Hexadecimal (only parsing). #[deprecated(since="8.13",note="Use Number.uint_beq instead.")] Notation uint_beq := uint_beq (only parsing). diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index 4142bb786f..e57e5fe856 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -392,8 +392,8 @@ Definition of_hex_uint (d:Hexadecimal.uint) := Pos.of_hex_uint d. Definition of_num_uint (d:Number.uint) := match d with - | Number.UIntDec d => of_uint d - | Number.UIntHex d => of_hex_uint d + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d end. Definition of_int (d:Decimal.int) := @@ -410,8 +410,8 @@ Definition of_hex_int (d:Hexadecimal.int) := Definition of_num_int (d:Number.int) := match d with - | Number.IntDec d => of_int d - | Number.IntHex d => of_hex_int d + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d end. Definition to_uint n := @@ -426,13 +426,13 @@ Definition to_hex_uint n := | pos p => Pos.to_hex_uint p end. -Definition to_num_uint n := Number.UIntDec (to_uint n). +Definition to_num_uint n := Number.UIntDecimal (to_uint n). Definition to_int n := Decimal.Pos (to_uint n). Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). -Definition to_num_int n := Number.IntDec (to_int n). +Definition to_num_int n := Number.IntDecimal (to_int n). Number Notation N of_num_uint to_num_uint : N_scope. diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index 958778762d..2ec9f4d871 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -641,8 +641,8 @@ Fixpoint of_hex_uint (d:Hexadecimal.uint) : N := Definition of_num_uint (d:Number.uint) : N := match d with - | Number.UIntDec d => of_uint d - | Number.UIntHex d => of_hex_uint d + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d end. Definition of_int (d:Decimal.int) : option positive := @@ -667,8 +667,8 @@ Definition of_hex_int (d:Hexadecimal.int) : option positive := Definition of_num_int (d:Number.int) : option positive := match d with - | Number.IntDec d => of_int d - | Number.IntHex d => of_hex_int d + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d end. Fixpoint to_little_uint p := @@ -689,13 +689,13 @@ Fixpoint to_little_hex_uint p := Definition to_hex_uint p := Hexadecimal.rev (to_little_hex_uint p). -Definition to_num_uint p := Number.UIntDec (to_uint p). +Definition to_num_uint p := Number.UIntDecimal (to_uint p). Definition to_int n := Decimal.Pos (to_uint n). Definition to_hex_int p := Hexadecimal.Pos (to_hex_uint p). -Definition to_num_int n := Number.IntDec (to_int n). +Definition to_num_int n := Number.IntDecimal (to_int n). Number Notation positive of_num_int to_num_uint : positive_scope. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 9a70ac311a..fa4f9134cc 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -396,20 +396,20 @@ Definition to_hexadecimal (n : IQ) : option Hexadecimal.hexadecimal := Definition of_number (n : Number.number) : IQ := match n with - | Number.Dec d => of_decimal d - | Number.Hex h => of_hexadecimal h + | Number.Decimal d => of_decimal d + | Number.Hexadecimal h => of_hexadecimal h end. Definition to_number (q:IQ) : option Number.number := match to_decimal q with | None => None - | Some q => Some (Number.Dec q) + | Some q => Some (Number.Decimal q) end. Definition to_hex_number q := match to_hexadecimal q with | None => None - | Some q => Some (Number.Hex q) + | Some q => Some (Number.Hexadecimal q) end. Number Notation Q of_number to_hex_number (via IQ diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index ac82216474..40736c61f2 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -280,8 +280,8 @@ Definition of_hexadecimal (d : Hexadecimal.hexadecimal) : IR := Definition of_number (n : Number.number) : IR := match n with - | Number.Dec d => of_decimal d - | Number.Hex h => of_hexadecimal h + | Number.Decimal d => of_decimal d + | Number.Hexadecimal h => of_hexadecimal h end. Definition IQmake_to_decimal num den := @@ -369,13 +369,13 @@ Definition to_hexadecimal (n : IR) : option Hexadecimal.hexadecimal := Definition to_number q := match to_decimal q with | None => None - | Some q => Some (Number.Dec q) + | Some q => Some (Number.Decimal q) end. Definition to_hex_number q := match to_hexadecimal q with | None => None - | Some q => Some (Number.Hex q) + | Some q => Some (Number.Hexadecimal q) end. Number Notation R of_number to_hex_number (via IR diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 9415903fa4..58bc75b62c 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -313,8 +313,8 @@ Definition of_hex_uint (d:Hexadecimal.uint) := of_N (Pos.of_hex_uint d). Definition of_num_uint (d:Number.uint) := match d with - | Number.UIntDec d => of_uint d - | Number.UIntHex d => of_hex_uint d + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d end. Definition of_int (d:Decimal.int) := @@ -331,8 +331,8 @@ Definition of_hex_int (d:Hexadecimal.int) := Definition of_num_int (d:Number.int) := match d with - | Number.IntDec d => of_int d - | Number.IntHex d => of_hex_int d + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d end. Definition to_int n := @@ -349,7 +349,7 @@ Definition to_hex_int n := | neg p => Hexadecimal.Neg (Pos.to_hex_uint p) end. -Definition to_num_int n := Number.IntDec (to_int n). +Definition to_num_int n := Number.IntDecimal (to_int n). (** ** Iteration of a function -- cgit v1.2.3 From 94132f40eb81ed3249c4d5f32f6d7aa356d38847 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Sat, 12 Sep 2020 08:54:17 +0200 Subject: Add changelog --- .../12218-numeral-notations-non-inductive.rst | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst diff --git a/doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst b/doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst new file mode 100644 index 0000000000..5ea37e7494 --- /dev/null +++ b/doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst @@ -0,0 +1,19 @@ +- **Deprecated** + ``Numeral.v`` is deprecated, please use ``Number.v`` instead. +- **Changed** + Rational and real constants are parsed differently. + The exponent is now encoded separately from the fractional part + using ``Z.pow_pos``. This way, parsing large exponents can no longer + blow up and constants are printed in a form closer to the one they + were parsed (i.e., ``102e-2`` is reprinted as such and not ``1.02``). +- **Removed** + OCaml parser and printer for real constants have been removed. + Real constants are now handled with proven Coq code. +- **Added:** + :ref:`Number Notation ` and :ref:`String Notation + ` commands now + support parameterized inductive and non inductive types + (`#12218 `_, + fixes `#12035 `_, + by Pierre Roux, review by Jason Gross and Jim Fehrle for the + reference manual). -- cgit v1.2.3 From e6f7517be65e9f5d2127a86e2213eb717d37e43f Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Thu, 3 Sep 2020 13:28:00 +0200 Subject: Add overlays --- .../12218-proux01-numeral-notations-non-inductive.sh | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh diff --git a/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh b/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh new file mode 100644 index 0000000000..d9b49ad0d1 --- /dev/null +++ b/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh @@ -0,0 +1,18 @@ +if [ "$CI_PULL_REQUEST" = "12218" ] || [ "$CI_BRANCH" = "numeral-notations-non-inductive" ]; then + + stdlib2_CI_REF=numeral-notations-non-inductive + stdlib2_CI_GITURL=https://github.com/proux01/stdlib2 + + hott_CI_REF=numeral-notations-non-inductive + hott_CI_GITURL=https://github.com/proux01/HoTT + + paramcoq_CI_REF=numeral-notations-non-inductive + paramcoq_CI_GITURL=https://github.com/proux01/paramcoq + + quickchick_CI_REF=numeral-notations-non-inductive + quickchick_CI_GITURL=https://github.com/proux01/QuickChick + + metacoq_CI_REF=numeral-notations-non-inductive + metacoq_CI_GITURL=https://github.com/proux01/metacoq + +fi -- cgit v1.2.3