module Text.Numeral.Rules
(
Rule
, conditional
, combine
, mapRule
, findRule
, unknown
, lit, lit1
, pos, checkPos
, add
, mul, mul1
, sub
, mulScale_, mulScale, mulScale1
, shortScale, longScale, pelletierScale
, shortScale1, longScale1, pelletierScale1
, mkStep, step, step1
, changeCase
, changeGender
, changeNumber
) where
import "base" Data.Function ( fix )
import "this" Text.Numeral.Exp ( Side(L, R) )
import qualified "this" Text.Numeral.Exp as E
import qualified "this" Text.Numeral.Grammar as G
import "this" Text.Numeral.Misc ( intLog )
import qualified "fingertree" Data.IntervalMap.FingerTree as FT
( Interval(Interval)
, IntervalMap, empty, insert
, search
)
type Rule a = (a -> E.Exp) -> (a -> E.Exp)
conditional :: (a -> Bool)
-> Rule a
-> Rule a
-> Rule a
conditional p t e = \f n -> if p n
then t f n
else e f n
combine :: Rule a
-> Rule a
-> Rule a
combine r1 r2 = \f n -> case r1 f n of
E.Unknown -> r2 f n
x -> x
mapRule :: (a -> a) -> Rule a -> Rule a
mapRule g r = \f n -> r f (g n)
findRule :: (Ord a, Num a)
=> (a, Rule a)
-> [(a, Rule a)]
-> a
-> Rule a
findRule x xs end = \f n -> case FT.search n xm of
[] -> E.Unknown
(_,r):_ -> r f n
where
xm = mkIntervalMap $ mkIntervalList x xs end
unknown :: Rule a
unknown _ = const E.Unknown
lit :: (Integral a) => Rule a
lit = const $ E.Lit . fromIntegral
lit1 :: (Integral a) => Rule a
lit1 = const $ \n -> E.Lit 1 `E.Mul` E.Lit (fromIntegral n)
pos :: (Ord a, Num a) => Rule a
pos f n | n < 0 = E.Neg $ f (abs n)
| n > 0 = f n
| otherwise = E.Lit 0
checkPos :: (Ord a, Num a) => Rule a
checkPos f n | n < 0 = E.Unknown
| n > 0 = f n
| otherwise = E.Lit 0
add :: (Num a) => a -> Side -> Rule a
add val s = \f n -> (flipIfR s E.Add) (f $ n val) (f val)
mul :: (Integral a) => a -> Side -> Side -> Rule a
mul val aSide mSide =
\f n -> let (m, a) = n `divMod` val
mval = (flipIfR mSide E.Mul) (f m) (f val)
in if a == 0
then mval
else (flipIfR aSide E.Add) (f a) mval
mul1 :: (Integral a) => a -> Side -> Side -> Rule a
mul1 val aSide mSide =
\f n -> let (m, a) = n `divMod` val
mval = if m == 1
then E.Lit 1 ⊡ E.Lit (fromIntegral val)
else f m ⊡ E.Lit (fromIntegral val)
in if a == 0
then mval
else (flipIfR aSide E.Add) (f a) mval
where
(⊡) = flipIfR mSide E.Mul
sub :: (Integral a) => a -> Rule a
sub val = \f n -> E.Sub (f $ val n) (f val)
mkStep :: (Integral a)
=> Rule a
-> (a -> Side -> Rule a)
-> (a -> Side -> Side -> Rule a)
-> a -> a -> Side -> Side -> Rule a
mkStep lr ar mr val r aSide mSide
f n | n < val = E.Unknown
| n == val = lr f n
| n < val*2 = ar val aSide f n
| n < val*r = mr val aSide mSide f n
| otherwise = E.Unknown
step :: (Integral a) => a -> a -> Side -> Side -> Rule a
step = mkStep lit add mul
step1 :: (Integral a) => a -> a -> Side -> Side -> Rule a
step1 = mkStep lit1 add mul1
mulScale_ :: forall a. (Integral a)
=> ( (a -> E.Exp)
-> a
-> E.Exp
-> Side
-> E.Exp
)
-> a
-> a
-> Side
-> Side
-> Rule a
-> Rule a
mulScale_ doMul base offset aSide mSide bigNumRule =
\f n -> let rank = (intLog n offset) `div` base
base' :: Integer
base' = fromIntegral base
offset' :: Integer
offset' = fromIntegral offset
rankExp :: E.Exp
rankExp = (fix bigNumRule) rank
m, a :: a
(m, a) = n `divMod` E.evalScale base offset rank
scale' :: E.Exp
scale' = E.Scale base' offset' rankExp
mval = doMul f m scale' mSide
in case rankExp of
E.Unknown -> E.Unknown
_ -> if a == 0
then mval
else (flipIfR aSide E.Add) (f a) mval
mulScale :: (Integral a)
=> a
-> a
-> Side
-> Side
-> Rule a
-> Rule a
mulScale = mulScale_ $ \f m scale' mSide ->
case m of
1 -> scale'
_ -> (flipIfR mSide E.Mul) (f m) scale'
mulScale1 :: (Integral a)
=> a
-> a
-> Side
-> Side
-> Rule a
-> Rule a
mulScale1 = mulScale_ $ \f m scale' mSide -> (flipIfR mSide E.Mul) (f m) scale'
shortScale :: (Integral a)
=> Side
-> Side
-> Rule a
-> Rule a
shortScale = mulScale 3 3
shortScale1 :: (Integral a)
=> Side
-> Side
-> Rule a
-> Rule a
shortScale1 = mulScale1 3 3
longScale :: (Integral a)
=> Side
-> Side
-> Rule a
-> Rule a
longScale = mulScale 6 0
longScale1 :: (Integral a)
=> Side
-> Side
-> Rule a
-> Rule a
longScale1 = mulScale1 6 0
pelletierScale :: (Integral a)
=> Side
-> Side
-> Rule a
-> Rule a
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 a)
=> Side
-> Side
-> Rule a
-> Rule a
pelletierScale1 aSide mSide bigNumRule =
conditional (\n -> even $ intLog n `div` 3)
(mulScale1 6 0 aSide mSide bigNumRule)
(mulScale1 6 3 aSide mSide bigNumRule)
changeCase :: Maybe G.Case -> Rule a
changeCase mbCase = \f n -> E.ChangeCase mbCase $ f n
changeGender :: Maybe G.Gender -> Rule a
changeGender mbGender = \f n -> E.ChangeGender mbGender $ f n
changeNumber :: Maybe G.Number -> Rule a
changeNumber mbNumber = \f n -> E.ChangeNumber mbNumber $ f n
flipIfR :: Side -> (a -> a -> a) -> (a -> a -> a)
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, k21), r1) : go k2 r2 xs
mkIntervalMap :: (Ord v) => [((v, v), a)] -> FT.IntervalMap v a
mkIntervalMap = foldr ins FT.empty
where ins ((lo, hi), n) = FT.insert (FT.Interval lo hi) n