Merge branch 'adaptedStrategy0' into vm

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

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)) 
             

src/LCG.hs

@@ -1,6 +1,6 @@
 module LCG where
 
-import Data.Bits
+import Data.Bits(shiftR,(.&.))
 
 modulus = 2^32
 multiplier = 1103515245

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)
+    

src/Mainpf.hs

@@ -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) ++ " "

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
 

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

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)
+