diff --git a/icfp2015.cabal b/icfp2015.cabal index 734a37d..175bb83 100644 --- a/icfp2015.cabal +++ b/icfp2015.cabal @@ -51,7 +51,7 @@ cabal-version: >=1.10 executable icfp2015 -- .hs or .lhs file containing the Main module. - main-is: Main0.hs + main-is: Main.hs -- Modules included in this executable, other than Main. other-modules: Datatypes, Datatypes.Board, Datatypes.Cell, Datatypes.Game, Datatypes.Unit @@ -60,7 +60,7 @@ executable icfp2015 other-extensions: OverloadedStrings, DeriveGeneric, DeriveDataTypeable -- Other library packages from which modules are imported. - build-depends: base >=4.6 && <4.9, hashable >=1.2 && <1.3, containers >=0.5 && <0.6, QuickCheck >=2.7 && <2.9, bytestring >=0.10 && <0.11, aeson >=0.8 && <0.9, pqueue >=1.3 && <1.4, clock >= 0.1 + build-depends: base >=4.6 && <4.9, hashable >=1.2 && <1.3, containers >=0.5 && <0.6, QuickCheck >=2.7 && <2.9, bytestring >=0.10 && <0.11, aeson >=0.8 && <0.9, pqueue >=1.3 && <1.4, clock, random, deepseq >= 1.3 && <1.4 -- Directories containing source files. hs-source-dirs: src diff --git a/src/JSONDeser.hs b/src/JSONDeser.hs index b85fded..8ffff2b 100644 --- a/src/JSONDeser.hs +++ b/src/JSONDeser.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} module JSONDeser where -import qualified Data.Set as Set +import Data.Set(fromList) import Data.Maybe import qualified Data.ByteString.Lazy as BS import Data.Aeson @@ -52,10 +52,10 @@ newGame :: Input -> (Int,[(Int,DT.Game)]) newGame input = (JSONDeser.id input, zip (sourceSeeds input) (map gameFromSeed (sourceSeeds input))) where gameFromSeed seed = DT.Game.new board (seedUnits seed input) - board = DT.Board w h filledel + board = DT.Board w h filledelement w = width input h = height input - filledel = Set.fromList (map cellConvVM (filled input)) + filledelement = fromList (map cellConvVM (filled input)) seedUnits :: Int -> Input -> [DT.Unit] seedUnits s input = map (\x -> uinput !! x ) unit_index @@ -69,5 +69,5 @@ cellConvVM (Cell x y) = (x,y) unitConvVM :: Unit -> DT.Unit unitConvVM unit = DT.Unit (cellConvVM (pivot unit)) setcell where - setcell = Set.fromList (map cellConvVM (members unit)) + setcell = fromList (map cellConvVM (members unit)) diff --git a/src/LCG.hs b/src/LCG.hs index 98a413d..ea005dc 100644 --- a/src/LCG.hs +++ b/src/LCG.hs @@ -1,6 +1,6 @@ module LCG where -import Data.Bits +import Data.Bits(shiftR,(.&.)) modulus = 2^32 multiplier = 1103515245 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..0042480 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS -Wall #-} + +module Main where + +import Control.DeepSeq (deepseq, NFData(..)) +import Data.Int +import qualified Data.ByteString.Lazy.Char8 as BS +import System.Environment +import System.Random +import System.Clock +import GHC.Generics +import Data.Aeson +import Data.Maybe + +import StrategyManager +import Strategy0 +import Datatypes.Game(Game,Command) +import VM +import Opt +import JSONDeser(readInput) +import PowerPhrases + +strategyTag :: String +strategyTag = "lilik0" + +logFileName :: String +logFileName = "scores" + +timeLimitRatio :: Double +timeLimitRatio = 0.96 + +memLimitRatio :: Double +memLimitRatio = 1.0 + +computationsPerStep :: Int +computationsPerStep = 10 + + +data JSONSer = JSONSer { problemId :: Int, + problemSeed :: Int, + problemTag :: String, + problemSolution :: String + } deriving (Show, Generic) + +instance FromJSON JSONSer +instance ToJSON JSONSer + +type Id = Int +type Seed = Int + + +strategies :: Game -> StdGen -> Maybe [Command] -> GameComputation +strategies g sgen cmd = [MkStrategyWrapper (initst g sgen cmd :: Strategy0)] + +-- = [MkStrategyWrapper (initst g sgen cmd :: NullStrategy1), +-- MkStrategyWrapper (initst g sgen cmd :: NullStrategy2)] + +-- example :: +-- = [MkStrategyWrapper (init g sgen cmd :: Strat0), +-- MkStrategyWrapper (init g sgen cmd :: Strat1), +-- MkStrategyWrapper (init g sgen cmd :: Strat2)] + +main :: IO () +main = do initTime <- secTime + args <- getArgs + opt <- parseArgs args + let files = optFile opt + let maxTime = optTime opt + let maxMem = optMem opt + let powerPhrase = optPowerPhrase opt + let logFile = optLog opt + rng <- getStdGen + initialData <- createComputationsFromFiles files rng powerPhrase + let (_, _,gameComputations) = unzip3 initialData + commandResults <- iterateGame gameComputations (timeStruct maxTime initTime) maxMem + let stringResults = map (\(cmds,score,algoIdx) -> (cmdToString cmds,score,algoIdx)) commandResults + let outJSONstructs = zipWith jsonBuilder initialData stringResults + BS.putStrLn $ encode outJSONstructs + writeLogFile logFile (zipWith logFileBuilder initialData stringResults) + where + timeStruct Nothing _ = Nothing + timeStruct (Just stopTime) initialTime = Just (fromIntegral stopTime,fromIntegral initialTime) + + + + jsonBuilder (idx, seed, _) (strCmds, _, _) = (JSONSer idx seed strategyTag strCmds) + logFileBuilder (idx, seed, _) (_ ,score , algoIdx) = (idx, seed, score, algoIdx) + +createComputationsFromFiles :: [String] -> StdGen -> Maybe String -> IO [(Id,Seed,GameComputation)] +createComputationsFromFiles fileNames randomGen powerPhrase = do inputs <- readFiles fileNames + let igames = map readInput inputs + let cstruct = compstruct igames + return (gcstruct cstruct) + where + compstruct ig = concat (map genf ig) + genf (i,g) = zipWith (\x (y,z) -> (x,y,z)) (replicate (length g) i) g + gcstruct cst = map (\(x,y,z) -> (x,y,j z)) cst + where + j game = strategies game randomGen (powerCommands powerPhrase) + powerCommands Nothing = Nothing + powerCommands (Just a) = Just (mapMaybe charToCommand a) + +readFiles :: [String] -> IO [BS.ByteString] +readFiles [] = return [] +readFiles (x:xs) = do f <- BS.readFile x + fs <- readFiles xs + return (f:fs) + +instance NFData Command where rnf x = seq x () + +iterateGame :: [GameComputation] -> Maybe (Double,Double) -> Maybe Int -> IO [FinishedGame] +iterateGame gameComputations timeLimitData memLimitData = do alive <- checkComputationAlive + if alive + then nextPass + else return bestGames + where + nextPass = (bestGames `deepseq` (iterateGame nextGameComputations timeLimitData memLimitData)) + nextGameComputations = (applyNtimes computationsPerStep advanceGameComputations gameComputations) + checkComputationAlive = do timeLimitFlag <- timeLimit timeLimitData + memLimitFlag <- memLimit memLimitData + let finishedComputation = (and $ map finishedGameComputation gameComputations) + return $ not (timeLimitFlag || memLimitFlag || finishedComputation) + advanceGameComputations computations = map advanceGameComputation computations + bestGames = map getBestGameComputation gameComputations + +timeLimit :: Maybe (Double, Double) -> IO Bool +timeLimit Nothing = return False +timeLimit (Just (initialTime,stopTime)) = do actualTime <- secTime + let actualTimeD = fromIntegral actualTime + let timeDifference = (actualTimeD - initialTime) + return (stopTime <= timeDifference) + +memLimit :: Maybe Int -> IO Bool +memLimit _ = return False + +secTime :: IO Int64 +secTime = do (TimeSpec s _) <- getTime Monotonic + return s + +writeLogFile :: Bool -> [(Int,Int,Int,Int)] -> IO () +writeLogFile False _ = return () +writeLogFile _ els = writeFile logFileName scoredata + where + scoredata = foldl strlog "\n" els + strlog x (a,b,c,d) = sa ++ sb ++ sc ++ sd ++ x ++ "\n\n" + where + sa = (show a) ++ " " + sb = (show b) ++ " " + sc = (show c) ++ " " + sd = (show d) ++ " " + +applyNtimes :: Int -> (a -> a) -> a -> a +applyNtimes 0 _ accum = accum +applyNtimes n f accum = applyNtimes (n - 1) f (f accum) + diff --git a/src/Mainpf.hs b/src/Mainpf.hs deleted file mode 100644 index 6b707c9..0000000 --- a/src/Mainpf.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS -Wall #-} - -module Mainf where - -import Data.Int -import Data.List -import qualified Data.ByteString.Lazy.Char8 as BS -import System.Environment -import System.Random -import System.Clock -import GHC.Generics -import Data.Aeson -import Data.Maybe - -import StrategyManager -import Datatypes -import Datatypes.Game -import VM -import Opt -import JSONDeser(readInput) -import PowerPhrases - -ptag :: String -ptag = "lilik0" -logfilename :: String -logfilename = "scores" - -timelimitratio :: Double -timelimitratio = 0.9 -memlimitratio :: Double -memlimitratio = 0.9 -gccompperstep :: Integer -gccompperstep = 10 - - -data JSONSer = JSONSer { problemId :: Int, - seed :: Int, - tag :: String, - solution :: String - } deriving (Show, Generic) - -instance FromJSON JSONSer -instance ToJSON JSONSer - -type Id = Int -type Seed = Int - -strategies :: Game -> StdGen -> Maybe [Command] -> GameComputation -strategies g sgen cmd = [MkStrategyWrapper (initst g sgen cmd :: NullStrategy1), - MkStrategyWrapper (initst g sgen cmd :: NullStrategy2)] - --- example :: --- = [MkStrategyWrapper (init g sgen cmd :: Strat0), --- MkStrategyWrapper (init g sgen cmd :: Strat1), --- MkStrategyWrapper (init g sgen cmd :: Strat2)] - -main :: IO () -main = do args <- getArgs - opt <- parseArgs args - let files = optFile opt - let timelimit = optTime opt - let memlimit = optMem opt - let powerp = optPowerPhrase opt - let cores = optCores opt - let logf = optLog opt - rng <- getStdGen - loaddata <- createComputationsFromFiles files rng powerp - let (ids,seeds,gamecomputations) = unzip3 loaddata - inittime <- secTime - results <- iterategc gamecomputations (timestruct timelimit inittime) memlimit - let (commandswpoints,strat) = unzip results - let (commandlists, points) = unzip commandswpoints - let wordlists = map cmdToString commandlists - let outJSONstructs = zipWith3 (\x y z -> (JSONSer x y ptag z)) ids seeds wordlists - BS.putStrLn $ encode outJSONstructs - writelogfile logf (zip4 ids seeds points strat) - where - timestruct Nothing _ = Nothing - timestruct (Just maxtime) intime = Just (maxtime, intime) - -createComputationsFromFiles :: [String] -> StdGen -> Maybe String -> IO [(Id,Seed,GameComputation)] -createComputationsFromFiles fns sg pp = do inputs <- readFiles fns - let igames = map readInput inputs - let cstruct = compstruct igames - return (gcstruct cstruct) - where - compstruct ig = concat (map genf ig) - genf (i,g) = zipWith (\x (y,z) -> (x,y,z)) (replicate (length g) i) g - gcstruct cst = map (\(x,y,z) -> (x,y,j z))cst - where - j z = strategies z sg (ppascommands pp) - ppascommands Nothing = Nothing - ppascommands (Just a) = Just (mapMaybe charToCommand a) - -readFiles :: [String] -> IO [BS.ByteString] -readFiles [] = return [] -readFiles (x:xs) = do f <- BS.readFile x - fs <- readFiles xs - return (f:fs) - -iterategc :: [GameComputation] -> Maybe (Int,Int64) -> Maybe Int -> IO [(([Command], Int), Int)] -iterategc gcs tlimit mlimit = do rtl <- timeLimit tlimit - rml <- memLimit mlimit - (gcresult rtl rml) - where - gcresult True _ = return best - gcresult _ True = return best - gcresult _ _ = if (and $ map finishedGameComputation gcs) - then return best - else iterategc (applyNtimes gccompperstep itf gcs) tlimit mlimit - where - itf gcs1 = map (\x -> advanceGameComputation x) gcs1 - applyNtimes 1 f x = f x - applyNtimes n f x = f (applyNtimes (n-1) f x) - best = map getBestGameComputation gcs - - -timeLimit :: Maybe (Int,Int64) -> IO Bool -timeLimit Nothing = return False -timeLimit (Just (itime,limit)) = do atime <- secTime - let diff = (atime - (fromIntegral itime)) - return (((fromIntegral limit) * timelimitratio) < (fromIntegral diff)) - - -memLimit :: Maybe Int -> IO Bool -memLimit _ = return False - -secTime :: IO Int64 -secTime = do (TimeSpec s _) <- getTime Monotonic - return s - -writelogfile :: Bool -> [(Int,Int,Int,Int)] -> IO () -writelogfile False _ = return () -writelogfile _ els = writeFile logfilename scoredata - where - scoredata = foldl strlog "\n" els - strlog x (a,b,c,d) = sa ++ sb ++ sc ++ sd ++ x ++ "\n" - where - sa = (show a) ++ " " - sb = (show b) ++ " " - sc = (show c) ++ " " - sd = (show d) ++ " " diff --git a/src/PowerPhrases.hs b/src/PowerPhrases.hs index 94ac0d7..6c59930 100644 --- a/src/PowerPhrases.hs +++ b/src/PowerPhrases.hs @@ -1,8 +1,11 @@ +{-# OPTIONS -Wall #-} module PowerPhrases where -import Data.Maybe +import Data.Maybe(mapMaybe) import Datatypes.Game (Command(..)) +listToCommand :: String -> [Command] +listToCommand str = mapMaybe charToCommand str charToCommand :: Char -> Maybe Command @@ -48,8 +51,5 @@ charToCommand 'u' = Just RotateCounterclockwise charToCommand 'w' = Just RotateCounterclockwise charToCommand 'x' = Just RotateCounterclockwise -charToCommand '\t' = Nothing -charToCommand '\n' = Nothing -charToCommand '\r' = Nothing - +charToCommand _ = Nothing diff --git a/src/Strategy0.hs b/src/Strategy0.hs index c7e3a7d..e52dde4 100644 --- a/src/Strategy0.hs +++ b/src/Strategy0.hs @@ -1,37 +1,65 @@ -module Strategy0 where +module Strategy0(Strategy0) where import qualified Data.PQueue.Prio.Max as PQ +import System.Random(StdGen) import Data.Maybe (isJust) - import Datatypes import Datatypes.Game (Command(..)) import qualified Datatypes.Unit as Unit import qualified Datatypes.Game as Game import VM +import StrategyManager + commandsList :: [Command] commandsList = [MoveSE, MoveSW, MoveW, MoveE, RotateClockwise, RotateCounterclockwise] type Queue = PQ.MaxPQueue (Int, Int, Int) Game +data Strategy0 = Strategy0 (Queue, [Game]) + + +instance Strategy Strategy0 where + initst = strategy0initst + advance = strategy0advance + getbest = strategy0getbest + +strategy0initst :: Game -> StdGen -> Maybe [Command] -> Strategy0 +strategy0initst game _ _ = (Strategy0 (firstQueue, firstList)) where + firstQueue = PQ.singleton (fullScore game, -(length $ Game.units game), snd . Unit.pivot . head . Game.units $ game) game + firstList = [] + +strategy0advance :: Strategy0 -> Either Strategy0 ([Command],Int) +strategy0advance (Strategy0 (queue,completed)) = + let candidates = (tryPowerPhrases game) ++ (map (step game) commandsList) + (newQueue, newCompleted) = updateCollections candidates remQueue (game:completed) + in Left (Strategy0 (newQueue, newCompleted)) + where + ((score, game), remQueue) = PQ.deleteFindMax queue + updateCollections [] q l = (q, l) + updateCollections ((g, n):rs) q l = case n of + OK -> updateCollections rs (pushToQueue q g) l + Lock _ -> updateCollections rs (pushToQueue q g) l + GameOver -> updateCollections rs q (pushToList l g) + _ -> updateCollections rs q l + pushToQueue q x = PQ.insert (fullScore x, -(length $ Game.units x), snd . Unit.pivot . head . Game.units $ x) x q + pushToList c x = x : c + +strategy0getbest :: Strategy0 -> ([Command], Int) +strategy0getbest (Strategy0 (incomplete,completed)) = + let (_, bestIncomplete) = PQ.findMax incomplete + resultGame = findListMax (bestIncomplete:completed) + in (reverse (Game.history resultGame), fullScore resultGame) fullScore :: Game -> Int fullScore game = Game.score game + (Game.powerCounterToScore $ Game.powerCounter game) -strat0 :: Game -> ([Command],Int) -strat0 game = let firstQueue = PQ.singleton (fullScore game, -(length $ Game.units game), snd . Unit.pivot . head . Game.units $ game) game - (incomplete, completed) = findBest maxIter firstQueue [] - (_, bestIncomplete) = PQ.findMax incomplete - resultGame = findListMax (bestIncomplete:completed) - in (reverse (Game.history resultGame), fullScore resultGame) - where - maxIter = 300000 - findListMax :: [Game] -> Game findListMax (x:xs) = innerFindListMax x xs where innerFindListMax currentMax [] = currentMax innerFindListMax currentMax (y:ys) = innerFindListMax (if (fullScore currentMax) > (fullScore y) then currentMax else y) ys + partition :: (a -> Bool) -> [a] -> ([a], [a]) partition p items = innerPartition items [] [] where innerPartition [] ts fs = (ts, fs) @@ -55,20 +83,3 @@ tryPowerPhrases game = validResults where OK -> innerExpand nn ps Lock _ -> innerExpand nn ps _ -> Nothing - -findBest :: Int -> Queue -> [Game] -> (Queue, [Game]) -findBest 0 queue completed = (queue, completed) -findBest i queue completed = - let candidates = (tryPowerPhrases game) ++ (map (step game) commandsList) - (newQueue, newCompleted) = updateCollections candidates remQueue (game:completed) - in findBest (i - 1) newQueue newCompleted - where - ((score, game), remQueue) = PQ.deleteFindMax queue - updateCollections [] q l = (q, l) - updateCollections ((g, n):rs) q l = case n of - OK -> updateCollections rs (pushToQueue q g) l - Lock _ -> updateCollections rs (pushToQueue q g) l - GameOver -> updateCollections rs q (pushToList l g) - _ -> updateCollections rs q l - pushToQueue q x = PQ.insert (fullScore x, -(length $ Game.units x), snd . Unit.pivot . head . Game.units $ x) x q - pushToList c x = x : c diff --git a/src/StrategyManager.hs b/src/StrategyManager.hs index c6b661a..cb8b3bb 100644 --- a/src/StrategyManager.hs +++ b/src/StrategyManager.hs @@ -2,32 +2,21 @@ {-# OPTIONS -Wall #-} module StrategyManager where -import System.Random - -import Datatypes -import Datatypes.Game +import System.Random(StdGen) +import Datatypes.Game(Game,Command) +type Score = Int +type StrategyIdx = Int +type FinishedGame = ([Command], Score, StrategyIdx) type GameComputation = [StrategyWrapper] + data StrategyWrapper = forall a . Strategy a => MkStrategyWrapper a | FinishedGame ([Command], Int) - + data NullStrategy1 = NullS1 -instance Strategy NullStrategy1 where - initst _ _ _ = NullS1 - advance _ = Left NullS1 - getbest _ = ([],0) - - -data NullStrategy2 = NullS2 - -instance Strategy NullStrategy2 where - initst _ _ _ = NullS2 - advance _ = Left NullS2 - getbest _ = ([],0) - initWrapper :: Strategy a => a -> StrategyWrapper @@ -41,9 +30,9 @@ class Strategy a where advanceWrapper :: StrategyWrapper -> StrategyWrapper advanceWrapper (FinishedGame result) = (FinishedGame result) -advanceWrapper (MkStrategyWrapper st) = wrapResult $ advance st +advanceWrapper (MkStrategyWrapper strategy) = wrapResult $ advance strategy where - wrapResult (Left nst) = MkStrategyWrapper nst + wrapResult (Left nextStrategy) = MkStrategyWrapper nextStrategy wrapResult (Right result) = FinishedGame result finishedWrapper :: StrategyWrapper -> Bool @@ -59,13 +48,31 @@ finishedGameComputation :: GameComputation -> Bool finishedGameComputation gc = and $ map finishedWrapper gc -- Ritorna i comandi con i punti piu l indice della strategia -getBestGameComputation :: GameComputation -> (([Command], Int),Int) -getBestGameComputation gc = foldl bestgame (([], 0), 0) (map getbestWrapper gc) +getBestGameComputation :: GameComputation -> FinishedGame +getBestGameComputation gameComputation = bestGame where - bestgame (b,i) a = if (snd a) > (snd b) - then (a,i+1) - else (b,i) + resultsFromAlgorithms = (map getbestWrapper gameComputation) + algoIdxs = take (length resultsFromAlgorithms) [ i | i <- [0..]] + bestGames = zipWith (\(a,b) c -> (a,b,c)) resultsFromAlgorithms algoIdxs + bestGame = foldl findBest ([], 0, 0) bestGames + findBest best nextBest = if ((bestScore best) > (bestScore nextBest)) + then best + else nextBest + bestScore (_, score, _) = score advanceGameComputation :: GameComputation -> GameComputation advanceGameComputation gc = map advanceWrapper gc +instance Strategy NullStrategy1 where + initst _ _ _ = NullS1 + advance _ = Left NullS1 + getbest _ = ([],0) + + +data NullStrategy2 = NullS2 + +instance Strategy NullStrategy2 where + initst _ _ _ = NullS2 + advance _ = Left NullS2 + getbest _ = ([],0) +