diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jan Mas Rovira (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jan Mas Rovira nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified AM3.Main as A + +main :: IO () +main = A.main diff --git a/grasp.cabal b/grasp.cabal new file mode 100644 --- /dev/null +++ b/grasp.cabal @@ -0,0 +1,106 @@ +name: grasp +version: 0.1.0.0 +synopsis: GRASP implementation for the AMMM project. +description: + = Brief summary + This is part of the final project for the AMMM (MIRI, FIB-UPC) subject. + It contains the random instance generator plus all the GRASP part. + . + It is hosted at https://bitbucket.org/janmasrovira/am3-project. + . + This package includes: + . + * A polymorphic GRASP implementation. + * A random instance generator for the AM3 project. + * The @AM3@ folder contains the code specific to the final project for + the Algorithmic Methods for Mathematical Models subject + (Master in Innovation and Research in Informatics, FIB-UPC). + . + = Contents + Make sure to read the documentation of all the modules listed below. + . + Specifically, the contents of each module (sorted by relevance to the project) are: + . + 1. "GRASP": A polymorphic parameterizable implementation of a Greedy Randomized + Adaptive Search Procedure (GRASP). + The idea is taken from this paper: http://www.optimization-online.org/DB_FILE/2001/09/371.pdf. + It does not contain anything that is specific to the AM3 project. + 2. "AM3.Solution": Contains all the specific functions to the solution of an + instance of the AM3 project. + 3. "AM3.RandomInstance": A parameterizable random generator of instances. + 4. "AM3.Instance": An instance of the problem. It also provides useful functions that + have to do with constructing, querying, importing, exporting... an instance. + +homepage: https://bitbucket.org/janmasrovira/am3-project/overview +license: BSD3 +license-file: LICENSE +author: Jan Mas Rovira +maintainer: janmasrovira@gmail.com +copyright: 2015 Jan Mas Rovira +category: Development +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: GRASP + , AM3.Instance + , AM3.Solution + , AM3.Main + , AM3.DatParser + , AM3.RandomInstance + , AM3.TestParams + , AM3.Solver + , AM3.Scripts + build-depends: + base >= 4.8 && < 5 + , clock >= 0.6 + , directory >= 1.2.2 + , extra >= 1.4.2 + , filepath >= 1.4 + , hashable >= 1.2.3.3 + , lens >= 4.13 + , mtl >= 2.2.1 + , pcre-heavy >= 1.0.0.1 + , primitive >= 0.6.1 + , process >= 1.2.3 + , random-shuffle >= 0.0.4 + , safe >= 0.3.9 + , split >= 0.2.2 + , system-filepath >= 0.4.13 + , text >= 1.2.2 + , transformers >= 0.4.2 + , turtle >= 1.2.4 + , unordered-containers >= 0.2.5.1 + , vector >= 0.11 + , MonadRandom >= 0.4.1 + , megaparsec >= 4.2 + default-language: Haskell2010 + default-extensions: TupleSections + , MultiWayIf + , RecordWildCards + , GeneralizedNewtypeDeriving + , LambdaCase + ghc-options: -O2 + other-modules: AM3.Regex + +executable grasp-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , grasp + default-language: Haskell2010 + +test-suite grasp-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , grasp + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://bitbucket.org/janmasrovira/am3-project diff --git a/src/AM3/DatParser.hs b/src/AM3/DatParser.hs new file mode 100644 --- /dev/null +++ b/src/AM3/DatParser.hs @@ -0,0 +1,62 @@ +-- | Parses a file in OPL's @.dat@. +module AM3.DatParser ( + -- * Types + Assig(..) + , Value(..) + -- * Parser + , pdat + -- * AST traversal + , flatten + ) where + +import Control.Monad +import Text.Megaparsec hiding (fromFile) +import Text.Megaparsec.ByteString.Lazy +import Text.Megaparsec.Lexer (decimal) + +-- | An identifier is assigned a 'Value'. +data Assig = Assig String Value deriving (Show) + +-- | A 'Value' can either be an integer or a list of 'Value's. +data Value = Num Int | List [Value] deriving (Show) + +-- | Traversal of the AST in inorder. +flatten :: Value -> [Int] +flatten (Num x) = [x] +flatten (List xs) = concatMap flatten xs + +plist :: Parser Value +plist = List <$> between openSquare closeSquare (many pvalue) + +pvalue :: Parser Value +pvalue = pnum <|> plist + +openSquare :: Parser () +openSquare = void (char '[') <* space + +closeSquare :: Parser () +closeSquare = void (char ']') <* space + +pnum :: Parser Value +pnum = Num . fromIntegral <$> decimal <* space + +semicolon :: Parser () +semicolon = void (char ';') <* space + +equals :: Parser () +equals = void (char '=') <* space + +identifier :: Parser String +identifier = some letterChar <* space + +passig :: Parser Assig +passig = do + ident <- identifier + equals + v <- pvalue + semicolon + return (Assig ident v) + +-- | Parser of a @.dat@ file. +pdat :: Parser [Assig] +pdat = space >> many passig diff --git a/src/AM3/Instance.hs b/src/AM3/Instance.hs new file mode 100644 --- /dev/null +++ b/src/AM3/Instance.hs @@ -0,0 +1,224 @@ +-- | Data type representing an instance of the problem. + +{-# LANGUAGE RecordWildCards #-} + +module AM3.Instance ( + -- * Types + Instance + , CenterId + , OfficeId + , SegmentId + -- * Construction + , newInstance + -- * Importing + , fromFile + -- * Exporting + , toDat + , toFile + -- * Queries + , isAllowed + , numCenters + , numOffices + , numSegments + , officeData + , centerCost + , segmentCost + , segmentThreshold + , centerCosts + , segmentCosts + , segmentThresholds + , centers + , offices + , allowedConnections + , centerCapacity + , replications + , centerCapacities + , officeDatas + , index2CO + ) where + +import AM3.DatParser +import Control.Arrow +import Data.Foldable +import Data.Ix +import Data.List.Split (chunksOf) +import Data.Vector.Unboxed (Vector, fromList, (!)) +import qualified Data.Vector.Unboxed as V +import GRASP +import Text.Megaparsec hiding (fromFile) + +-- | Identifier of a Center. +type CenterId = Int + +-- | Identifier of an office. +type OfficeId = Int + +-- | Identifier of a segment. +type SegmentId = Int + +-- | Container for all parameters of the problem. +data Instance = Instance { + _nC :: Int -- ^ Number of centers. + , _nO :: Int -- ^ Number of offices. + , _nP :: Int -- ^ Number of segments + , _r :: Int -- ^ Number of replications. + , _d :: Vector Int -- ^ Needed storage per office. + , _k :: Vector Int -- ^ Center capacities. + , _f :: Vector Cost -- ^ Fixed cost of each center. + , _s :: Vector Cost -- ^ Segment costs. + , _m :: Vector Int -- ^ Segments thresholds. + , _u :: Vector Bool -- ^ Allowed connections. Stored by rows (row per center). + , _us :: [(CenterId, OfficeId)] -- ^ List of allowed connections. + } deriving (Show, Read) + +newInstance :: + Int -- ^ Number of replications. + -> [Int] -- ^ Needed storage per office. + -> [Int] -- ^ Center capacities. + -> [Cost] -- ^ Fixed costs. + -> [Cost] -- ^ Segment costs. + -> [Int] -- ^ Segment thresholds. + -> [Bool] -- ^ Allowed connections. + -> Instance +newInstance rr dd kk ff ss mm uu = + let x = + Instance { + _r = rr + , _nC = length kk + , _nO = length dd + , _nP = length mm + , _d = fromList dd + , _k = fromList kk + , _f = fromList ff + , _s = fromList ss + , _m = fromList mm + , _u = fromList uu + , _us = calcAllowedConnections x + } + in x + +allowedConnections :: Instance -> [(CenterId, OfficeId)] +allowedConnections = _us + +emptyInstance :: Instance +emptyInstance = newInstance 0 [] [] [] [] [] [] + +replications :: Instance -> Int +replications Instance{..} = _r + +-- | List of all 'CenterId'. +centers :: Instance -> [CenterId] +centers Instance{..} = range (0, _nC - 1) + +-- | List of all 'OfficeId'. +offices :: Instance -> [OfficeId] +offices Instance{..} = range (0, _nO - 1) + + +-- | True if the connection is allowed. +isAllowed :: Instance -> CenterId -> OfficeId -> Bool +isAllowed Instance{..} c o = _u ! ix + where ix = _nO*c + o + +-- | Unidimensional to bidimensional index. +index2CO :: Instance -> Int -> (CenterId, OfficeId) +index2CO Instance{..} = (`divMod`_nO) + +-- | Cost for using a center. +centerCost :: Instance -> CenterId -> Cost +centerCost Instance{..} = (_f !) + +-- | Vector of center costs. +centerCosts :: Instance -> Vector Cost +centerCosts = _f + +centerCapacity :: Instance -> CenterId -> Int +centerCapacity Instance{..} = (_k !) + +centerCapacities :: Instance -> Vector Int +centerCapacities = _k + +officeDatas :: Instance -> Vector Int +officeDatas = _d + +-- | Needed storage of an office. +officeData :: Instance -> OfficeId -> Int +officeData Instance{..} = (_d !) + +-- | Number of offices. +numOffices :: Instance -> Int +numOffices Instance{..} = _nO + +-- | Number of centers. +numCenters :: Instance -> Int +numCenters Instance{..} = _nC + +-- | Number of segments +numSegments :: Instance -> Int +numSegments Instance{..} = _nP + +-- | Cost of a segment. +segmentCost :: Instance -> SegmentId -> Int +segmentCost Instance{..} = (_s !) + +segmentCosts :: Instance -> Vector Int +segmentCosts = _s + +-- | Threshold of a segment. +segmentThreshold :: Instance -> SegmentId -> Int +segmentThreshold Instance{..} = (_m !) + +segmentThresholds :: Instance -> Vector Int +segmentThresholds = _m + +-- | List of all allowed connections. +calcAllowedConnections :: Instance -> [(CenterId, OfficeId)] +calcAllowedConnections i = [ (c, o) | c <- centers i, o <- offices i + , isAllowed i c o ] + +mkInstance :: [Assig] -> Instance +mkInstance as = let parsed = foldl' f emptyInstance as + in parsed {_us = calcAllowedConnections parsed} + where + f i (Assig "r" (Num x)) = i {_r = x} + f i (Assig "NO" (Num x)) = i {_nO = x} + f i (Assig "NC" (Num x)) = i {_nC = x} + f i (Assig "NP" (Num x)) = i {_nP = x} + f i (Assig "d" xs) = i {_d = fromList $ flatten xs} + f i (Assig "k" xs) = i {_k = fromList $ flatten xs} + f i (Assig "f" xs) = i {_f = fromList $ flatten xs} + f i (Assig "s" xs) = i {_s = fromList $ flatten xs} + f i (Assig "u" xs) = i {_u = fromList $ map toEnum $ flatten xs} + f i (Assig "m" xs) = i {_m = fromList $ flatten xs} + f i _ = i + + +-- | Creates and 'Instance' from a @.dat@ file. +fromFile :: FilePath -> IO (Either ParseError Instance) +fromFile path = right mkInstance <$> parseFromFile pdat path + +-- | Shows an 'Instance' in @.dat@ format. +toDat :: Instance -> String +toDat Instance{..} = unlines [ + assigInt "r" _r + , assigInt "NO" _nO + , assigInt "NP" _nP + , assigInt "NC" _nC + , assigVector "d" _d + , assigVector "k" _k + , assigVector "f" _f + , assigVector "m" _m + , assigVector "s" _s + , assigVector2 "u" (V.map fromEnum _u) _nO + ] + where + showAssig name val = name ++ " = " ++ val ++ ";" + assigInt name x = showAssig name (show x) + assigVector name v = showAssig name (noCommas $ show v) + assigVector2 name v2 numCols = + showAssig name (noCommas $ show (chunksOf numCols (V.toList v2))) + noCommas = map (\case ',' -> ' '; x -> x) + +-- | Exports an 'Instance' to a @.dat@ file. +toFile :: FilePath -> Instance -> IO () +toFile p = writeFile p . toDat diff --git a/src/AM3/Main.hs b/src/AM3/Main.hs new file mode 100644 --- /dev/null +++ b/src/AM3/Main.hs @@ -0,0 +1,18 @@ +module AM3.Main (main) where + +import AM3.Instance +import AM3.RandomInstance +import AM3.Scripts +import AM3.Solution +import AM3.Solver +import GRASP +import System.Environment +import System.FilePath +import Text.Megaparsec (ParseError) + +main :: IO () +main = do + args <- getArgs + case args of + ["-g", seed, dat] -> runGrasp (read seed) False dat >>= putStr + _ -> putStrLn "nothing to do" diff --git a/src/AM3/RandomInstance.hs b/src/AM3/RandomInstance.hs new file mode 100644 --- /dev/null +++ b/src/AM3/RandomInstance.hs @@ -0,0 +1,135 @@ +-- | Module for generating random 'Instance's. + +module AM3.RandomInstance ( + -- * Random generator + randomInstance + , randomInstanceFile + -- * Parameters + , Params(..) + , Range + -- * Probability + , Probability + , fromDouble + -- * Auxiliary functions + , coin + ) where + +import AM3.Instance +import Control.Monad.Random +import Control.Monad (replicateM) +import Control.Monad.Trans + +-- | An inclusive range of 'Int's. +type Range = (Int, Int) + +-- | A real between 0 and 1. +newtype Probability = Prob Double + deriving (Eq, Num, Ord, Show) + +instance Fractional Probability where + fromRational = fromDouble . fromRational + (Prob a) / (Prob b) = Prob (a / b) + +-- | Creates a probability from a 'Double'. Error if not between 0 and 1. +fromDouble :: Double -> Probability +fromDouble p + | 0 <= p && p <= 1 = Prob p + | otherwise = error $ show p ++ " is not a probability" + +asDouble :: Probability -> Double +asDouble (Prob p) = p + +-- | Parameters for generating a random 'Instance'. +-- +-- Concrete values are picked uniformly at random within the defined 'Range's. +data Params = Params { + _NC :: Range -- ^ Number of entities (@nOffices + nCenters@). + , _oP :: Probability -- ^ Probability for an entity of being an office, as + -- opposed to being a center. In other words, proportion + -- @nOffices/nCenters@. + , _kR :: Range -- ^ Capacities range. + , _dR :: Range -- ^ Data range. + , _pR :: Range -- ^ Number of segments range. + , _fR :: Range -- ^ Fixed costs range. + , _cI :: Int -- ^ Positive 'Int'. Max cost increase added to a certain lower + -- bound. This lower bound ensures that the total cost is + -- monotonic with respect to the stored data. See the + -- documentation of 'randomInstance'. + , _uP :: Probability -- ^ Probability of allowed connection. + } deriving (Show) + + +-- | Flips a coin with probability of heads /p/. +coin :: MonadRandom m => Probability -> m Bool +coin (Prob p) = (< p) <$> getRandom + +-- | Generates a random 'Instance' from a set of parameters 'Params'. +-- +-- Ensures the cost of a center is monotonic with respect to the amount +-- of data stored in it. This can be expressed by the following inequation. +-- +-- * @M[i]@: threshold of segment @i@. +-- * @C[i]@: cost of segment @i@. +-- +-- @M[i]*C[i] > (M[i] - 1)*C[i-1]@. +-- +-- equivalent to: +-- +-- @C[i] > (C[i-1] * (1 + M[i])) \/ M[i]@. +-- +-- We add an additional random positive cost @I[i]@ to add randomness. +-- +-- * @I[i]@: random cost increase. In range of (1, '_cI'). +-- +-- Finally we define @C[i]@ as follows. +-- +-- @i = 0: C[i] = I[i]@. +-- +-- @i > 0: C[i] + I[i] = (C[i-1] * (1 + M[i])) \/ M[i]@. +randomInstance :: MonadRandom m => Params -> m Instance +randomInstance Params{..} = do + nEntities <- getRandomR _NC + nSegs <- getRandomR _pR + xs <- take nEntities <$> getRandoms + let nOffices = length (filter (< asDouble _oP) xs) + nCenters = nEntities - nOffices + allowdCons <- replicateM (nOffices*nCenters) (coin _uP) + fixedCosts <- take nCenters <$> getRandomRs _fR + datas <- take nOffices <$> getRandomRs _dR + caps <- take nCenters <$> getRandomRs _kR + spans <- take (nSegs - 1) <$> getRandomRs (incR nSegs) + let thresh = scanl (+) 0 spans + costs <- getCosts thresh + return (newInstance r datas caps fixedCosts costs thresh allowdCons) + where + r = 2 + getCosts ms = do + cost0 <- getRandomR (1, _cI) + step ms cost0 + where + step [] _ = return [] + step (m2:ms) c1 = do + c2 <- getRandomR (lb, lb + _cI) + cs <- step ms c2 + return (c2:cs) + where + lb = ceiling (((m + 1)*fromIntegral c1) / m) + m = fromIntegral m2 :: Double + expectedCap = let (a, b) = _kR in a + (a + b)`div`2 + incR segs = let x = expectedCap `div` segs + in (max 1 x, x) + +-- | Generates a random 'Instance' and exports it to a @.dat@ file. +-- +-- * Running the generation with a seed: +-- +-- @evalRandT (randomInstanceFile params path) (mkStdGen seed)@ +-- +-- * Running the generation without a seed (using the @IO monad@): +-- +-- @evalRandT (randomInstanceFile params path)@ +randomInstanceFile :: + Params -- ^ Parameters for the generation. + -> FilePath -- ^ Path of the @.dat@ file. + -> RandT StdGen IO () +randomInstanceFile p file = randomInstance p >>= lift . toFile file diff --git a/src/AM3/Regex.hs b/src/AM3/Regex.hs new file mode 100644 --- /dev/null +++ b/src/AM3/Regex.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE QuasiQuotes, FlexibleContexts #-} + +module AM3.Regex where + +import Text.Regex.PCRE.Heavy +import Safe +import Control.Monad + +f = readFile "/home/jan/Projects/am3-project/dat/runs/run4/test9.grasp" + +t = searchCost <$> f +q p m = fmap p . m + + +searchCost :: String -> Maybe Int +searchCost = (fmap read . headMay . snd <=< headMay) . scan [re|\s*cost: (\d+)|] diff --git a/src/AM3/Scripts.hs b/src/AM3/Scripts.hs new file mode 100644 --- /dev/null +++ b/src/AM3/Scripts.hs @@ -0,0 +1,115 @@ +-- | Contains some useful scripts for automating things. +-- +-- Some functions assume that are ran from the project root dir. +{-# LANGUAGE OverloadedStrings #-} +-- :set -XOverloadedStrings +module AM3.Scripts where + +import System.Process +import System.FilePath +import System.Directory +import Control.Monad.Random +import Control.Monad.Extra +import AM3.RandomInstance +import AM3.TestParams +import Control.Monad.Trans +import Numeric +import System.Clock + +-- process = proc + +-- -- | Runs oplrun in all the .dats in a directory +-- runOplDir dir = do +-- export "LD_LIBRARY_PATH" "$LD_LIBRARY_PATH:$HOME/Programs/cplex-studio126/opl/bin/x86-64_linux" +-- e <- need "LD_LIBRARY_PATH" +-- print e +-- process "oplrun" ["-version"] empty +-- shell "oplrun" empty + +getDirectoryContentsAbsolute :: FilePath -> IO [FilePath] +getDirectoryContentsAbsolute dir = + map (dir ) <$> getDirectoryContents dir + +getDats :: FilePath -> IO [FilePath] +getDats dir = filter isDat <$> getDirectoryContentsAbsolute dir + where isDat = (==".dat") . takeExtension + +appendFileName :: FilePath -> String -> FilePath +appendFileName file x = replaceBaseName file (takeBaseName file ++ x) + +rdd :: Int -> FilePath +rdd i = "dat" "runs" "run" ++ show i + +-- | Guarantees no overwrites. +withNum :: FilePath -> IO FilePath +withNum = go 0 + where + go n file = ifM (doesFileExist file') + (go (n + 1) file) (return file') + where file' + | n == 0 = file + | otherwise = appendFileName file ("-" ++ show n) + +-- | oplrun from the root dir. +runOpl :: String -> FilePath -> IO () +runOpl mod dat = do + out <- withNum (replaceExtension dat ".out") + readProcess "oplrun" [mod, dat] "" >>= writeFile out + +runStackGrasp :: Int -> FilePath -> IO () +runStackGrasp seed dat = do + out <- withNum (replaceExtension dat ".grasp") + timeReadProcess "time" ["stack", "exec", "grasp-exe", "--", "-g", show seed, dat] "" + >>= \(stdout, nanos) -> writeFile out (unlines [stdout, "time: " ++ show nanos]) + + +timeReadProcess :: String -> [String] -> String -> IO (String, Integer) +timeReadProcess cmd args stdin = do + t1 <- getTime Monotonic + r <- readProcess cmd args stdin + t2 <- getTime Monotonic + return (r, timeSpecAsNanoSecs $ diffTimeSpec t1 t2) + +timeSpecsAsSecs :: TimeSpec -> Double +timeSpecsAsSecs = (/1000) . fromInteger . (`div`(10^6)) . timeSpecAsNanoSecs + +-- | Creates many randomly generated test in a folder. +populateFolder :: Int -> Int -> Params -> FilePath -> IO () +populateFolder seed many params dir = flip evalRandT (mkStdGen seed) $ + do + info <- lift $ withNum (dir "info.txt") + lift $ writeFile info (unlines ["seed: " ++ show seed + , "many: " ++ show many + , show params]) + names <- lift $ mapM withNum [dir "test" ++ show n <.> ".dat" | n <- [1..many]] + forM_ names (randomInstanceFile params) + + +-- | Runs oplrun in all the .dat files in a directory. +runOplDir :: FilePath -> IO () +runOplDir dir = do + dats <- getDats dir >>= mapM makeAbsolute + print dats + forM_ dats (runOpl "dat/oplP.mod") + +runGraspDir :: Int -> FilePath -> IO () +runGraspDir seed dir = do + dats <- getDats dir >>= mapM makeAbsolute + print dats + forM_ dats (\d -> print d >> runStackGrasp seed d) + + +-- renaming :: IO () +-- renaming = +-- getDirectoryContentsAbsolute "dat/runs/run2" >>= mapM_ rename +-- where +-- rename x +-- | takeExtension x == ".dat" || takeExtension x == ".out" = +-- let old = takeBaseName x +-- new = replaceBaseName x ("test" ++ (reverse . drop k .reverse . drop 5) old) +-- in print (x, new) >> renameFile x new +-- | otherwise = return () +-- where +-- k +-- | takeExtension x == ".dat" = 2 +-- | otherwise = 4 diff --git a/src/AM3/Solution.hs b/src/AM3/Solution.hs new file mode 100644 --- /dev/null +++ b/src/AM3/Solution.hs @@ -0,0 +1,235 @@ +-- | This module implements a data type for constructing a new 'Solution'. + +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +module AM3.Solution ( + -- * Types + Solution + , Candidate + -- * Construction + , empty + -- * Queries + , cost + , connections + , correct + -- * Other Queries + , spaceLeft + , dataLeft + , connection + -- * Modifiers + , updateCon + , insertCon + -- * GRASP parameters + , gparams + -- * GRASP modifiers + , appendCand + -- * GRASP queries + , neighborhood + , candidates + ) where + +import AM3.Instance +import Control.Arrow +import Control.Lens +import Control.Monad.Random +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H +import Data.HashSet (HashSet) +import qualified Data.HashSet as S +import Data.Hashable +import qualified Data.List as L +import Data.Maybe +import Data.Vector.Unboxed (findIndex, unsafeFreeze, (!)) +import Debug.Trace +import GRASP +import System.Random.Shuffle + +-- | Represents a solution to an 'Instance' of the problem. +data Solution = Solution { + _inst :: Instance -- ^ Instance. + , _distr :: HashMap (CenterId, OfficeId) Int -- ^ amount of data per connection. + , _conns :: HashMap OfficeId (HashSet CenterId) -- ^ list of connected centers per office. + , _oUsage :: HashMap OfficeId Int -- ^ data stored per office. + , _cUsage :: HashMap CenterId Int -- ^ storage usage per center. + } deriving (Show, Read) +makeLenses ''Solution + +-- | A candidate that can be added to a 'Solution'. +type Candidate = Connection + +-- | Connection between center and office of a certain amount. +type Connection = (CenterId, OfficeId, Int) + + +centerTotalCost :: Instance + -> CenterId -- ^ Id of the center. + -> Int -- ^ Amount of data. + -> Cost -- ^ total cost. +centerTotalCost _ _ 0 = 0 +centerTotalCost i c k = centerCost i c + case findIndex (<=k) (segmentThresholds i) of + Nothing -> error "no suitable segment exists" + Just six -> k * segmentCost i six + +-- | Tells if an office has some data stored in a center. +existsCon :: Solution -> CenterId -> OfficeId -> Bool +existsCon s c o = fromMaybe False (S.member o <$> H.lookup c (s ^. conns)) + +-- | List of 'Connection's in a 'Solution'. +connections :: Solution -> [Connection] +connections s = [ (c, o, k) | ((c, o), k) <- H.toList (s ^. distr)] + +-- | Returns how much data from some office is assigned to a center. +connection :: Solution -> CenterId -> OfficeId -> Int +connection s c o = fromMaybe 0 (H.lookup (c, o) (s ^. distr)) + +-- | Strict sum +sum' :: [Cost] -> Cost +sum' = L.foldl' (+) 0 + +-- | Computes the total cost of a solution. +cost :: Solution -> Cost +cost sol = (sum' . map (uncurry $ centerTotalCost i)) $ H.toList (sol ^. cUsage) + where + i = sol ^. inst + +-- | Creates an empty 'Solution'. +empty :: Instance -> Solution +empty insta = Solution + { _inst = insta + , _distr = H.empty + , _cUsage = H.empty + , _oUsage = H.empty + , _conns = H.fromList [ (o, S.empty) | o <- offices insta ] + } + +-- | Returns (old, new, updatedMap) +update :: (Eq k, Hashable k) => + k -- ^ key. + -> (Maybe a -> Maybe a) -- ^ update function. + -> HashMap k a -- ^ The hashmap. + -> (Maybe a, Maybe a, HashMap k a) -- ^ (old, new, updatedMap). +update k f hm = + case f old of + Nothing -> (old, Nothing, H.delete k hm) + Just new -> (old, Just new, H.insert k new hm) + where + old = H.lookup k hm + +addUsage :: CenterId -> OfficeId -> Int -> Solution -> Solution +addUsage c o k = over oUsage (H.insertWith (+) o k) . over cUsage (H.insertWith (+) c k) + +assertConnExists :: CenterId -> OfficeId -> Bool -> Solution -> Solution +assertConnExists c o exists = over conns (H.adjust (fun c) o) + where fun | exists = S.insert + | otherwise = S.delete + +-- | Returns True if the solution satisfies all the restrictions. +-- +-- At the moment only checks if every office has stored its data. +correct :: Solution -> Bool +correct s = all ((== 0) . dataLeft s) (offices (s ^. inst)) + +-- | Updates a connection if present. +updateCon :: CenterId -> OfficeId -> (Maybe Int -> Int) -> Solution -> Solution +updateCon c o upd s = + let (mold, mnew, hm') = update (c, o) f (s ^. distr) + diff = new - old + old = fromMaybe 0 mold + new = fromMaybe 0 mnew + s1 + | diff == 0 = s + | otherwise = addUsage c o diff s + s2 + | old == 0 && new > 0 = assertConnExists c o True s1 + | old > 0 && new == 0 = assertConnExists c o False s1 + | otherwise = s1 + in set distr hm' s2 + where + f x + | updx == 0 = Nothing + | otherwise = Just updx + where updx = upd x + +-- | Inserts a new connection. +insertCon :: Solution -> CenterId -> OfficeId -> Int -> Solution +insertCon s c o v = assertConnExists c o True $ addUsage c o v $ over distr (H.insert (c, o) v) s + +-- | Appends a 'Candidate' to the 'Solution'. Assumes that the center and the +-- office are not already connected. +appendCand :: Solution -> Candidate -> Solution +appendCand s (c, o, v) = insertCon s c o v + +-- | Space left in a center. +spaceLeft :: Solution -> CenterId -> Int +spaceLeft s c = centerCapacity (s ^. inst) c - centerUsage s c + +-- | Data left in an office. Replications are taken into account. +dataLeft :: Solution -> OfficeId -> Int +dataLeft s o = replications (s ^. inst) * officeData (s ^. inst) o - officeUsage s o + +-- | Generates in a random order the list of neighbors. +-- +-- Neighbors are generated as follows: +-- +-- * Move as many data as possible from an office in one center to another center. +-- +-- * Interchange two offices from two centers. +-- @(c1, o1, d1) (c2, o2, d2) --> (c1, o2, d2) (c2, o1, d1)@ +neighborhood :: MonadRandom m => Solution -> m [Solution] +neighborhood s = do + rcon <- shuffleM (connections s) + return [ moveData c1 c2 o s | (c1, o, _) <- rcon, c2 <- centers (s ^. inst)] + where + -- | Moves as many data as possible from o in c1 to c2. + moveData :: CenterId -> CenterId -> OfficeId -> Solution -> Solution + moveData c1 c2 o s = (updateCon c1 o (\x -> fromMaybe 0 x - much) + >>> updateCon c2 o (\x -> fromMaybe 0 x + much)) s + where + much = min (spaceLeft s c2) (connection s c1 o) + swapData c1 o1 c2 o2 = undefined + +-- | How much data is stored in a center. +centerUsage :: Solution -> CenterId -> Int +centerUsage s c = fromMaybe 0 (H.lookup c (s ^. cUsage)) + +-- | How much data from an office is already stored. +officeUsage :: Solution -> OfficeId -> Int +officeUsage s o = fromMaybe 0 (H.lookup o (s ^. oUsage)) + +-- | Generates the list of candidates and their estimated cost. +-- +-- Candidates are generated as follows: +-- +-- * All data from an office is stored in a center. +-- * All remaining space from a center is occupied with some data from an office. +candidates :: Solution -> [(Candidate, Cost)] +candidates sol = mapMaybe (uncurry mkCandidate) (allowedConnections i) + where + i = view inst sol + mkCandidate c o + | add == 0 = Nothing + | add > 0 && not (existsCon sol c o) = + let addCost = centerTotalCost i c (cx + add) - centerTotalCost i c cx + in Just ((c, o, add), addCost) + | otherwise = Nothing + where + cx = centerUsage sol c + add = minimum [officeData i o, spaceLeft sol c, dataLeft sol o] + +-- | Creates the parameters 'GParams' for 'grasp' specifics for this problem. +gparams :: MonadRandom m => + Int -- ^ Maximum number of iterations. + -> Maybe Int -- ^ Optional maximum number of candidates. + -> Double -- ^ Alpha. + -> Instance -- ^ Problem instance. + -> GParams Solution Candidate m +gparams maxi maxCand alph inst = GParams { + alpha = alph + , maxitr = maxi + , costf = return . cost + , correctf = return . correct + , start = return (empty inst) + , append = \s -> return . appendCand s + , genCandidates = \s -> let c = candidates s in return $ maybe id take maxCand c + , neighbors = neighborhood +} diff --git a/src/AM3/Solver.hs b/src/AM3/Solver.hs new file mode 100644 --- /dev/null +++ b/src/AM3/Solver.hs @@ -0,0 +1,39 @@ +-- | This module implements convenience functions for solving 'Instance's using +-- 'grasp' + +module AM3.Solver ( + runGrasp + ) where + + +import AM3.Solution +import AM3.Instance +import GRASP +import Text.Megaparsec (ParseError) +import Control.Monad.Identity +import Control.Monad.Random + +-- | Runs the grasp on a file. +runGrasp :: Int -> Bool -> FilePath -> IO String +runGrasp seed printSol dat = do + par <- fromFile dat :: IO (Either ParseError Instance) + case par of + (Left e) -> return (show e) + (Right i) -> + let + gp :: MonadRandom m => GParams Solution Candidate m + gp = gparams maxit maxCand alph i + res = case flip evalRand (mkStdGen seed) $ flip evalRandT (mkStdGen seed) (grasp gp) of + Nothing -> "no solution" + Just (sol, cost) -> unlines (["cost: " ++ show cost] + ++ ["solution: " ++ show (connections sol) | printSol]) + info = unlines ["seed = " ++ show seed + , "alpha = " ++ show alph + , "maxitr = " ++ show maxit + , "maxCand = " ++ show maxCand] + in return (unlines [info, res]) + where + alph = 0.5 + maxCand = Just 3000 + maxit = 10 + diff --git a/src/AM3/TestParams.hs b/src/AM3/TestParams.hs new file mode 100644 --- /dev/null +++ b/src/AM3/TestParams.hs @@ -0,0 +1,97 @@ +-- | Definitions of some parameters 'Params' for the random generator of 'Instance's. +-- +-- See function 'randomInstance'. +module AM3.TestParams where + +import AM3.RandomInstance +import AM3.Instance -- imported for the haddock link. +import Control.Monad.Random + + +-- | ('Params', seed). +type Concrete = (Params, Int) + +micro :: Params +micro = Params { + _oP = 0.5 + , _NC = (8, 12) + , _kR = (5, 10) + , _dR = (2, 6) + , _pR = (2, 3) + , _fR = (2, 2) + , _cI = 5 + , _uP = 0.7 + } + +small :: Params +small = Params { + _oP = 0.6 + , _NC = (80,120) + , _kR = (80, 150) + , _dR = (25,60) + , _pR = (5,7) + , _fR = (100, 200) + , _uP = 0.8 + , _cI = 10 + } + +-- 10 secs +medium0 :: Concrete +medium0 = (medium, 0) + +-- 134 secs +medium12 :: Concrete +medium12 = (medium, 12) + +medium :: Params +medium = Params { + _oP = 0.6 + , _NC = (550,550) + , _kR = (80, 190) + , _dR = (25,60) + , _pR = (15,15) + , _fR = (100, 200) + , _uP = 0.8 + , _cI = 10 + } + +-- 1550.66 secs +-- cost: 872616 +big0 :: Concrete +big0 = (big, 0) + +big :: Params +big = Params { + _oP = 0.62 + , _NC = (700,700) + , _kR = (180, 390) + , _dR = (25,160) + , _pR = (15,15) + , _fR = (1000, 2000) + , _uP = 0.8 + , _cI = 8 + } + +big2 :: Params +big2 = Params { + _oP = 0.60 + , _NC = (800,800) + , _kR = (175, 380) + , _dR = (25,160) + , _pR = (15,25) + , _fR = (100, 200) + , _uP = 0.8 + , _cI = 5 + } + +large :: Params +large = Params { + _oP = 0.60 + , _NC = (900,1100) + , _kR = (190, 390) + , _dR = (25,160) + , _pR = (15,15) + , _fR = (100, 200) + , _uP = 0.8 + , _cI = 10 + } diff --git a/src/GRASP.hs b/src/GRASP.hs new file mode 100644 --- /dev/null +++ b/src/GRASP.hs @@ -0,0 +1,122 @@ +-- | Higher order GRASP algorithm. +module GRASP ( + -- * Types + Cost + , GParams (..) + -- * GRASP + , grasp + , graspM + -- * Auxiliar functions + , constructM + , localM + ) where + +import Control.Monad.Extra +import Control.Monad.Identity +import Control.Monad.Random +import Control.Monad.Trans +import Data.Foldable +import Data.Maybe +import Data.Ord +import Debug.Trace + +-- | Cost of something. +type Cost = Int + + +-- | All the parameters that define a problem susceptible to be solved using a GRASP algorithm. +data GParams sol cand m = GParams { + alpha :: Double -- ^ Alpha. Used to define the Restricted Candidate List (RCL). + , maxitr :: Int -- ^ Iterations. + , costf :: sol -> m Cost -- ^ Cost function. + , correctf :: sol -> m Bool -- ^ Verification function. + , start :: m sol -- ^ Empty solution. + , append :: sol -> cand -> m sol -- ^ Function to append a candidate to the solution. + , genCandidates :: sol -> m [(cand, Cost)] -- ^ Generator of candidates paired with their + -- greedily estimated cost increase. + , neighbors :: sol -> m [sol] -- ^ Neighborhood generator. +} + +-- | Higher order implementation of a Greedy Randomized Adaptive Search Procedure. +grasp :: Monad m => GParams sol cand m -> RandT StdGen m (Maybe (sol, Cost)) -- ^ Returns best solution found with its associated cost. +grasp GParams{..} = + graspM alpha maxitr costf correctf start append genCandidates neighbors + + +-- | Monadic version of 'grasp'. +graspM :: + Monad m => Double -- ^ Alpha. Used to define the Restricted Candidate List (RCL). + -> Int -- ^ Iterations. + -> (sol -> m Cost) -- ^ Cost function. + -> (sol -> m Bool) -- ^ Verification function. + -> m sol -- ^ Empty solution. + -> (sol -> cand -> m sol) -- ^ Function to append a candidate to the solution. + -> (sol -> m [(cand, Cost)]) -- ^ Generator of candidates paired with their + -- greedily estimated cost increase. + -> (sol -> m [sol]) -- ^ Neighborhood generator. + -> RandT StdGen m (Maybe (sol, Cost)) -- ^ Returns best solution found with its associated cost. +graspM alpha maxitr f correct start append genCandidates neighb = + step maxitr Nothing + where + step 0 best = return best + step it best = do + traceM $ "iteration " ++ show it + x <- constructM start append genCandidates alpha + >>= lift . (\s -> (s,) <$> f s) + cor <- lift $ correct (fst x) + if + | cor -> do + x1 <- trace ("Constructed: " ++ show (snd x)) $ localM f neighb x + step (it - 1) (keepBest best (Just x1)) + + | otherwise -> step (it - 1) Nothing + where + keepBest :: Maybe (sol, Cost) -> Maybe (sol, Cost) -> Maybe (sol, Cost) + keepBest a b + | null cm = Nothing + | otherwise = Just $ minimumBy (comparing snd) cm + where cm = catMaybes [a, b] + +-- | Construction of an starting solution. +constructM :: + Monad m + => m sol -- ^ Empty solution. + -> (sol -> cand -> m sol) -- ^ Function to append a candidate to the solution. + -> (sol -> m [(cand, Cost)]) -- ^ Generator of candidates paired with their + -- greedily estimated cost increase. + -> Double -- ^ Alpha. + -> RandT StdGen m sol -- ^ Generated solution. +constructM start append genCandidates alpha = lift start >>= step + where + step solution = do + candidates <- lift $ genCandidates solution + if + | null candidates -> return solution + | otherwise -> do + let smin = (minimum . map snd) candidates + smax = (maximum . map snd) candidates + rcl = [ c | (c, gc') <- candidates + , gc' <= smin + floor (alpha*fromIntegral (smax - smin))] + uniform rcl >>= lift . append solution >>= step + + +-- | Local search. +localM :: + Monad m + => (sol -> m Cost) -- ^ Cost function. + -> (sol -> m [sol]) -- ^ Neighborhood generator. + -> (sol, Cost) -- ^ Starting solution paired with its cost. + -> RandT StdGen m (sol, Cost) +localM cost neighb sol@(best, costbest) = do + h <- lift $ neighb best + >>= mapMaybeM processNeighb + if + | null h -> return sol + | otherwise -> trace ("localM: " ++ show costbest) $ do + let w = head h + localM cost neighb w + where processNeighb n = do + costn <- cost n + return $ if + | costn < costbest -> Just (n, costn) + | otherwise -> Nothing diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,32 @@ +# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-4.0 + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 1.0.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"