packages feed

grasp (empty) → 0.1.0.0

raw patch · 16 files changed

+1241/−0 lines, 16 filesdep +MonadRandomdep +basedep +clocksetup-changed

Dependencies added: MonadRandom, base, clock, directory, extra, filepath, grasp, hashable, lens, megaparsec, mtl, pcre-heavy, primitive, process, random-shuffle, safe, split, system-filepath, text, transformers, turtle, unordered-containers, vector

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import qualified AM3.Main as A++main :: IO ()+main = A.main
+ grasp.cabal view
@@ -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
+ src/AM3/DatParser.hs view
@@ -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
+ src/AM3/Instance.hs view
@@ -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
+ src/AM3/Main.hs view
@@ -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"
+ src/AM3/RandomInstance.hs view
@@ -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
+ src/AM3/Regex.hs view
@@ -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+)|]
+ src/AM3/Scripts.hs view
@@ -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
+ src/AM3/Solution.hs view
@@ -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+}
+ src/AM3/Solver.hs view
@@ -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+
+ src/AM3/TestParams.hs view
@@ -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+  }
+ src/GRASP.hs view
@@ -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
+ stack.yaml view
@@ -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]
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"