module Data.RangeMin (
RangeMin, Comparator,
rangeMinBy, rangeMin, rangeMinValue, rangeMinValueBy, rangeMinOpt,
rangeMinBy', rangeMin', rangeMinValue', rangeMinValueBy',
rangeMinByM, rangeMinM,
lowestCommonAncestor, lowestCommonAncestorBy, lowestCommonAncestorBy'
) where
import Control.Monad (liftM, liftM2)
import Data.Maybe(fromJust, catMaybes, fromMaybe)
import Data.Tree (Tree(Node))
import Data.List(tails)
import Data.Monoid
import Data.Array.IArray(listArray, array, elems, bounds, Ix, Array, (!))
import GHC.Arr(unsafeIndex, unsafeRangeSize)
import Data.Array.MArray(freeze)
import Data.Foldable (Foldable, toList)
import Data.Array.Base
import Data.Array.ST(STArray, runSTUArray)
import Control.Arrow((&&&))
import Data.Ix(Ix(range))
import Data.RangeMin.Internal.HandyArray
import Data.RangeMin.Internal.HandyOrdering (minimumBy, orderPair, minBy, comparing)
import Data.RangeMin.Internal.Combinators (onPair, on, (.:))
import Data.RangeMin.Internal.HandyNumeric
import Data.RangeMin.Internal.HandyList
import Control.Monad.ST
import Data.Array.Unboxed(UArray)
import GHC.Exts
type RangeMin i e = (i, i) -> (i, e)
type RangeMinVal i e = (i, i) -> e
type Comparator e = e -> e -> Ordering
offset :: Enum i => i -> Int -> i
offset (fromEnum -> x) = toEnum . (x+)
rangeSize :: Enum i => (i, i) -> Int
rangeSize (fromEnum -> i, fromEnum -> j) = ji+1
index :: Enum i => (i, i) -> i -> Int
index (fromEnum -> i, _) (fromEnum -> x) = xi
zeroEft' :: Int -> [Int]
zeroEft' i = zeroEft (i 1)
data IntAccum e = IA !Int e
data BlockAccum e f = BA !Int e f
assocs' :: Enum i => (i, i) -> [e] -> [(i, e)]
assocs' (_, fromEnum -> iMax) l = build (\ c nil -> case foldr (assocs'' c) (IA iMax nil) l of IA _ ls -> ls) where
assocs'' c x (IA i ls) = IA (i1) ((toEnum i, x) `c` ls)
blockify :: Int -> Int -> [e] -> [(Int, [e])]
blockify n bS l = build (\ c nil -> case foldr (blocker c) (BA n [] nil) l of BA _ _ bs -> bs) where
!breakpoint = n bS
blocker c x (BA i b bs) = let j = i1 in
if j `rem` bS == 0 then BA j [] ((if j > breakpoint then n j else bS, x:b) `c` bs) else BA j (x:b) bs
boxer :: (Int# -> Int#) -> Int -> Int
boxer f (I# i) = I# (f i)
unboxer :: (Int -> Int) -> Int# -> Int#
unboxer f i = case f (I# i) of I# x -> x
boxIn :: (Int# -> e) -> Int -> e
boxIn f (I# i) = f i
unboxIn :: (Int -> e) -> Int# -> e
unboxIn f i = f (I# i)
rangeMin3Look :: (Int# -> e) -> Comparator e -> Int -> [Int] -> RangeMinVal Int Int
rangeMin3Look (boxIn -> look) cmp !n ixs =
runST $ liftM (. uncurry encodePosition) $ mListUArray rmSize $ build (\ c n -> foldr (\ t -> scanl1FB min' t c) n (tails ixs))
where encodePosition !i !j = i * lastIx + j half ((i 1) * i)
!rmSize = lastIx * n half ((lastIx 1) * lastIx) + 1
!lastIx = n 1
min' = minBy (cmp `on` look)
rangeMin2Look :: (Int# -> e) -> Comparator e -> Int -> [Int] -> RangeMinVal Int Int
rangeMin2Look (boxIn -> look) cmp n ixs = \ r@(i, j) ->
if i == j then initRow i else
let !logWidth = intLog (j i)
!left = i
!right = j pow2 logWidth + 1 in rM logWidth left right
where !logn = intLog n + 1
min' = minBy (cmp `on` look)
!(initRow, rMs) = runST $
do iR <- liftM unboxer $ mListUArray n ixs
rm <- mListArray logn $ build (rower 1 iR)
return (boxer iR, rm)
nextRow !p !p' (boxer -> row) =
runST $ liftM unboxer $ mFuncUArray (n p' + 1) (\ i -> (min' `on` row) i (i+p))
rower !p rowM c nil
| p >= n = nil
| otherwise = rowM `c` rower p' (nextRow p p' rowM) c nil
where !p' = p + p
rM r = min' `on` boxer (rMs r)
blockedRangeMin :: Show e => Comparator e -> Int -> (Int -> RangeMinVal Int e) -> RangeMinVal Int e -> RangeMinVal Int e
blockedRangeMin (minBy -> min') !bS !blockRM !multiBlockRM (flip quotRem' bS -> (!bi,!xi), flip quotRem' bS -> (!bj, !xj)) =
if bi == bj then blockRM bi (xi, xj) else
let sidesMin = min' (blockRM bi (xi, lastIx)) (blockRM bj (0, xj)) in
(if bi == pred bj then sidesMin else
min' sidesMin (multiBlockRM (succ bi, pred bj)))
where !lastIx = bS 1
rangeMin1Look :: (Int# -> e) -> Comparator e -> Int -> [Int] -> RangeMinVal Int Int
rangeMin1Look look cmp n ixs =
blockedRangeMin (cmp `on` boxIn look) blockSize blockRM multiBlockRM
where !blockSize = 1 + intLog n
!nBlocks = n `divCeil` blockSize
blockRM = runST $ mListArray nBlocks $
map (uncurry (rangeMin3Look look cmp)) $ blockify n blockSize ixs
bW = blockWidth n blockSize
multiBlockRM = internalRangeMinBy look cmp nBlocks $
map (\ i -> blockRM i (0, bW i 1)) $ zeroEft' nBlocks
blockWidth :: Int -> Int -> Int -> Int
blockWidth !n !bS = let !nBlocks = n `divCeil` bS 1 in \ !i -> if i == nBlocks then n `modCeil` bS else bS
catalanArr :: UArray (Int, Int) Int
catalanArr = runSTUArray $
do !arr <- newArray_ r
let writer !i !j = unsafeWrite arr (unsafeIndex r (i, j)) =<< cat arr i j
mapM_ (\ !i -> mapM_ (writer i) $ unsafeEft i 16) $ zeroEft 16
return arr
where r = ((0,0), (16,16))
cat arr i j = case i of
0 -> return 1
1 -> return j
_ -> liftM2 (+) (reader arr (i1, j)) (reader arr (i, j1))
reader !arr !p = unsafeRead arr (unsafeIndex r p)
catalan :: (Int, Int) -> Int
catalan = unsafeLookup catalanArr
stackProcessor :: (e -> Bool) -> Int -> Int -> [e] -> (Int, Int, [e])
stackProcessor pr p = stackProc' 0 where
stackProc' !cum !q stack = case stack of
(x:xs) | pr x -> stackProc' (cum + catalan (p, q)) (q1) xs
_ -> (cum, q, stack)
data Ixr e = Ixr [e] !Int !Int !Int
indexer :: Comparator e -> e -> Ixr e -> Ixr e
indexer cmp = index' where
index' !x !(Ixr stack p q ans) = case stackProcessor (\ y -> cmp x y == LT) p q stack of
(acc, q', stack') -> Ixr (x:stack') (p1) q' (ans + acc)
rangeMin0Look :: (Int# -> e) -> Comparator e -> Int -> [Int] -> RangeMinVal Int Int
rangeMin0Look look cmp n ixs =
runST $ do iLookup <- liftM unboxer $ mListUArray n ixs
indexRM <- newArr indexRange
types <- funcMUArray nBlocks (procBlock iLookup indexRM)
indexRMIce <- mLook indexRM
let blockRM !b = boxer iLookup . (blockSize * b +) . indexRMIce (types b)
let blockMin !i = blockRM i (0, min (n blockSize * i) blockSize 1)
return $ blockedRangeMin (cmp `on` boxIn look) blockSize blockRM $ internalRangeMinBy look cmp nBlocks (map blockMin (zeroEft' nBlocks))
where !blockSize = max 4 (ceilLog n `divCeil` 4)
!nBlocks = n `divCeil` blockSize
indexRange = catalan (blockSize, blockSize)
look' iLookup = boxIn look . boxer iLookup
procBlock :: (Int# -> Int#) -> MArr (RangeMinVal Int Int) s -> Int -> ST s Int
procBlock iLookup indexRM !b =
let !start = blockSize * b
!width = min blockSize (n start) 1
lookIl = look' iLookup
Ixr _ _ _ !ans = foldr (indexer cmp) (Ixr [] (blockSize1) blockSize 0) $ map lookIl $ reverseEft start (start + width)
in writeArr indexRM ans (rangeMin3Look I# (cmp `on` (lookIl . (+start))) (width+1) $ zeroEft width) >> return ans
rangeMin3Size = 100
rangeMin2Size = 660
rangeMin1Size = 1200
rangeMinFunc :: Int -> a -> a -> a -> a -> a
rangeMinFunc !n f3 f2 f1 f0 = if n < rangeMin2Size then (if n < rangeMin3Size then f3 else f2) else (if n < rangeMin1Size then f1 else f0)
internalRangeMinBy :: (Int# -> e) -> Comparator e -> Int -> [Int] -> RangeMinVal Int Int
internalRangeMinBy look cmp !n l = let rM = lazyInternalRangeMinBy look cmp n l in rM (0, n1) `seq` rM
lazyInternalRangeMinBy :: (Int# -> e) -> Comparator e -> Int -> [Int] -> RangeMinVal Int Int
lazyInternalRangeMinBy look cmp !n = rangeMinFunc n rangeMin3Look rangeMin2Look rangeMin1Look rangeMin0Look look cmp n
initRangeMin :: (Int# -> e) -> Comparator e -> Int -> RangeMinVal Int Int
initRangeMin look cmp n = rangeMin0Look look cmp n $ zeroEft' n
rangeMinBy' :: (Enum i) => Comparator e
-> (i, i)
-> [e]
-> RangeMin i e
rangeMinBy' cmp bounds@(rangeSize -> n) elems =
let (iMin, _) = bounds; look = runST $ liftM unboxIn $ mListArray n elems
in (offset iMin &&& boxIn look) . initRangeMin look cmp n . onPair (index bounds)
rangeMin' :: (Enum i, Ord e) =>
(i, i)
-> [e]
-> RangeMin i e
rangeMin' = rangeMinBy' compare
rangeMinValueBy' :: Enum i => Comparator e -> (i, i) -> [e] -> ((i, i) -> e)
rangeMinValueBy' cmp bounds@(rangeSize -> n) elems =
let look = runST $ liftM unboxIn $ mListArray n elems in boxIn look . initRangeMin look cmp n . onPair (index bounds)
rangeMinValue' :: (Enum i, Ord e) => (i, i) -> [e] -> ((i, i) -> e)
rangeMinValue' = rangeMinValueBy' compare
rangeMinBy :: (IArray a e, Enum i, Ix i) => Comparator e
-> a i e
-> RangeMin i e
rangeMinBy cmp arr@(numElements -> n) = let arrBounds@(iMin, _) = bounds arr; look = unboxIn $ unsafeAt arr in
(offset iMin &&& boxIn look) . initRangeMin look cmp n . onPair (index arrBounds)
rangeMin :: (IArray a e, Enum i, Ix i, Ord e) => a i e -> RangeMin i e
rangeMin = rangeMinBy compare
rangeMinOpt :: UArray Int Int -> RangeMinVal Int Int
rangeMinOpt arr@(numElements -> n) = unsafeAt arr . initRangeMin (unboxIn $ unsafeAt arr) compare n
rangeMinValueBy :: (IArray a e, Enum i, Ix i) => Comparator e -> a i e -> ((i, i) -> e)
rangeMinValueBy cmp !arr@(numElements -> n) = let arrBounds = bounds arr; look = unboxIn $ unsafeAt arr in
boxIn look . initRangeMin look cmp n . onPair (index arrBounds)
rangeMinValue :: (IArray a e, Enum i, Ix i, Ord e) => a i e -> ((i, i) -> e)
rangeMinValue = rangeMinValueBy compare
rangeMinByM :: (Monad m, MArray a e m, Enum i, Ix i) => Comparator e -> a i e -> m (RangeMin i e)
rangeMinByM cmp = liftM (rangeMinBy cmp . asPureArray) . freeze
rangeMinM :: (Monad m, MArray a e m, Enum i, Ix i, Ord e) => a i e -> m (RangeMin i e)
rangeMinM = rangeMinByM compare
lcaTraversal :: Tree e -> (Int, [(Int, e)])
lcaTraversal t = case lcaTraversal' 0 t (IA 0 []) of IA n l -> (n, l); where
lcaTraversal' !d (Node a ts) trav = let cat = lcaTraversal' (d+1); consHere (IA m tr) = IA (m+1) ((d, a):tr) in case ts of
[] -> consHere trav
[t] -> consHere (t `cat` trav)
(t:ts) -> t `cat` foldr (consHere .: cat) trav ts
lowestCommonAncestorBy :: Ix i => (a -> Maybe i)
-> (i, i)
-> Tree a
-> ((a, a) -> a)
lowestCommonAncestorBy ix r tree = lowestCommonAncestorBy' ix r tree . onPair (fromJust . ix)
lowestCommonAncestorBy' :: Ix i => (a -> Maybe i)
-> (i, i)
-> Tree a
-> ((i, i) -> a)
lowestCommonAncestorBy' ix r (lcaTraversal -> (n, trav)) = snd . rM . orderPair . onPair indexes
where pairList = [(x, i) | (i, ix . snd -> Just x) <- zipNaturals n trav]
rM = rangeMinValueBy' (comparing fst) (0, n1) trav
indexes = unsafeLookup $ asPureArray $ array r pairList
lowestCommonAncestor :: Ix i => (i, i)
-> Tree i
-> ((i, i) -> i)
lowestCommonAncestor = lowestCommonAncestorBy Just