module Text.Numeral.Rules
(
Rule
, conditional
, combine
, mapRule
, findRule
, unknown
, lit, lit1
, pos, checkPos
, dual, plural
, inflection
, add
, mul, mul1
, sub
, mulScale_, mulScale, mulScale1
, shortScale, longScale, pelletierScale
, shortScale1, longScale1, pelletierScale1
, mkStep, step, step1
) where
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.Reified ( Side(L, R) )
import "this" Text.Numeral.Misc ( intLog )
import qualified "this" Text.Numeral.Exp as E
import qualified "fingertree" Data.IntervalMap.FingerTree as FT
( Interval(Interval)
, IntervalMap, empty, insert
, search
)
type Rule α β = (α → β) → (α → β)
conditional ∷ (α → Bool)
→ Rule α β
→ Rule α β
→ Rule α β
conditional p t e = \f n → if p n
then t f n
else e f n
combine ∷ (E.Unknown β)
⇒ Rule α β
→ Rule α β
→ Rule α β
combine r1 r2 = \f n → case r1 f n of
x | E.isUnknown x → r2 f n
| otherwise → x
mapRule ∷ (α → α) → Rule α β → Rule α β
mapRule g r = \f n → r f (g n)
findRule ∷ (Ord α, Num α, E.Unknown β)
⇒ (α, Rule α β)
→ [(α, Rule α β)]
→ α
→ Rule α β
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 ∷ (E.Unknown β) ⇒ Rule α β
unknown _ _ = E.unknown
lit ∷ (Integral α, E.Lit β) ⇒ Rule α β
lit = const $ E.lit ∘ fromIntegral
lit1 ∷ (Integral α, E.Lit β, E.Mul β) ⇒ Rule α β
lit1 = const $ \n → E.lit 1 `E.mul` E.lit (fromIntegral n)
pos ∷ (Ord α, Num α, E.Lit β, E.Neg β) ⇒ Rule α β
pos f n | n < 0 = E.neg $ f (abs n)
| n > 0 = f n
| otherwise = E.lit 0
checkPos ∷ (Ord α, Num α, E.Unknown β, E.Lit β) ⇒ Rule α β
checkPos f n | n < 0 = E.unknown
| n > 0 = f n
| otherwise = E.lit 0
dual ∷ (E.Dual β) ⇒ Rule α β
dual = (∘) E.dual
plural ∷ (E.Plural β) ⇒ Rule α β
plural = (∘) E.plural
inflection ∷ (E.Inflection β) ⇒ (E.Inf β → E.Inf β) → Rule α β
inflection changeInf = \f n → E.inflection changeInf $ f n
add ∷ (Num α, E.Add β) ⇒ α → Side → Rule α β
add val s = \f n → (flipIfR s E.add) (f $ n val) (f val)
mul ∷ (Integral α, E.Add β, E.Mul β) ⇒ α → Side → Side → Rule α β
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 α, E.Lit β, E.Add β, E.Mul β)
⇒ α → Side → Side → Rule α β
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 α, E.Sub β) ⇒ α → Rule α β
sub val = \f n → E.sub (f $ val n) (f val)
mkStep ∷ (Integral α, E.Unknown β, E.Lit β, E.Add β, E.Mul β)
⇒ Rule α β
→ (α → Side → Rule α β)
→ (α → Side → Side → Rule α β)
→ α → α → Side → Side → Rule α β
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 α, E.Unknown β, E.Lit β, E.Add β, E.Mul β)
⇒ α → α → Side → Side → Rule α β
step = mkStep lit add mul
step1 ∷ (Integral α, E.Unknown β, E.Lit β, E.Add β, E.Mul β)
⇒ α → α → Side → Side → Rule α β
step1 = mkStep lit1 add mul1
mulScale_ ∷ (Integral α, E.Scale α, E.Unknown β, E.Add β, E.Mul β, E.Scale β)
⇒ ( (α → β)
→ α
→ β
→ Side
→ β
)
→ α
→ α
→ Side
→ Side
→ Rule α β
→ Rule α β
mulScale_ doMul 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` E.scale base' offset' rank'
scale' = E.scale base' offset' rankExp
mval = doMul f m scale' mSide
in if E.isUnknown rankExp
then E.unknown
else if a ≡ 0
then mval
else (flipIfR aSide E.add) (f a) mval
mulScale ∷ (Integral α, E.Scale α, E.Unknown β, E.Add β, E.Mul β, E.Scale β)
⇒ α
→ α
→ Side
→ Side
→ Rule α β
→ Rule α β
mulScale = mulScale_ $ \f m scale' mSide →
case m of
1 → scale'
_ → (flipIfR mSide E.mul) (f m) scale'
mulScale1 ∷ (Integral α, E.Scale α, E.Unknown β, E.Add β, E.Mul β, E.Scale β)
⇒ α
→ α
→ Side
→ Side
→ Rule α β
→ Rule α β
mulScale1 = mulScale_ $ \f m scale' mSide → (flipIfR mSide E.mul) (f m) scale'
shortScale ∷ (Integral α, E.Scale α, E.Unknown β, E.Add β, E.Mul β, E.Scale β)
⇒ Side
→ Side
→ Rule α β
→ Rule α β
shortScale = mulScale 3 3
shortScale1 ∷ (Integral α, E.Scale α, E.Unknown β, E.Add β, E.Mul β, E.Scale β)
⇒ Side
→ Side
→ Rule α β
→ Rule α β
shortScale1 = mulScale1 3 3
longScale ∷ (Integral α, E.Scale α, E.Unknown β, E.Add β, E.Mul β, E.Scale β)
⇒ Side
→ Side
→ Rule α β
→ Rule α β
longScale = mulScale 6 0
longScale1 ∷ (Integral α, E.Scale α, E.Unknown β, E.Add β, E.Mul β, E.Scale β)
⇒ Side
→ Side
→ Rule α β
→ Rule α β
longScale1 = mulScale1 6 0
pelletierScale ∷ (Integral α, E.Scale α, E.Unknown β, E.Add β, E.Mul β, E.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 α, E.Scale α, E.Unknown β, E.Add β, E.Mul β, E.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)
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, k21), 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