Browse Source

by the power of grayskull

vm
Slash 9 years ago
parent
commit
8aa771b3ea
5 changed files with 184 additions and 68 deletions
  1. +101
    -32
      src/Datatypes/Game.hs
  2. +2
    -2
      src/Main0.hs
  3. +7
    -6
      src/Strategy0.hs
  4. +67
    -0
      src/TestSolution.hs
  5. +7
    -28
      src/VM.hs

+ 101
- 32
src/Datatypes/Game.hs View File

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

+ 2
- 2
src/Main0.hs View File

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


+ 7
- 6
src/Strategy0.hs View File

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

+ 67
- 0
src/TestSolution.hs View File

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

+ 7
- 28
src/VM.hs View File

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


Loading…
Cancel
Save