numerals-base (empty) → 0.3
raw patch · 12 files changed
+1064/−0 lines, 12 filesdep +HUnitdep +basedep +base-unicode-symbolssetup-changed
Dependencies added: HUnit, base, base-unicode-symbols, containers, containers-unicode-symbols, fingertree, test-framework, test-framework-hunit
Files
- LICENSE +32/−0
- README.markdown +6/−0
- Setup.hs +3/−0
- TODO.markdown +58/−0
- numerals-base.cabal +72/−0
- src/Text/Numeral.hs +69/−0
- src/Text/Numeral/BigNum.hs +131/−0
- src/Text/Numeral/Exp.hs +91/−0
- src/Text/Numeral/Exp/Classes.hs +104/−0
- src/Text/Numeral/Misc.hs +37/−0
- src/Text/Numeral/Render.hs +148/−0
- src/Text/Numeral/Rules.hs +313/−0
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright © 2009—2011 Roel van Dijk, Bas van Dijk++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of Roel van Dijk and Bas van Dijk and the names of+ contributors may NOT be used to endorse or promote products+ derived from this software without specific prior written+ permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,6 @@+This package contains machinery to construct functions that convert+numbers to number words. It allows you to write a function which+converts a number like 142 to the string "one hundred and forty-two".++See the [numerals](https://github.com/roelvandijk/numerals) package+for numerous examples.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ TODO.markdown view
@@ -0,0 +1,58 @@+# TODO++Todo list for the numerals-base package++### Resources++Useful resources:++- [Number Systems of the World](http://www.sf.airnet.ne.jp/~ts/language/number.html)+- [Of Languages and Numbers](http://www.languagesandnumbers.com)+- [Word numbers, Part 1: Billion approaches](http://conway.rutgers.edu/~ccshan/wiki/blog/posts/WordNumbers1/)++### Cardinal numerals++How many items - one, two, three++### Ordinal numerals++Position - first, second, third.++- en 1 = first+- en 2 = second+- en 32 = thirty-second+- nl 8 = achtste+- nl 9 = negende+- nl 89 = negenentachtigste++### Partitive numerals++Expresses a fraction - half, third, quarter.++- en 1÷2 = half+- en 2÷3 = two thirds+- nl 2÷3 = twee derden+- nl 3÷4 = drie kwart++### Decimals++Fractions of powers of ten++- en 0.7 = seven-tenths+- en 0.065 = sixty-five thousanths+- nl 0.28 = achtentwintig honderdsten++### Multiplicative numerals++How many times - once, twice, thrice.++- en 1 = once+- en 2 = twice+- en 3 = thrice+- en [4..] = undefined - or use a convention like "four times, five times, etc."++### Distributive numerals++Expresses a group of the number specified: In pairs, by the+dozen. English does not have distributive numerals for these but other+languages such as Georgian do.
+ numerals-base.cabal view
@@ -0,0 +1,72 @@+name: numerals-base+version: 0.3+cabal-version: >= 1.8+build-type: Simple+stability: experimental+author: Roel van Dijk <vandijk.roel@gmail.com>, Bas van Dijk <v.dijk.bas@gmail.com>+maintainer: Roel van Dijk <vandijk.roel@gmail.com>+copyright: 2009–2011 Roel van Dijk, Bas van Dijk+license: BSD3+license-file: LICENSE+homepage: https://github.com/roelvandijk/numerals-base+bug-reports: https://github.com/roelvandijk/numerals-base/issues+category: Natural Language Processing, Numerical, Text+synopsis: Convert numbers to number words+description:+ This package contains machinery to construct functions that convert+ numbers to number words. It allows you to write a function which+ converts a number like 142 to the string \"one hundred and+ forty-two\".+ .+ The documentation for the "Text.Numeral" module contains an high+ level overview of the package.+ .+ If you just want to convert numbers to number words in a specific+ language you should probably use the @numerals@ package. That+ package also contains numerous examples on how to use the functions+ in this package.++extra-source-files: ./TODO.markdown, ./README.markdown++-------------------------------------------------------------------------------++source-repository head+ Type: git+ Location: git://github.com/roelvandijk/numerals-base.git++-------------------------------------------------------------------------------++library+ hs-source-dirs: src+ ghc-options: -Wall++ build-depends: base >= 3.0.3.1 && < 4.5+ , base-unicode-symbols >= 0.2.2 && < 0.3+ , containers >= 0.4 && < 0.5+ , containers-unicode-symbols >= 0.3 && < 0.4+ , fingertree >= 0.0.1 && < 0.1++ exposed-modules: Text.Numeral+ , Text.Numeral.BigNum+ , Text.Numeral.Exp+ , Text.Numeral.Exp.Classes+ , Text.Numeral.Misc+ , Text.Numeral.Render+ , Text.Numeral.Rules++-------------------------------------------------------------------------------++test-suite test-numerals+ type: exitcode-stdio-1.0+ main-is: test.hs+ hs-source-dirs: src, test+ ghc-options: -Wall++ build-depends: base >= 3.0.3.1 && < 4.5+ , base-unicode-symbols >= 0.2.2 && < 0.3+ , containers >= 0.4 && < 0.5+ , containers-unicode-symbols >= 0.3 && < 0.4+ , fingertree >= 0.0.1 && < 0.1+ , HUnit >= 1.2.2 && < 1.3+ , test-framework >= 0.3.3 && < 0.5+ , test-framework-hunit >= 0.2.6 && < 0.3
+ src/Text/Numeral.hs view
@@ -0,0 +1,69 @@+module Text.Numeral+ ( -- * Overview+ -- $overview++ -- ** Expression language+ -- $dsl++ -- ** Rules+ -- $rules++ -- ** Rendering+ -- $render++ module Text.Numeral.Exp+ , module Text.Numeral.Render+ , module Text.Numeral.Rules+ )+ where++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++-- from numerals:+import Text.Numeral.Exp+import Text.Numeral.Render+import Text.Numeral.Rules++-------------------------------------------------------------------------------+-- Documentation+-------------------------------------------------------------------------------++{- $overview++The general idea behind this package is to take a number, convert that+number to an abstract representation of its spoken form and finally+render that representation to a string-like value.++-}++{- $dsl++Numerals are represented by a small expression language defined in the+"Text.Numeral.Exp.Classes" module. This language is also reified as+the concrete type 'Exp' in the "Text.Numeral.Exp" module.++-}++{- $rules++Conversion from numbers to numerals is the responsibility of+rules. The 'Rule' type itself and a number of useful rules are defined+in the "Text.Numeral.Rules" module. All rules are completely+polymorphic in their types. Their result types are only constrained by+the type classes that make up the numeral expression language.++-}++{- $render++Finally, the "Text.Numeral.Render" module is responsible for+converting the numeral expression language to a string-like+value. This happens via the 'render' function. Render is parametrised+with a 'Repr' value which contains all the knowledge on how to convert+the abstract expression to a concrete string-like value. The+expression itself is passed as a concrete 'Exp' value. The only+constrained on the final value is that it is a 'Monoid'.++-}
+ src/Text/Numeral/BigNum.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE NoImplicitPrelude+ , OverloadedStrings+ , PackageImports+ , UnicodeSyntax+ #-}++module Text.Numeral.BigNum+ ( cardinal+ , rule+ , cardinalRepr+ , symMap+ , forms++ , scaleRepr+ , pelletierRepr+ ) where+++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++import "base" Data.Bool ( otherwise )+import "base" Data.Function ( ($), const, fix )+import "base" Data.Functor ( (<$>) )+import "base" Data.Maybe ( Maybe(Nothing, Just) )+import "base" Data.Monoid ( Monoid )+import "base" Data.String ( IsString )+import "base" Prelude ( Integral )+import "base-unicode-symbols" Data.Eq.Unicode ( (≡) )+import "base-unicode-symbols" Data.Function.Unicode ( (∘) )+import "base-unicode-symbols" Data.List.Unicode ( (∈) )+import "base-unicode-symbols" Data.Monoid.Unicode ( (⊕) )+import "base-unicode-symbols" Prelude.Unicode ( ℤ )+import "containers-unicode-symbols" Data.Map.Unicode ( (∪) )+import "this" Text.Numeral+import qualified "containers" Data.Map as M ( Map, fromList, lookup )+import qualified "this" Text.Numeral.Exp.Classes as C+++--------------------------------------------------------------------------------+-- Language of Big Numbers+--------------------------------------------------------------------------------++cardinal ∷ (Monoid s, IsString s, Integral α) ⇒ α → Maybe s+cardinal = render cardinalRepr ∘ (pos $ fix rule)++rule ∷ (Integral α, C.Unknown β, C.Lit β, C.Add β, C.Mul β) ⇒ Rule α β+rule = findRule ( 1, lit )+ [ ( 11, add 10 L )+ , ( 20, mul 10 L L)+ , ( 100, lit )+ , ( 101, add 100 L )+ , ( 200, mul 100 R L)+ , (1000, lit )+ ]+ 1000++cardinalRepr ∷ (Monoid s, IsString s) ⇒ Repr s+cardinalRepr =+ defaultRepr { reprValue = \n → M.lookup n symMap+ , reprAdd = Just $ \_ _ _ → ""+ , reprMul = Just $ \_ _ _ → ""+ }++symMap ∷ (Integral α, IsString s) ⇒ M.Map α (Ctx Exp → s)+symMap = M.fromList+ [ (1, forms "m" "un" "un" "" "")+ , (2, forms "b" "duo" "duo" "vi" "du")+ , (3, forms "tr" "tre" "tres" "tri" "tre")+ , (4, forms "quadr" "quattuor" "quattuor" "quadra" "quadri")+ , (5, forms "quint" "quin" "quinqua" "quinqua" "quin")+ , (6, forms "sext" "sex" "ses" "sexa" "ses")+ , (7, forms "sept" "septen" "septem" "septua" "septin")+ , (8, forms "oct" "octo" "octo" "octo" "octin")+ , (9, forms "non" "novem" "novem" "nona" "non")+ , (10, \c → case c of+ CtxAdd _ (Lit 100) _ → "deci"+ CtxMul _ _ (CtxAdd L (Lit 100) _) → "ginta"+ CtxMul {} → "gint"+ _ → "dec"+ )+ , (100, \c → case c of+ CtxMul _ (Lit n) _+ | n ∈ [2,3,6] → "cent"+ | otherwise → "gent"+ _ → "cent"+ )+ , (1000, const "millin")+ , (10000, const "myr")+ ]++forms ∷ s → s → s → s → s → Ctx Exp → s+forms t a1 a2 m1 m2 ctx =+ case ctx of+ CtxAdd _ (Lit 10) _ → a1+ CtxAdd {} → a2+ CtxMul _ (Lit 100) _ → m2+ CtxMul {} → m1+ _ → t++--------------------------------------------------------------------------------+-- Representations of scales+--------------------------------------------------------------------------------++scaleRepr ∷ (IsString s, Monoid s)+ ⇒ s -- ^Postfix for singular names.+ → s -- ^Postfix for plural names.+ → [(ℤ, Ctx Exp → s)]+ → ℤ → ℤ → Exp → Ctx Exp → Maybe s+scaleRepr s p syms _ _ e ctx = (⊕ pf) <$> render repr e+ where+ pf = case ctx of+ CtxMul _ (Lit 1) _ → s+ CtxMul {} → p+ _ → s+ repr = cardinalRepr { reprValue = \n → M.lookup n syms' }+ syms' = M.fromList syms ∪ symMap++pelletierRepr ∷ (IsString s, Monoid s)+ ⇒ s -- ^Postfix for singular offset 0 names.+ → s -- ^Postfix for singular offset 0 names.+ → s -- ^Postfix for plural offset 3 names.+ → s -- ^Postfix for plural offset 3 names.+ → [(ℤ, Ctx Exp → s)]+ → ℤ → ℤ → Exp → Ctx Exp → Maybe s+pelletierRepr s0 p0 s3 p3 syms+ b o e ctx | o ≡ 0 = scaleRepr s0 p0 syms b o e ctx+ | o ≡ 3 = scaleRepr s3 p3 syms b o e ctx+ | otherwise = Nothing+
+ src/Text/Numeral/Exp.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE NoImplicitPrelude+ , PackageImports+ , UnicodeSyntax+ #-}++module Text.Numeral.Exp+ ( Exp(..)+ , eval+ , Side(L, R)+ ) where+++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++import "base" Data.Bool ( Bool(False, True) )+import "base" Data.Eq ( Eq )+import "base" Data.Ord ( Ord )+import "base" Text.Show ( Show )+import "base-unicode-symbols" Prelude.Unicode ( ℤ )+import qualified "this" Text.Numeral.Exp.Classes as C+++-------------------------------------------------------------------------------+-- Exp datatype+-------------------------------------------------------------------------------++-- | An expression that represents the structure of a numeral.+data Exp -- | An unknown value.+ = Unknown+ -- | A literal value.+ | Lit ℤ+ -- | Negation of an expression.+ | Neg Exp+ -- | Addition of two expressions.+ | Add Exp Exp+ -- | Multiplication of two expressions.+ | Mul Exp Exp+ -- | One expression subtracted from another expression.+ | Sub Exp Exp+ -- | A step in a scale of large values.+ | Scale ℤ ℤ Exp+ deriving (Eq, Ord, Show)++infixl 6 `Add`+infixl 6 `Sub`+infixl 7 `Mul`++-- | Precisely the 'Unknown' constructor.+instance C.Unknown Exp where+ unknown = Unknown+ isUnknown Unknown = True+ isUnknown _ = False+-- | Precisely the 'Lit' constructor.+instance C.Lit Exp where lit = Lit+-- | Precisely the 'Neg' constructor.+instance C.Neg Exp where neg = Neg+-- | Precisely the 'Add' constructor.+instance C.Add Exp where add = Add+-- | Precisely the 'Mul' constructor.+instance C.Mul Exp where mul = Mul+-- | Precisely the 'Sub' constructor.+instance C.Sub Exp where sub = Sub+-- | Precisely the 'Scale' constructor.+instance C.Scale Exp where scale = Scale++-- | Evaluates an expression to a value.+--+-- Law: @e == eval e@+eval ∷ (C.Unknown α, C.Lit α, C.Neg α, C.Add α, C.Mul α, C.Sub α, C.Scale α) ⇒ Exp → α+eval (Add x y) = C.add (eval x) (eval y)+eval (Mul x y) = C.mul (eval x) (eval y)+eval (Sub x y) = C.sub (eval x) (eval y)+eval (Neg x) = C.neg (eval x)+eval (Lit x) = C.lit x+eval (Scale b o r) = C.scale b o (eval r)+eval Unknown = C.unknown++-- prop_eval ∷ Exp → Bool+-- prop_eval e = e ≡ eval e+++-------------------------------------------------------------------------------+-- Side+-------------------------------------------------------------------------------++-- | A side or direction, either 'L'eft or 'R'ight.+data Side = L -- ^ Left.+ | R -- ^ Right.+ deriving Show
+ src/Text/Numeral/Exp/Classes.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE NoImplicitPrelude+ , PackageImports+ , TypeSynonymInstances+ , UnicodeSyntax+ #-}++module Text.Numeral.Exp.Classes+ ( Unknown(unknown, isUnknown)+ , Lit(lit)+ , Neg(neg)+ , Add(add)+ , Mul(mul)+ , Sub(sub)+ , Scale(scale)+ ) where++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++import "base" Data.Bool ( Bool(False) )+import "base" Data.Function ( const )+import "base" Prelude ( (+), (*), (^), subtract, negate, fromInteger, error )+import "base-unicode-symbols" Prelude.Unicode ( ℤ, (⋅) )+++-------------------------------------------------------------------------------+-- Exp classes+-------------------------------------------------------------------------------++-- | An unknown value. This is used to signal that a value can not be+-- represented in the expression language.+--+-- Law: isUnknown unknown == True+class Unknown α where+ unknown ∷ α+ isUnknown ∷ α → Bool++-- | A literal value.+--+-- Example in English:+--+-- > "three" = lit 3+class Lit α where lit ∷ ℤ → α++-- | Negation of a value.+--+-- Example in English:+--+-- > "minus two" = neg (lit 2)+class Neg α where neg ∷ α → α++-- | Addition of two values.+--+-- Example in English:+--+-- > "fifteen" = lit 5 `add` lit 10+class Add α where add ∷ α → α → α++-- | Multiplication of two values.+--+-- Example in English:+--+-- > "thirty" = lit 3 `mul` lit 10+class Mul α where mul ∷ α → α → α++-- | One value subtracted from another value.+--+-- Example in Latin:+--+-- > "duodēvīgintī" = lit 2 `sub` (lit 2 `mul` lit 10)+class Sub α where sub ∷ α → α → α++-- | A step in a scale of large values.+--+-- Should be interpreted as @10 ^ (rank * base + offset)@.+--+-- Example in English:+--+-- > "quadrillion" = scale 3 3 4+class Scale α where+ scale ∷ ℤ -- ^ Base.+ → ℤ -- ^ Offset.+ → α -- ^ Rank.+ → α++infixl 6 `add`+infixl 6 `sub`+infixl 7 `mul`+++-------------------------------------------------------------------------------+-- Integer instances+-------------------------------------------------------------------------------++instance Unknown ℤ where+ unknown = error "unknown"+ isUnknown = const False+instance Lit ℤ where lit = fromInteger+instance Neg ℤ where neg = negate+instance Add ℤ where add = (+)+instance Mul ℤ where mul = (*)+instance Sub ℤ where sub = subtract+instance Scale ℤ where scale b o r = 10 ^ (r⋅b + o)
+ src/Text/Numeral/Misc.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE NoImplicitPrelude+ , OverloadedStrings+ , PackageImports+ , UnicodeSyntax+ #-}++module Text.Numeral.Misc where++--------------------------------------------------------------------------------+-- Imports+--------------------------------------------------------------------------------++import "base" Data.Bool ( otherwise )+import "base" Data.Ord ( (<) )+import "base" Prelude ( Integral, (+), (^), div, ($!), error )+++--------------------------------------------------------------------------------+-- Misc+--------------------------------------------------------------------------------++-- ^ Raise 10 to some power.+dec ∷ (Integral α) ⇒ α → α+dec = (10 ^)++-- ^ The (base 10) logarithm of an integral value.+intLog ∷ (Integral α) ⇒ α → α+intLog x | x < 0 = error "intLog: undefined for negative numbers"+ | otherwise = go x 0+ where+ go n acc = case n `div` 10 of+ 0 → acc+ 1 → acc + 1+ q → go q $! acc + 1++-- prop_intLog e = intLog (10^e) ≡ e+
+ src/Text/Numeral/Render.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE NoImplicitPrelude+ , UnicodeSyntax+ , PackageImports+ , RecordWildCards+ #-}++module Text.Numeral.Render+ ( -- * Rendering numerals+ render+ -- * Representation of numerals+ , Repr(..), defaultRepr+ -- * Context of expressions+ , Ctx(..)+ )+ where+++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++import "base" Data.Function ( ($) )+import "base" Data.Functor ( (<$>) )+import "base" Data.Maybe ( Maybe(Nothing, Just) )+import "base" Data.Monoid ( Monoid )+import "base-unicode-symbols" Data.Monoid.Unicode ( (⊕) )+import "base-unicode-symbols" Prelude.Unicode ( ℤ )+import "base" Text.Show ( Show )+import "this" Text.Numeral.Exp ( Exp(..), Side(L, R) )+++-------------------------------------------------------------------------------+-- Rendering numerals+-------------------------------------------------------------------------------++-- | Renders an expression to a string-like value according to a+-- certain representation.+render ∷ (Monoid s) ⇒ Repr s → Exp → Maybe s+render (Repr {..}) e = go CtxEmpty e+ where+ go _ Unknown = reprUnknown+ go ctx (Lit n) = ($ ctx) <$> reprValue n+ go ctx (Scale b o r) = reprScale b o r ctx+ go ctx (Neg x) = do x' ← go (CtxNeg ctx) x+ rn ← reprNeg+ rnc ← reprNegCombine+ Just $ rnc (rn x ctx) x'+ go ctx (Add x y) = do x' ← go (CtxAdd L y ctx) x+ y' ← go (CtxAdd R x ctx) y+ ra ← reprAdd+ rac ← reprAddCombine+ Just $ rac (ra x y ctx) x' y'+ go ctx (Mul x y) = do x' ← go (CtxMul L y ctx) x+ y' ← go (CtxMul R x ctx) y+ rm ← reprMul+ rmc ← reprMulCombine+ Just $ rmc (rm x y ctx) x' y'+ go ctx (Sub x y) = do x' ← go (CtxSub L y ctx) x+ y' ← go (CtxSub R x ctx) y+ rs ← reprSub+ rsc ← reprSubCombine+ Just $ rsc (rs x y ctx) x' y'+++--------------------------------------------------------------------------------+-- Representation of numerals+--------------------------------------------------------------------------------++-- | A representation for numerals.+--+-- A 'Repr' contains all the information on how to render an+-- 'Exp'ression to a string-like value.+data Repr s =+ Repr+ { -- | Representation for unknown values.+ reprUnknown ∷ Maybe s+ -- | Renders a literal value. Not necessarily defined for every+ -- value.+ , reprValue ∷ ℤ → Maybe (Ctx Exp → s)+ -- | Renders a step in a scale of large values. The arguments+ -- are in order: base, offset and rank of the step and the+ -- context of the rank. The value represented by the step is 10+ -- ^ (rank * base + offset).+ , reprScale ∷ ℤ → ℤ → Exp → Ctx Exp → Maybe s+ -- | Renders a negation. This concerns the negation itself, not+ -- the thing being negated.+ , reprNeg ∷ Maybe (Exp → Ctx Exp → s)+ -- | Renders an addition. This concerns the addition itself, not+ -- the things being added. For example: In \"one hundred and+ -- eighty\" this function would be responsible for rendering the+ -- \"and\".+ , reprAdd ∷ Maybe (Exp → Exp → Ctx Exp → s)+ -- | Renders a multiplication. This concerns the multiplication+ -- itself, not the things being multiplied.+ , reprMul ∷ Maybe (Exp → Exp → Ctx Exp → s)+ -- | Renders a subtraction. This concerns the subtraction+ -- itself, not the things being subtracted.+ , reprSub ∷ Maybe (Exp → Exp → Ctx Exp → s)+ -- | Combines a negation and the thing being negated. For+ -- example: this would combine \"minus\" and \"three\" into+ -- \"minus three\".+ , reprNegCombine ∷ Maybe (s → s → s)+ -- | Combines an addition and the things being added.+ , reprAddCombine ∷ Maybe (s → s → s → s)+ -- | Combines a multiplication and the things being multiplied.+ , reprMulCombine ∷ Maybe (s → s → s → s)+ -- | Combines a subtraction and the things being subtracted.+ , reprSubCombine ∷ Maybe (s → s → s → s)+ }++-- | The default representation.+--+-- Only the combining functions are defined. The rest are either+-- 'Nothing' or always produce 'Nothing'.+defaultRepr ∷ (Monoid s) ⇒ Repr s+defaultRepr =+ Repr { reprUnknown = Nothing+ , reprValue = \_ → Nothing+ , reprScale = \_ _ _ _ → Nothing+ , reprNeg = Nothing+ , reprAdd = Nothing+ , reprMul = Nothing+ , reprSub = Nothing+ , reprNegCombine = Just $ \n x → n ⊕ x+ , reprAddCombine = Just $ \a x y → x ⊕ a ⊕ y+ , reprMulCombine = Just $ \m x y → x ⊕ m ⊕ y+ , reprSubCombine = Just $ \s x y → x ⊕ s ⊕ y+ }+++--------------------------------------------------------------------------------+-- Context of expressions+--------------------------------------------------------------------------------++-- | A context in which an 'Exp'ression appears.+data Ctx α -- | The empty context. Used for top level expressions.+ = CtxEmpty+ -- | Negation context.+ | CtxNeg (Ctx α)+ -- | Addition context.+ | CtxAdd Side α (Ctx α)+ -- | Multiplication context.+ | CtxMul Side α (Ctx α)+ -- | Subtraction context.+ | CtxSub Side α (Ctx α)+ -- | Scale context.+ | CtxScale (Ctx α)+ deriving Show
+ src/Text/Numeral/Rules.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE NoImplicitPrelude+ , PackageImports+ , UnicodeSyntax+ #-}++{-|++Rules to convert numbers to an expression language.++-}+module Text.Numeral.Rules+ ( -- * The Rule type+ Rule++ -- * Rule combinators+ , conditional+ , combine+ , findRule++ -- * Rules+ , unknown+ , pos, checkPos++ , lit, lit1+ , add+ , mul, mul1+ , sub++ , mulScale, mulScale1+ , shortScale, longScale, pelletierScale+ , shortScale1, longScale1, pelletierScale1++ , mkStep, step, step1+ ) where+++-------------------------------------------------------------------------------+-- Imports+-------------------------------------------------------------------------------++import "base" Data.Bool ( Bool, otherwise )+import "base" Data.Function ( ($), id, const, flip, fix )+import "base" Data.List ( foldr )+import "base" Data.Ord ( Ord, (<), (>) )+import "base" Prelude ( Integral, fromIntegral+ , Num, (-), abs, divMod, div, even+ )+import "base-unicode-symbols" Data.Eq.Unicode ( (≡) )+import "base-unicode-symbols" Data.Function.Unicode ( (∘) )+import "base-unicode-symbols" Prelude.Unicode ( (⋅) )+import "this" Text.Numeral.Exp ( Side(L, R) )+import "this" Text.Numeral.Misc ( intLog )+import qualified "this" Text.Numeral.Exp.Classes as C+import qualified "fingertree" Data.IntervalMap.FingerTree as FT+ ( Interval(Interval)+ , IntervalMap, empty, insert+ , search+ )+++--------------------------------------------------------------------------------+-- The Rule type+--------------------------------------------------------------------------------++-- | A rule on how to convert a number into an expression+-- language. Notice how this type is equal to the type of the '$'+-- operator.+type Rule α β = (α → β) → (α → β)+++--------------------------------------------------------------------------------+-- Rule combinators+--------------------------------------------------------------------------------+++-- | The \'if-then-else\' concept for rules. Applies the first rule if+-- the predicate holds on the input value, otherwise applies the+-- second rule.+conditional ∷ (α → Bool) -- ^ Predicate on input value (\"if\").+ → Rule α β -- ^ Rule to apply when predicate holds (\"then\").+ → Rule α β -- ^ Rule to apply when predicate does not hold (\"else\").+ → Rule α β+conditional p t e = \f n → if p n+ then t f n+ else e f n++-- | Tries to apply the first rule, if that produces an 'C.unknown'+-- value it applies the second rule.+combine ∷ (C.Unknown β)+ ⇒ Rule α β+ → Rule α β+ → Rule α β+combine r1 r2 = \f n → case r1 f n of+ x | C.isUnknown x → r2 f n+ | otherwise → x++-- | Chooses which rule to apply to an input value based on a interval+-- list of rules.+findRule ∷ (Ord α, Num α, C.Unknown β)+ ⇒ (α, Rule α β) -- ^ First interval rule.+ → [(α, Rule α β)] -- ^ Interval rule list.+ → α -- ^ Upper bound of the last interval.+ → Rule α β+findRule x xs end = \f n → case FT.search n xm of+ [] → C.unknown+ (_,r):_ → r f n+ where+ xm = mkIntervalMap $ mkIntervalList x xs end+++--------------------------------------------------------------------------------+-- Rules+--------------------------------------------------------------------------------++-- | A rule that always fails to convert a value. It constantly+-- produces the 'C.unknown' value.+--+-- >>> (fix unknown) (3 :: Integer) :: Exp+-- Unknown+unknown ∷ (C.Unknown β) ⇒ Rule α β+unknown _ _ = C.unknown++-- |+--+-- >>> (pos $ lit $ fix unknown) (3 :: Integer) :: Exp+-- Lit 3+-- >>> (pos $ lit $ fix unknown) (-3 :: Integer) :: Exp+-- Neg (Lit 3)+pos ∷ (Ord α, Num α, C.Lit β, C.Neg β) ⇒ Rule α β+pos f n | n < 0 = C.neg $ f (abs n)+ | n > 0 = f n+ | otherwise = C.lit 0++-- |+--+-- >>> (checkPos $ lit $ fix unknown) (3 :: Integer) :: Exp+-- Lit 3+-- >>> (checkPos $ lit $ fix unknown) (-3 :: Integer) :: Exp+-- Unknown+checkPos ∷ (Ord α, Num α, C.Unknown β, C.Lit β) ⇒ Rule α β+checkPos f n | n < 0 = C.unknown+ | n > 0 = f n+ | otherwise = C.lit 0++-- | The literal rule. Converts its argument into a 'C.lit'eral+-- expression.+--+-- >>> lit (fix unknown) (3 :: Integer) :: Exp+-- Lit 3+--+-- In this example lit is applied to the nonsense rule \"'fix'+-- 'unknown'\". Lit ignores that function, which is why we can pass it+-- anything we want, including itself.+--+-- >>> lit (fix undefined) (3 :: Integer) :: Exp+-- Lit 3+-- >>> (fix lit) (3 :: Integer) :: Exp+-- Lit 3+lit ∷ (Integral α, C.Lit β) ⇒ Rule α β+lit = const $ C.lit ∘ fromIntegral++-- | A variant on the 'lit' rule which always multiplies its argument+-- with 1. Useful for languages which have numerals of the form \"one+-- hundred and three\" as opposed to \"hundred and three\".+--+-- >>> lit1 (fix unknown) (3 :: Integer) :: Exp+-- Mul (Lit 1) (Lit 3)+lit1 ∷ (Integral α, C.Lit β, C.Mul β) ⇒ Rule α β+lit1 = const $ \n → C.lit 1 `C.mul` C.lit (fromIntegral n)++-- |+--+-- >>> (add 10 L $ lit $ fix unknown) (13 :: Integer) :: Exp+-- Add (Lit 3) (Lit 10)+add ∷ (Num α, C.Add β) ⇒ α → Side → Rule α β+add val s = \f n → (flipIfR s C.add) (f $ n - val) (f val)++-- |+--+-- >>> (mul 10 R L $ lit $ fix unknown) (42 :: Integer) :: Exp+-- Add (Mul (Lit 4) (Lit 10)) (Lit 2)+mul ∷ (Integral α, C.Add β, C.Mul β) ⇒ α → Side → Side → Rule α β+mul val aSide mSide =+ \f n → let (m, a) = n `divMod` val+ mval = (flipIfR mSide C.mul) (f m) (f val)+ in if a ≡ 0+ then mval+ else (flipIfR aSide C.add) (f a) mval++mul1 ∷ (Integral α, C.Lit β, C.Add β, C.Mul β)+ ⇒ α → Side → Side → Rule α β+mul1 val aSide mSide =+ \f n → let (m, a) = n `divMod` val+ mval = if m ≡ 1+ then C.lit 1 ⊡ C.lit (fromIntegral val)+ else f m ⊡ C.lit (fromIntegral val)+ in if a ≡ 0+ then mval+ else (flipIfR aSide C.add) (f a) mval+ where+ (⊡) = flipIfR mSide C.mul++-- |+--+-- >>> (sub 20 $ lit $ fix unknown) (18 :: Integer) :: Exp+-- Sub (Lit 2) (Lit 20)+sub ∷ (Integral α, C.Sub β) ⇒ α → Rule α β+sub val = \f n → C.sub (f $ val - n) (f val)++mkStep ∷ (Integral α, C.Unknown β, C.Lit β, C.Add β, C.Mul β)+ ⇒ Rule α β -- ^ lit rule+ → (α → Side → Rule α β) -- ^ add rule+ → (α → Side → Side → Rule α β) -- ^ mul rule+ → α → α → Side → Side → Rule α β+mkStep lr ar mr val r aSide mSide+ f n | n < val = C.unknown+ | n ≡ val = lr f n+ | n < val⋅2 = ar val aSide f n+ | n < val⋅r = mr val aSide mSide f n+ | otherwise = C.unknown++step ∷ (Integral α, C.Unknown β, C.Lit β, C.Add β, C.Mul β)+ ⇒ α → α → Side → Side → Rule α β+step = mkStep lit add mul++step1 ∷ (Integral α, C.Unknown β, C.Lit β, C.Add β, C.Mul β)+ ⇒ α → α → Side → Side → Rule α β+step1 = mkStep lit1 add mul1++-- See: http://en.wikipedia.org/wiki/Names_of_large_numbers+mulScale ∷ (Integral α, C.Scale α, C.Add β, C.Mul β, C.Scale β)+ ⇒ α → α → Side → Side → Rule α β → Rule α β+mulScale base offset aSide mSide bigNumRule =+ \f n → let rank = (intLog n - offset) `div` base+ base' = fromIntegral base+ offset' = fromIntegral offset+ rank' = fromIntegral rank+ rankExp = (fix bigNumRule) rank+ (m, a) = n `divMod` C.scale base' offset' rank'+ scale' = C.scale base' offset' rankExp+ mval | m ≡ 1 = scale'+ | otherwise = (flipIfR mSide C.mul)+ (f m)+ scale'+ in if a ≡ 0+ then mval+ else (flipIfR aSide C.add) (f a) mval++mulScale1 ∷ (Integral α, C.Scale α, C.Add β, C.Mul β, C.Scale β)+ ⇒ α → α → Side → Side → Rule α β → Rule α β+mulScale1 base offset aSide mSide bigNumRule =+ \f n → let rank = (intLog n - offset) `div` base+ base' = fromIntegral base+ offset' = fromIntegral offset+ rank' = fromIntegral rank+ rankExp = (fix bigNumRule) rank+ (m, a) = n `divMod` C.scale base' offset' rank'+ mval = (flipIfR mSide C.mul)+ (f m)+ (C.scale base' offset' rankExp)+ in if a ≡ 0+ then mval+ else (flipIfR aSide C.add) (f a) mval++shortScale ∷ (Integral α, C.Scale α, C.Add β, C.Mul β, C.Scale β)+ ⇒ Side → Side → Rule α β → Rule α β+shortScale = mulScale 3 3++shortScale1 ∷ (Integral α, C.Scale α, C.Add β, C.Mul β, C.Scale β)+ ⇒ Side → Side → Rule α β → Rule α β+shortScale1 = mulScale1 3 3++longScale ∷ (Integral α, C.Scale α, C.Add β, C.Mul β, C.Scale β)+ ⇒ Side → Side → Rule α β → Rule α β+longScale = mulScale 6 0++longScale1 ∷ (Integral α, C.Scale α, C.Add β, C.Mul β, C.Scale β)+ ⇒ Side → Side → Rule α β → Rule α β+longScale1 = mulScale1 6 0++pelletierScale ∷ (Integral α, C.Scale α, C.Add β, C.Mul β, C.Scale β)+ ⇒ Side → Side → Rule α β → Rule α β+pelletierScale aSide mSide bigNumRule =+ conditional (\n → even $ intLog n `div` 3)+ (mulScale 6 0 aSide mSide bigNumRule)+ (mulScale 6 3 aSide mSide bigNumRule)++pelletierScale1 ∷ (Integral α, C.Scale α, C.Add β, C.Mul β, C.Scale β)+ ⇒ Side → Side → Rule α β → Rule α β+pelletierScale1 aSide mSide bigNumRule =+ conditional (\n → even $ intLog n `div` 3)+ (mulScale1 6 0 aSide mSide bigNumRule)+ (mulScale1 6 3 aSide mSide bigNumRule)+++--------------------------------------------------------------------------------+-- Miscellaneous+--------------------------------------------------------------------------------++flipIfR ∷ Side → (α → α → α) → (α → α → α)+flipIfR L = id+flipIfR R = flip++mkIntervalList ∷ (Num a) ⇒ (a, b) → [(a, b)] → a → [((a, a), b)]+mkIntervalList (k, r) krs end = go k r krs+ where+ go k1 r1 [] = [((k1, end), r1)]+ go k1 r1 ((k2, r2):xs) = ((k1, k2-1), r1) : go k2 r2 xs++mkIntervalMap ∷ (Ord v) ⇒ [((v, v), α)] → FT.IntervalMap v α+mkIntervalMap = foldr ins FT.empty+ where ins ((lo, hi), n) = FT.insert (FT.Interval lo hi) n+