numerals-base-0.3: src/Text/Numeral/Rules.hs
{-# 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