AERN-Real-0.9.7: src/Data/Number/ER/Misc.hs
{-|
Module : Data.Number.ER.Misc
Description : general purpose extras
Copyright : (c) Michal Konecny
License : BSD3
Maintainer : mik@konecny.aow.cz
Stability : experimental
Portability : portable
Miscelaneous utilities (eg related to Ordering, pairs, booleans, strings)
-}
module Data.Number.ER.Misc where
import Data.List
import System.IO.Unsafe
unsafePrint msg val =
unsafePerformIO $
do
putStrLn $ "unsafe: " ++ msg
return val
unsafePrintReturn msg a =
unsafePrint (msg ++ show a) a
{-|
Compose as when defining the lexicographical ordering.
-}
compareCompose :: Ordering -> Ordering -> Ordering
compareCompose EQ o = o
compareCompose o _ = o
{-|
Compose as when defining the lexicographical ordering.
-}
compareComposeMany :: [Ordering] -> Ordering
compareComposeMany [] = EQ
compareComposeMany (EQ:os) = compareComposeMany os
compareComposeMany (o:_) = o
{-|
The lexicographical ordering.
-}
compareLex :: (Ord a) => [a] -> [a] -> Ordering
compareLex [] _ = LT
compareLex _ [] = GT
compareLex (x:xs) (y:ys)
| x == y = compareLex xs ys
| otherwise = compare x y
mapFst :: (a1 -> a2) -> (a1,b) -> (a2,b)
mapFst f (a,b) = (f a,b)
mapSnd :: (b1 -> b2) -> (a,b1) -> (a,b2)
mapSnd f (a,b) = (a,f b)
mapPair :: (a1 -> a2, b1 -> b2) -> (a1,b1) -> (a2,b2)
mapPair (f1, f2) (a,b) = (f1 a, f2 b)
mapPairHomog :: (a1 -> a2) -> (a1,a1) -> (a2,a2)
mapPairHomog f = mapPair (f,f)
unpair :: [(a,a)] -> [a]
unpair = (\(l1,l2) -> l1 ++ l2) . unzip
bool2maybe :: Bool -> Maybe ()
bool2maybe True = Just ()
bool2maybe False = Nothing
dropLast :: Int -> [a] -> [a]
dropLast n list = reverse $ drop n (reverse list)
{-|
eg
> concatWith "," ["a","b"] = "a,b"
-}
concatWith ::
String {-^ a connective -} ->
[String] ->
String
concatWith sep [] = ""
concatWith sep [str] = str
concatWith sep (str : strs) = str ++ sep ++ (concatWith sep strs)
{-|
eg
> replicateSeveral [(2,"a"),(1,"b")] = "aab"
-}
replicateSeveral :: [(Int,a)] -> [a]
replicateSeveral [] = []
replicateSeveral ((n,e):rest) =
replicate n e ++ (replicateSeveral rest)
{-|
eg
> countDuplicates "aaba" = [(2,"a"),(1,"b"),(1,"a")]
-}
countDuplicates ::
Eq a =>
[a] ->
[(Int,a)]
countDuplicates list =
map (\ g -> (length g, head g)) $ group list
{-|
eg
> allCombinations
> [
> (1,['a']),
> (2,['b','c']),
> (3,['d','e','f'])
> ] =
> [
> [(1,'a'),(2,'b'),(3,'d')],
> [(1,'a'),(2,'b'),(3,'e')],
> [(1,'a'),(2,'b'),(3,'f')],
> [(1,'a'),(2,'c'),(3,'d')],
> [(1,'a'),(2,'c'),(3,'e')],
> [(1,'a'),(2,'c'),(3,'f')]
> ]
-}
allCombinations ::
[(k,[v])] -> [[(k,v)]]
allCombinations [] = [[]]
allCombinations ((k, vals) : rest) =
concat $ map (\ v -> map ((k,v):) restCombinations) vals
where
restCombinations =
allCombinations rest
allPairsCombinations ::
[(k,(v,v))] -> [[(k,v)]]
allPairsCombinations [] = [[]]
allPairsCombinations ((k, (v1,v2)) : rest) =
(map ((k, v1) :) restCombinations)
++
(map ((k, v2) :) restCombinations)
where
restCombinations =
allPairsCombinations rest
{-|
eg
> allPairsCombinationsEvenOdd
> [
> (1,('a0','a1'),
> (2,('b0','b1'),
> (3,('c0','c1')
> ] =
> ([
> [(1,'a0'),(2,'b0'),(3,'c0')],
> [(1,'a0'),(2,'b1'),(3,'c1')],
> [(1,'a1'),(2,'b1'),(3,'c0')],
> [(1,'a1'),(2,'b0'),(3,'c1')]
> ]
> ,[
> [(1,'a0'),(2,'b0'),(3,'c1')],
> [(1,'a0'),(2,'b1'),(3,'c0')],
> [(1,'a1'),(2,'b0'),(3,'c0')],
> [(1,'a1'),(2,'b1'),(3,'c1')]
> ]
> )
-}
allPairsCombinationsEvenOdd ::
[(k,(v,v))] {-^ the first value is even, the second odd -} ->
([[(k,v)]], [[(k,v)]])
allPairsCombinationsEvenOdd [] = ([[]], [])
allPairsCombinationsEvenOdd ((k, (evenVal,oddVal)) : rest) =
(
(map ((k, evenVal) :) restCombinationsEven)
++
(map ((k, oddVal) :) restCombinationsOdd)
,
(map ((k, evenVal) :) restCombinationsOdd)
++
(map ((k, oddVal) :) restCombinationsEven)
)
where
(restCombinationsEven, restCombinationsOdd) =
allPairsCombinationsEvenOdd rest
{- numeric -}
intLogDown b n = fst $ intLog b n
intLogUp b n = snd $ intLog b n
intLog ::
(Num n1, Num n2, Ord n1, Integral n2) =>
n1 {-^ base -} ->
n1 {-^ x -} ->
(n2, n2)
intLog b n
| n == 1 = (0,0)
| n > 1 && n < b = (0,1)
| n >= b =
bisect (lgDn, pwDn) (lgUp, pwUp)
| otherwise =
error $ "Data.Number.ER.Misc: intLog: illegal argument n = " ++ show n
where
((lgDn, pwDn), (lgUp, pwUp)) =
findBounds (1, b)
-- lgDn <= log_b n < lgUp; pwDn = b^lgDn; pwUp = b^lgUp
findBounds (lg, pw)
| n < pwNext = ((lg, pw), (lgNext, pwNext))
| otherwise = findBounds (lgNext, pwNext)
where
lgNext = 2 * lg
pwNext = pw * pw
bisect (lgDn, pwDn) (lgUp, pwUp)
| pwDn == n = (lgDn, lgDn)
| pwUp == n = (lgUp, lgUp)
| lgDn == lgMid = (lgDn, lgUp)
| lgUp == lgMid = (lgDn, lgUp)
| n < pwMid =
bisect (lgDn, pwDn) (lgMid, pwMid)
| otherwise =
bisect (lgMid, pwMid) (lgUp, pwUp)
where
lgMid = (lgDn + lgUp) `div` 2
pwMid = pwDn * (b ^ (lgMid - lgDn))
{-|
Directionally rounded versions of @+,*,sum,prod@.
-}
plusUp, plusDown, timesUp, timesDown ::
(Num t) =>
t -> t -> t
sumUp, sumDown, productDown, productUp ::
(Num t) =>
[t] -> t
plusUp = (+)
plusDown c1 c2 = - ((- c1) - c2)
sumUp = foldl plusUp 0
sumDown = foldl plusDown 0
timesUp = (*)
timesDown c1 c2 = - ((- c1) * c2)
productUp = foldl timesUp 1
productDown = foldl timesDown 1
{- parsing -}
readMaybe :: (Read a) => String -> Maybe a
readMaybe s =
case reads s of
[] -> Nothing
(val,_) : _ -> Just val
showFirstLastLines ::
(Show a) =>
Int {-^ how many initial lines to use -} ->
Int {-^ how many final lines to use -} ->
a ->
String
showFirstLastLines lineCountInit lineCountFinal x
| linesTotal > lineCount =
unlines $
firstLines
++ ["...(" ++ show (linesTotal - lineCount) ++ " lines omitted)..."] ++
lastLines
| otherwise = unlines firstLines
where
lineCount = lineCountInit + lineCountFinal
firstLines = take lineCountInit allLines
lastLines = drop (linesTotal - lineCountFinal) allLines
allLines = lines $ show x
linesTotal = length allLines
{- sequences -}
listUpdate :: Int -> a -> [a] -> [a]
listUpdate i newx (x:xs)
| i == 0 = newx : xs
| i > 0 = x : (listUpdate (i - 1) newx xs)
listHasMatch :: (a -> Bool) -> [a] -> Bool
listHasMatch f s =
foldl (\b a -> b && (f a)) False s
--{-| types encoding natural numbers -}
--class TypeNumber n
-- where
-- getTNData :: n
-- getTNNumber :: n -> Int
--
--data TN_0 = TN_0
--tn_0 = TN_0
--data TN_SUCC tn_prev = TN_SUCC tn_prev
--
--type TN_ONE = TN_SUCC TN_0
--tn_1 = TN_SUCC TN_0
--
--instance (TypeNumber TN_0)
-- where
-- getTNData = TN_0
-- getTNNumber _ = 0
--
--instance
-- (TypeNumber tn_prev) =>
-- (TypeNumber (TN_SUCC tn_prev))
-- where
-- getTNData = TN_SUCC getTNData
-- getTNNumber (TN_SUCC p) = 1 + (getTNNumber p)