by the power of grayskull

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

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

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

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
+    

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