diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/TODO.markdown b/TODO.markdown new file mode 100644 --- /dev/null +++ b/TODO.markdown @@ -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. diff --git a/numerals-base.cabal b/numerals-base.cabal new file mode 100644 --- /dev/null +++ b/numerals-base.cabal @@ -0,0 +1,72 @@ +name: numerals-base +version: 0.3 +cabal-version: >= 1.8 +build-type: Simple +stability: experimental +author: Roel van Dijk , Bas van Dijk +maintainer: Roel van Dijk +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 diff --git a/src/Text/Numeral.hs b/src/Text/Numeral.hs new file mode 100644 --- /dev/null +++ b/src/Text/Numeral.hs @@ -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'. + +-} diff --git a/src/Text/Numeral/BigNum.hs b/src/Text/Numeral/BigNum.hs new file mode 100644 --- /dev/null +++ b/src/Text/Numeral/BigNum.hs @@ -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 + diff --git a/src/Text/Numeral/Exp.hs b/src/Text/Numeral/Exp.hs new file mode 100644 --- /dev/null +++ b/src/Text/Numeral/Exp.hs @@ -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 diff --git a/src/Text/Numeral/Exp/Classes.hs b/src/Text/Numeral/Exp/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Text/Numeral/Exp/Classes.hs @@ -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) diff --git a/src/Text/Numeral/Misc.hs b/src/Text/Numeral/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Text/Numeral/Misc.hs @@ -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 + diff --git a/src/Text/Numeral/Render.hs b/src/Text/Numeral/Render.hs new file mode 100644 --- /dev/null +++ b/src/Text/Numeral/Render.hs @@ -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 diff --git a/src/Text/Numeral/Rules.hs b/src/Text/Numeral/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Text/Numeral/Rules.hs @@ -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 +