[WIP] Power phrases

src/Datatypes/Game.hs

@@ -1,6 +1,9 @@
-module Datatypes.Game (Game(..), Command(..), completed, new) where
+module Datatypes.Game (Game(..), Command(..), completed, new, cacheToScore, updateCache, powerPhrases, phraseConverter) where -- FIXME exports
 
 import Data.Hashable (hash)
+import qualified Data.List as List
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 
@@ -14,17 +17,20 @@ data Command = MoveW
              | MoveSE
              | RotateClockwise
              | RotateCounterclockwise
-             deriving (Show,Eq)
+             deriving (Show,Eq,Ord)
 
 type UnitHash = Int
 
+type PhrasesCache = Map [Command] Int
+
 data Game = Game {
           board :: Board,
           units :: [Unit],
           visitedUnits :: Set UnitHash,
           oldLines :: Int,
           score :: Int,
-          history :: [Command]
+          history :: [Command],
+          phrasesCache :: PhrasesCache
           }
           deriving Show
 
@@ -38,5 +44,32 @@ new b us = Game {
                 visitedUnits = Set.singleton (hash c),
                 oldLines = 0,
                 score = 0,
-                history = []
+                history = [],
+                phrasesCache = 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 

src/Strategy0.hs

@@ -2,29 +2,34 @@ module Strategy0 where
 
 import qualified Data.PQueue.Prio.Max as PQ
 
+import Data.Maybe (isJust)
+
 import Datatypes
 import Datatypes.Game (Command(..))
 import qualified Datatypes.Game as Game
 import VM
 
 commandsList :: [Command]
-commandsList = [MoveSE, MoveSW, MoveW, MoveE]
+commandsList = [MoveSE, MoveSW, MoveW, MoveE, RotateClockwise, RotateCounterclockwise]
 
 type Queue = PQ.MaxPQueue Int Game
 
+fullScore :: Game -> Int
+fullScore game = Game.score game + (Game.cacheToScore $ Game.phrasesCache game)
+
 strat0 :: Game -> ([Command],Int)
-strat0 game = let firstQueue = PQ.singleton (Game.score game) game
+strat0 game = let firstQueue = PQ.singleton (fullScore game) game
                   (incomplete, completed) = findBest maxIter firstQueue []
                   (_, bestIncomplete) = PQ.findMax incomplete
                   resultGame = findListMax (bestIncomplete:completed)
-                  in (reverse (Game.history resultGame), Game.score resultGame)
+                  in (reverse (Game.history resultGame), fullScore resultGame)
                   where
                       maxIter = 50000
 
 findListMax :: [Game] -> Game
 findListMax (x:xs) = innerFindListMax x xs where
     innerFindListMax currentMax [] = currentMax
-    innerFindListMax currentMax (y:ys) = innerFindListMax (if (Game.score currentMax) > (Game.score y) then currentMax else y) ys
+    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
@@ -33,10 +38,27 @@ partition p items = innerPartition items [] [] where
                                       then innerPartition xs (x:ts) fs
                                       else innerPartition xs ts (x:fs)
 
+tryPowerPhrases :: Game -> [(Game, Notes)]
+tryPowerPhrases game = validResults where
+    allResults = map (innerExpand (game, OK)) Game.powerPhrases
+    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
+                                        in case newNote of
+                                               OK -> Just nn
+                                               Lock _ -> Just nn
+                                               GameOver -> Just nn
+                                               _ -> Nothing
+    innerExpand (game, note) (p:ps) = let nn@(newGame, newNote) = step game p
+                                          in case newNote of
+                                                 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 = map (step game) commandsList
+        let candidates = map (step game) commandsList -- ++ (tryPowerPhrases game)
             (newQueue, newCompleted) = updateCollections candidates remQueue (game:completed)
             in findBest (i - 1) newQueue newCompleted
             where
@@ -47,5 +69,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 (Game.score x) x q
+                pushToQueue q x = PQ.insert (fullScore x) x q
                 pushToList c x = x : c

src/VM.hs

@@ -21,13 +21,21 @@ data Notes = OK
            deriving (Show,Eq)
 
 cmdToString :: [Command] -> String
-cmdToString (MoveW:cs) = 'p' : cmdToString cs
-cmdToString (MoveE:cs) = 'b' : cmdToString cs
-cmdToString (MoveSW:cs) = 'a' : cmdToString cs
-cmdToString (MoveSE:cs) = 'l' : cmdToString cs
-cmdToString (RotateClockwise:cs) = 'd' : cmdToString cs
-cmdToString (RotateCounterclockwise:cs) = 'k' : cmdToString cs
-cmdToString [] = []
+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 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
@@ -59,22 +67,6 @@ lockUnit game = game {
                          initialVisitedUnits [] = Set.empty
                          initialVisitedUnits (u:us) = Set.singleton (hash u)
 
-testStep = let unit = Unit (0, 0) (Set.fromList [(2,9)])
-               board = Board 5 10 (Set.fromList [(0,8),(1,8),(0,9),(1,9),(4,8),(3,9),(4,9)])
-               in  step (Game board [unit] (Set.fromList []) 0 0 []) MoveSW
-
-testStep2 = let unit = Unit (2, 4) (Set.fromList [(0,3),(1,3),(2,3),(3,3),(1,4),(2,4),(3,4), (1,5),(2,5),(2,6)])
-                board = Board 6 10 (Set.fromList [(0,8),(0,9),(4,6),(3,7),(4,7),(3,8),(4,8),(2,9),(3,9),(4,9),(5,8),(5,9)])
-                (g1, n1) = step (Game board [unit] (Set.fromList []) 2 0 []) MoveSW
-                (g2, n2) = step g1 MoveSE
-                (g3, n3) = step g2 MoveSW
-                (g4, n4) = step g3 MoveSW
-                in (g4, n4)
-
-testStep3 = let unit = Unit (0, 0) (Set.fromList [(2,9)])
-                board = Board 5 10 (Set.fromList [(0,8),(1,8),(0,9),(1,9),(4,8),(3,9),(4,9)])
-                in  step (Game board [unit] (Set.fromList []) 0 0 []) MoveSW
-
 step :: Game -> Command -> (Game, Notes)
 step game@(Game { units = [] }) command = (game, ErrorGameEnded)
 step game command =
@@ -83,7 +75,7 @@ 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) }
+            updatedGame = (checkSpawn $ lockUnit game) { history = command:(Game.history game), phrasesCache = Game.updateCache (Game.phrasesCache game) (command:(Game.history game)) }
             in
                 if shouldLock
                     then
@@ -93,7 +85,7 @@ step game command =
                     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) }, OK)
+                            else (game { units = newUnit:otherUnits, visitedUnits = newVisitedUnits, history = command:(Game.history game), phrasesCache = Game.updateCache (Game.phrasesCache game) (command:(Game.history game))}, OK)
 
 applyCommand :: Unit -> Command -> Unit
 applyCommand unit MoveW = Unit.map move unit where