icfp2015/src/Main.hs

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