The name of the initial branch for new projects is now "main" instead of "master". Existing projects remain unchanged. More information: https://doku.lrz.de/display/PUBLIC/GitLab

Util.hs 3.63 KB
Newer Older
1 2
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-}

Philipp Meyer's avatar
Philipp Meyer committed
3
module Util
Philipp Meyer's avatar
Philipp Meyer committed
4
    (elems,items,emap,prime,numPref,
Philipp Meyer's avatar
Philipp Meyer committed
5
     listSet,listMap,val,vals,mval,zeroVal,positiveVal,sumVal,
6
     makeVarMap,makeVarMapWith,buildVector,makeVector,getNames,
Philipp Meyer's avatar
Philipp Meyer committed
7
     Vector,Model,VarMap,SIMap,SBMap,IMap,BMap,showWeighted,
8
     OptIO,verbosePut,opt,putLine,parallelIO)
Philipp Meyer's avatar
Philipp Meyer committed
9 10
where

11
import Data.SBV
12 13 14 15
import qualified Data.Map as M
import Data.List
import Data.Ord
import Data.Function
16 17
import Control.Concurrent.ParallelIO
import Control.Monad
Philipp Meyer's avatar
Philipp Meyer committed
18
import Control.Monad.Reader
19
import System.IO
Philipp Meyer's avatar
Philipp Meyer committed
20 21

import Options
Philipp Meyer's avatar
Philipp Meyer committed
22

23 24 25
{-
- Various maps and functions on them
-}
Philipp Meyer's avatar
Philipp Meyer committed
26

27
newtype Vector a = Vector { getVector :: M.Map a Integer }
28 29 30 31 32 33 34
type Model a = M.Map String a
type VarMap a = M.Map a String
type SIMap a = M.Map a SInteger
type SBMap a = M.Map a SBool
type IMap a = M.Map a Integer
type BMap a = M.Map a Bool

35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69
class MapLike c a b | c -> a, c -> b where
        val :: c -> a -> b
        vals :: c -> [b]
        elems :: c -> [a]
        items :: c -> [(a,b)]

        mval :: c -> [a] -> [b]
        mval = map . val
        sumVal :: (Num b) => c -> b
        sumVal = sum . vals

instance (Ord a, Show a, Show b) => MapLike (M.Map a b) a b where
        val m x = M.findWithDefault
                    (error ("key " ++ show x ++ " not found in " ++ show m))
                    x m
        vals = M.elems
        items = M.toList
        elems = M.keys

instance (Ord a, Show a) => MapLike (Vector a) a Integer where
        val (Vector v) x = M.findWithDefault 0 x v
        vals = vals . getVector
        items = M.toList . getVector
        elems = M.keys . getVector

instance (Show a) => Show (Vector a) where
        show (Vector v) =
                "[" ++ intercalate "," (map showEntry (M.toList v)) ++ "]"
            where showEntry (i,x) =
                    show i ++ (if x /= 1 then "(" ++ show x ++ ")" else "")

emap :: (Ord a, Ord b) => (a -> b) -> Vector a -> Vector b
emap f = Vector . M.mapKeys f . getVector

zeroVal :: (Ord a, Show a) => M.Map a SInteger -> a -> SBool
70 71
zeroVal m x = val m x .== 0

72
positiveVal :: (Ord a, Show a) => M.Map a SInteger -> a -> SBool
73 74 75 76
positiveVal m x = val m x .> 0

makeVarMap :: (Show a, Ord a) => [a] -> VarMap a
makeVarMap = makeVarMapWith id
77

78 79
makeVarMapWith :: (Show a, Ord a) => (String -> String) -> [a] -> VarMap a
makeVarMapWith f xs = M.fromList $ xs `zip` map (f . show) xs
80

81 82 83
getNames :: VarMap a -> [String]
getNames = M.elems

84
buildVector :: (Ord a) => [(a, Integer)] -> Vector a
85
buildVector = makeVector . M.fromList
86 87

makeVector :: (Ord a) => M.Map a Integer -> Vector a
88
makeVector = Vector . M.filter (/=0)
89 90 91 92

{-
- List functions
-}
93

Philipp Meyer's avatar
Philipp Meyer committed
94 95
listSet :: (Ord a) => [a] -> [a]
listSet = map head . group . sort
96

Philipp Meyer's avatar
Philipp Meyer committed
97 98 99
listMap :: (Ord a, Num b) => [(a,b)] -> [(a,b)]
listMap = map (foldl1 (\(x1,y1) (_,y2) -> (x1,y1 + y2))) .
        groupBy ((==) `on` fst) .  sortBy (comparing fst)
100

101
{-
Philipp Meyer's avatar
Philipp Meyer committed
102
- IO functions
103 104
-}

Philipp Meyer's avatar
Philipp Meyer committed
105 106 107 108 109 110 111 112 113
type OptIO a = ReaderT Options IO a

opt :: (Options -> a) -> OptIO a
opt getOpt = liftM getOpt ask

verbosePut ::  Int -> String -> OptIO ()
verbosePut level str = do
        verbosity <- opt optVerbosity
        when (verbosity >= level) (putLine str)
114
        liftIO $ hFlush stdout -- TODO: remove again
Philipp Meyer's avatar
Philipp Meyer committed
115 116 117

putLine :: String -> OptIO ()
putLine = liftIO . putStrLn
118

119 120 121 122 123
parallelIO :: [OptIO a] -> OptIO [a]
parallelIO tasks = do
        opts <- ask
        liftIO $ parallel $ map (`runReaderT` opts) tasks

124 125 126 127
{-
- String functions
-}

128 129
prime :: String -> String
prime = ('\'':)
130

131 132 133 134 135
numPref :: String -> [String]
numPref s = map (\i -> s ++ show i) [(1::Integer)..]

showWeighted :: (Show a, Num b, Eq b, Show b) => (a, b) -> String
showWeighted (x, w) = (if w == 1 then "" else show w) ++ show x
136