diff --git a/src/Datatypes/Game.hs b/src/Datatypes/Game.hs index 727fd72..2999a41 100644 --- a/src/Datatypes/Game.hs +++ b/src/Datatypes/Game.hs @@ -1,4 +1,4 @@ -module Datatypes.Game (Game(..), Command(..), completed, new, cacheToScore, updateCache, powerPhrases, phraseConverter) where -- FIXME exports +module Datatypes.Game (Game(..), Command(..), isCompleted, new, notifyCommand, powerCounterToScore, powerPhrasesAsCommands, commandsToString) where -- FIXME exports import Data.Hashable (hash) import qualified Data.List as List @@ -12,16 +12,16 @@ import Datatypes.Unit (Unit) import qualified Datatypes.Unit as Unit data Command = MoveW + | MoveSE | MoveE | MoveSW - | MoveSE | RotateClockwise | RotateCounterclockwise deriving (Show,Eq,Ord) type UnitHash = Int -type PhrasesCache = Map [Command] Int +type PowerCounter = Map String Int data Game = Game { board :: Board, @@ -30,12 +30,12 @@ data Game = Game { oldLines :: Int, score :: Int, history :: [Command], - phrasesCache :: PhrasesCache + powerCounter :: PowerCounter } deriving Show -completed :: Game -> Bool -completed game = null $ units game +isCompleted :: Game -> Bool +isCompleted game = null $ units game new :: Board -> [Unit] -> Game new b us = Game { @@ -45,31 +45,100 @@ new b us = Game { oldLines = 0, score = 0, history = [], - phrasesCache = Map.empty + powerCounter = Map.empty } where (c:cs) = map (flip Unit.centeredIn b) us -phraseConverter :: [Command] -> String -phraseConverter s = if s == reverse [MoveE, MoveSW, MoveW] - then "ei!" - else if s == reverse [MoveSW, MoveSW, MoveW, MoveSE, MoveSW, MoveSW, MoveW] - then "ia! ia!" - else "PUPPA" - -powerPhrases :: [[Command]] -powerPhrases = [ - reverse [MoveE, MoveSW, MoveW], - reverse [MoveSW, MoveSW, MoveW, MoveSE, MoveSW, MoveSW, MoveW] - ] - -updateCache :: PhrasesCache -> [Command] -> PhrasesCache -updateCache cache history = innerUpdate cache history powerPhrases where - innerUpdate cache _ [] = cache - innerUpdate cache history (p:ps) = innerUpdate (updatedCache cache history p) history ps - updatedCache c h p | p `List.isPrefixOf` h = if Map.member p c - then Map.update (\a -> Just $ a + 1) p c - else Map.insert p 1 c - updatedCache c _ _ = c - -cacheToScore :: PhrasesCache -> Int -cacheToScore items = sum $ map evalScore (Map.toAscList items) where - evalScore (phrase, count) = 2 * (length phrase) * count + if count > 0 then 300 else 0 +powerPhrases :: Map String [Command] +powerPhrases = Map.fromList $ map (\x -> (x, stringToCommands x)) keys where + keys = ["ei!", "ia! ia!", "ph'nglui mglw'nafh cthulhu r'lyeh wgah'nagl fhtagn.", " r'lyeh", "yogsothoth", "necronomicon", "yuggoth", "john bigboote"] + +powerPhrasesAsCommands :: [[Command]] +powerPhrasesAsCommands = map snd $ Map.toList powerPhrases + +reversedPowerPhrases :: [([Command], String)] +reversedPowerPhrases = swapTuples . Map.toList $ powerPhrases where + swapTuples = map (\(s, cs) -> (reverse cs, s)) + +notifyCommand :: Game -> Command -> Game +notifyCommand game command = + game { history = newHistory, powerCounter = newPowerCounter } where + newHistory = command:(history game) + newPowerCounter = updatePowerCounter (powerCounter game) newHistory + +updatePowerCounter :: PowerCounter -> [Command] -> PowerCounter +updatePowerCounter counter history = + innerUpdate counter reversedPowerPhrases where + innerUpdate :: PowerCounter -> [([Command], String)] -> PowerCounter + innerUpdate c [] = c + innerUpdate c (p:ps) = innerUpdate (checkPrefix c p) ps + checkPrefix m (p, s) = if p `List.isPrefixOf` history + then incrementMember m s + else m + incrementMember m s = Map.insertWith (\_ old -> old + 1) s 1 m + +powerCounterToScore :: PowerCounter -> Int +powerCounterToScore items = sum $ map evalScore (Map.toAscList items) where + evalScore (phrase, count) = 2 * (length phrase) * count + (if count > 0 then 300 else 0) + +stringToCommands :: String -> [Command] +stringToCommands str = reverse (convert str []) where + convert [] acc = acc + convert ('p':cs) acc = convert cs (MoveW:acc) + convert ('\'':cs) acc = convert cs (MoveW:acc) + convert ('!':cs) acc = convert cs (MoveW:acc) + convert ('.':cs) acc = convert cs (MoveW:acc) + convert ('0':cs) acc = convert cs (MoveW:acc) + convert ('3':cs) acc = convert cs (MoveW:acc) + convert ('b':cs) acc = convert cs (MoveE:acc) + convert ('c':cs) acc = convert cs (MoveE:acc) + convert ('e':cs) acc = convert cs (MoveE:acc) + convert ('f':cs) acc = convert cs (MoveE:acc) + convert ('y':cs) acc = convert cs (MoveE:acc) + convert ('2':cs) acc = convert cs (MoveE:acc) + convert ('a':cs) acc = convert cs (MoveSW:acc) + convert ('g':cs) acc = convert cs (MoveSW:acc) + convert ('h':cs) acc = convert cs (MoveSW:acc) + convert ('i':cs) acc = convert cs (MoveSW:acc) + convert ('j':cs) acc = convert cs (MoveSW:acc) + convert ('4':cs) acc = convert cs (MoveSW:acc) + convert ('l':cs) acc = convert cs (MoveSE:acc) + convert ('m':cs) acc = convert cs (MoveSE:acc) + convert ('n':cs) acc = convert cs (MoveSE:acc) + convert ('o':cs) acc = convert cs (MoveSE:acc) + convert (' ':cs) acc = convert cs (MoveSE:acc) + convert ('5':cs) acc = convert cs (MoveSE:acc) + convert ('d':cs) acc = convert cs (RotateClockwise:acc) + convert ('q':cs) acc = convert cs (RotateClockwise:acc) + convert ('r':cs) acc = convert cs (RotateClockwise:acc) + convert ('v':cs) acc = convert cs (RotateClockwise:acc) + convert ('z':cs) acc = convert cs (RotateClockwise:acc) + convert ('1':cs) acc = convert cs (RotateClockwise:acc) + convert ('k':cs) acc = convert cs (RotateCounterclockwise:acc) + convert ('s':cs) acc = convert cs (RotateCounterclockwise:acc) + convert ('t':cs) acc = convert cs (RotateCounterclockwise:acc) + convert ('u':cs) acc = convert cs (RotateCounterclockwise:acc) + convert ('w':cs) acc = convert cs (RotateCounterclockwise:acc) + convert ('x':cs) acc = convert cs (RotateCounterclockwise:acc) + convert ('\t':cs) acc = convert cs acc + convert ('\n':cs) acc = convert cs acc + convert ('\r':cs) acc = convert cs acc + +commandsToString :: [Command] -> String +commandsToString [] = "" +commandsToString cmds@(c:cs) = + case smartConvert cmds (map (\(a, b) -> (b, a)) $ Map.toList powerPhrases) of + Just word -> word ++ (commandsToString (drop (length word) cmds)) + Nothing -> dumbConvert c : commandsToString cs + where + dumbConvert MoveW = 'p' + dumbConvert MoveE = 'b' + dumbConvert MoveSW = 'a' + dumbConvert MoveSE = 'l' + dumbConvert RotateClockwise = 'd' + dumbConvert RotateCounterclockwise = 'k' + smartConvert _ [] = Nothing + smartConvert cmds (p:ps) = + let (encoded, word) = p + in if encoded `List.isPrefixOf` cmds + then Just word + else smartConvert cmds ps diff --git a/src/Main0.hs b/src/Main0.hs index c03de38..c67b448 100644 --- a/src/Main0.hs +++ b/src/Main0.hs @@ -12,7 +12,7 @@ import Datatypes import Opt import JSONDeser import Strategy0 -import VM (cmdToString) +import Datatypes.Game (commandsToString) import Datatypes.Game (Command) data JSONSer = JSONSer { problemId :: Int, @@ -39,7 +39,7 @@ main = do args <- getArgs packAll :: Int -> [Int] -> [[Command]] -> [JSONSer] packAll id seeds commandLists = zipWith (\x y -> JSONSer id x "lilik0" y) seeds commandStrings where - commandStrings = map cmdToString commandLists + commandStrings = map commandsToString commandLists scoredata :: Int -> [Int] -> [Int] -> String scoredata id seeds points = pretty diff --git a/src/Strategy0.hs b/src/Strategy0.hs index 62bd8ea..c7e3a7d 100644 --- a/src/Strategy0.hs +++ b/src/Strategy0.hs @@ -6,25 +6,26 @@ import Data.Maybe (isJust) import Datatypes import Datatypes.Game (Command(..)) +import qualified Datatypes.Unit as Unit import qualified Datatypes.Game as Game import VM commandsList :: [Command] commandsList = [MoveSE, MoveSW, MoveW, MoveE, RotateClockwise, RotateCounterclockwise] -type Queue = PQ.MaxPQueue Int Game +type Queue = PQ.MaxPQueue (Int, Int, Int) Game fullScore :: Game -> Int -fullScore game = Game.score game + (Game.cacheToScore $ Game.phrasesCache game) +fullScore game = Game.score game + (Game.powerCounterToScore $ Game.powerCounter game) strat0 :: Game -> ([Command],Int) -strat0 game = let firstQueue = PQ.singleton (fullScore game) game +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 = 50000 + maxIter = 300000 findListMax :: [Game] -> Game findListMax (x:xs) = innerFindListMax x xs where @@ -40,7 +41,7 @@ partition p items = innerPartition items [] [] where tryPowerPhrases :: Game -> [(Game, Notes)] tryPowerPhrases game = validResults where - allResults = map (innerExpand (game, OK)) Game.powerPhrases + allResults = map (innerExpand (game, OK)) Game.powerPhrasesAsCommands validResults = map (\(Just x) -> x) $ filter (\x -> isJust x) allResults innerExpand (game, note) [] = Just (game, note) innerExpand (game, note) [p] = let nn@(newGame, newNote) = step game p @@ -69,5 +70,5 @@ findBest i queue completed = 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) x q + 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/TestSolution.hs b/src/TestSolution.hs new file mode 100644 index 0000000..767f6c7 --- /dev/null +++ b/src/TestSolution.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveGeneric #-} +module Main where + +import GHC.Generics +import Data.Aeson +import Data.Aeson.Types +import qualified Data.List as List + +import System.Environment +import qualified Data.ByteString.Lazy.Char8 as BS +import System.IO +import Datatypes +import Opt +import JSONDeser +import Strategy0 +import Datatypes.Game (commandsToString) +import Datatypes.Game (Command) +import PowerPhrases (charToCommand) + +import qualified Datatypes.Game as Game +import Datatypes.Game (Game) +import VM (step, Notes(..)) + +data JSONSer = JSONSer { problemId :: Int, + seed :: Int, + tag :: String, + solution :: String + } deriving (Show, Generic) + +instance FromJSON JSONSer +instance ToJSON JSONSer + +testVM :: Game -> String -> ([Notes], Int, Game) +testVM game strCmds = buildResult game commands [] where + commands = [c | (Just c) <- (map charToCommand strCmds)] + buildResult game [] notes = (reverse notes, Game.score game + (Game.powerCounterToScore $ Game.powerCounter game), game) + buildResult game (c:cs) notes = let (newGame, note) = step game c + in if elem note [ErrorSamePosition, ErrorGameEnded] + then (reverse (note:notes), 0, newGame) + else buildResult newGame cs (note:notes) + +main :: IO () +main = do args <- getArgs + opt <- parseArgs args + file <- return ((optFile opt) !! 0) + seed <- return (optSeedNumber opt) + (Just commands) <- return (optPowerPhrase opt) + str <- BS.readFile file + (_, gmseed) <- return (readInput str) + let (Just (s, g)) = List.find (\(s, g) -> s == seed) gmseed + (notes, score, ng) <- return $ testVM g commands + putStrLn ("Commands: " ++ show (Game.commandsToString . reverse . Game.history $ ng)) + putStrLn ("Notes: " ++ show notes) + putStrLn ("Score: " ++ show score) + +packAll :: Int -> [Int] -> [[Command]] -> [JSONSer] +packAll id seeds commandLists = zipWith (\x y -> JSONSer id x "lilik0" y) seeds commandStrings + where + commandStrings = map commandsToString commandLists + +scoredata :: Int -> [Int] -> [Int] -> String +scoredata id seeds points = pretty + where + pretty = foldl (\x (a,b,c) -> (show a) ++ " " ++ (show b) ++ " " ++ (show c) ++ "\n" ++ x) "" zipdata + zipdata = zip3 ids seeds points + ids = replicate (length seeds) id + diff --git a/src/VM.hs b/src/VM.hs index 88de3f0..f16bcc4 100644 --- a/src/VM.hs +++ b/src/VM.hs @@ -20,23 +20,6 @@ data Notes = OK | ErrorGameEnded deriving (Show,Eq) -cmdToString :: [Command] -> String -cmdToString [] = "" -cmdToString cmds@(s:ss) = case smartConvert cmds of - Just word -> word ++ cmdToString (drop (length word) cmds) - Nothing -> dumbConvert s : cmdToString ss -dumbConvert MoveW = 'p' -dumbConvert MoveE = 'b' -dumbConvert MoveSW = 'a' -dumbConvert MoveSE = 'l' -dumbConvert RotateClockwise = 'd' -dumbConvert RotateCounterclockwise = 'k' -smartConvert cmds = innerSmartConvert cmds Game.powerPhrases where - innerSmartConvert _ [] = Nothing - innerSmartConvert cmds (p:ps) = if (reverse p) `List.isPrefixOf` cmds - then Just $ Game.phraseConverter p - else innerSmartConvert cmds ps - moveScore :: Int -> Int -> Int -> Int moveScore size lines linesOld = points + lineBonus where points = size + 100 * ((1 + lines) * lines) `div` 2 @@ -44,22 +27,18 @@ moveScore size lines linesOld = points + lineBonus where then floor (fromIntegral ((linesOld - 1) * points) / 100) else 0 -checkSpawn :: Game -> Game -checkSpawn game@(Game { units = [] }) = game -checkSpawn game@(Game { units = (u:us), board = b }) = - if u `Unit.collidesWith` b - then game { Game.units = [] } - else game - lockUnit :: Game -> Game lockUnit game = game { board = newBoard, - units = otherUnits, + units = newUnits otherUnits, visitedUnits = initialVisitedUnits otherUnits, oldLines = clearedLines, score = Game.score game + newScore } where (currentUnit:otherUnits) = Game.units game + newUnits [] = [] + newUnits (u:us) | u `Unit.collidesWith` newBoard = [] + newUnits us = us mergedBoard = currentUnit `Unit.mergeWith` (Game.board game) (newBoard, clearedLines) = Board.clearLines mergedBoard size = Set.size $ Unit.members currentUnit @@ -75,17 +54,17 @@ step game command = board = Game.board game shouldLock = newUnit `Unit.collidesWith` board || newUnit `Unit.isOutsideOf` board newVisitedUnits = Set.insert (hash newUnit) (Game.visitedUnits game) - updatedGame = (checkSpawn $ lockUnit game) { history = command:(Game.history game), phrasesCache = Game.updateCache (Game.phrasesCache game) (command:(Game.history game)) } + updatedGame = Game.notifyCommand (lockUnit game) command in if shouldLock then - if Game.completed updatedGame + if Game.isCompleted updatedGame then (updatedGame, GameOver) else (updatedGame, Lock (Game.oldLines updatedGame)) else if Set.member (hash newUnit) (Game.visitedUnits game) then (game { units = newUnit:otherUnits }, ErrorSamePosition) - else (game { units = newUnit:otherUnits, visitedUnits = newVisitedUnits, history = command:(Game.history game), phrasesCache = Game.updateCache (Game.phrasesCache game) (command:(Game.history game))}, OK) + else (Game.notifyCommand (game { units = newUnit:otherUnits, visitedUnits = newVisitedUnits }) command, OK) applyCommand :: Unit -> Command -> Unit applyCommand unit MoveW = Unit.map move unit where