|
|
- module VM where
-
- import Data.Hashable (hash, Hashable(..))
- import qualified Data.List as List
- import Data.Set (Set)
- import qualified Data.Set as Set
-
- import Datatypes
-
- unitMap :: (Cell -> Cell) -> Unit -> Unit
- unitMap f (Unit members pivot) = Unit (Set.map f members) (f pivot)
-
- centerUnit :: Unit -> Board -> Unit
- centerUnit u b = unitMap (\(x, y) -> (x + deltaX, y - unitTop)) u where
- members = unitMembers u
- yCoords = Set.map (\(x, y) -> y) members
- xCoords = Set.map (\(x, y) -> x) members
- unitTop = Set.findMin yCoords
- unitLeft = Set.findMin xCoords
- unitRight = Set.findMax xCoords
- deltaX = (unitLeft + (boardWidth b - unitRight - 1)) `div` 2 - unitLeft
-
- collides :: Unit -> Board -> Bool
- collides u b = not . Set.null $ Set.intersection (unitMembers u) (boardFilled b)
-
- isInvalidFor :: Unit -> Board -> Bool
- isInvalidFor u b = any isOutside (Set.toList $ unitMembers u) where
- isOutside (x, y) = x < 0 || x >= boardWidth b || y < 0 || y >= boardHeight b
-
- checkSpawn :: Game -> Game
- checkSpawn game@(Game _ [] _ _ _) = game
- checkSpawn game@(Game board (u:us) oldPos _ _) = if u `collides` board
- then game { gameUnits = [] }
- else game
-
- isCompleted :: Game -> Bool
- isCompleted game@(Game _ [] _ _ _) = True
- isCompleted _ = False
-
- clearLines :: Board -> (Board, Int)
- clearLines (Board width height filled) = let (newFilled, linesDeleted) = tryToDelete yCoords 0 filled
- in (Board width height newFilled, linesDeleted)
- where
- yCoords = Set.toList $ Set.map (\(x, y) -> y) filled
- countInLine l items = Set.size $ Set.filter (\(x, y) -> y == l) items
- tryToDelete (l:ls) count items = if countInLine l items == width
- then tryToDelete ls (count + 1) (deleteLine l items)
- else tryToDelete ls count items
- tryToDelete [] count items = (items, count)
- deleteLine l items = let deleted = Set.filter (\(x, y) -> y /= l) items
- in Set.map (\(x, y) -> if y < l then (x, y + 1) else (x, y)) deleted
-
- lockUnit :: Game -> Game
- lockUnit (Game board (u:us) _ oldLines oldPoints) = Game newBoard us (Set.fromList []) newLines (newPoints + oldPoints) where
- tempBoard = board { boardFilled = Set.union (unitMembers u) (boardFilled board) }
- (newBoard, newLines) = clearLines tempBoard
- newPoints = (Set.size (unitMembers u)) + (100 * (1 + newLines) * newLines `div` 2) + lineBonus
- lineBonus = if oldLines > 1
- then floor (fromIntegral ((oldLines - 1) * newPoints) / 10)
- else 0
-
- testStep = let unit = Unit (Set.fromList [(2,9)]) (0,0)
- 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 _ [] _ _ _) command = (game, ErrorZero)
- step game@(Game board (unit:us) oldPositions o l) command =
- if newUnit `collides` board || newUnit `isInvalidFor` board
- then let final = checkSpawn (lockUnit game) in
- (if isCompleted final then (final, Ended) else (final, OK))
- else
- if Set.member (hash newUnit) oldPositions
- then (Game board (newUnit:us) oldPositions o l, ErrorZero)
- else (Game board (newUnit:us) newOldPositions o l, OK)
- where
- newUnit = applyCommand unit command
- newOldPositions = Set.insert (hash newUnit) oldPositions
-
- applyWholeUnit :: Unit -> (Cell -> Cell) -> Unit
- applyWholeUnit (Unit members pivot) f = Unit (Set.map f members) (f pivot)
-
- applyCommand :: Unit -> Command -> Unit
- applyCommand unit MoveW = applyWholeUnit unit move where
- move (x, y) = (x - 1, y)
- applyCommand unit MoveE = applyWholeUnit unit move where
- move (x, y) = (x + 1, y)
- applyCommand unit MoveSW = applyWholeUnit unit move where
- move (x, y) = (x - ((y + 1) `mod` 2), y + 1)
- applyCommand unit MoveSE = applyWholeUnit unit move where
- move (x, y) = (x + (y `mod` 2), y + 1)
- applyCommand (Unit members pivot) RotateClockwise = Unit (Set.map transform members) pivot where
- transform cell = rotateCell pivot cell
- applyCommand (Unit members pivot) RotateCounterclockwise = Unit (Set.map transform members) pivot where
- transform cell = counterRotateCell pivot cell
-
- rotateCell :: Cell -> Cell -> Cell
- rotateCell (px, py) (x, y) = (px - ddiag + (doriz + py `mod` 2) `div` 2, py + doriz) where
- (ddiag, doriz) = relativePosition (px, py) (x, y)
-
- counterRotateCell :: Cell -> Cell -> Cell
- counterRotateCell pivot = rp . rp . rp . rp . rp where
- rp = rotateCell pivot
- counterRotateCell2 :: Cell -> Cell -> Cell
- counterRotateCell2 (px, py) (x, y) = (px + (ddiag + doriz + py `mod` 2) `div` 2, py + ddiag - doriz) where
- (ddiag, doriz) = relativePosition (px, py) (x, y)
-
- relativePosition :: Cell -> Cell -> (Int, Int)
- relativePosition (px, py) (x, y) = (diagDir, horizDir) where
- diagDir = y - py
- horizDir = x - px + (if py `mod` 2 == 0 then diagDir + diagDir `mod` 2 else diagDir - diagDir `mod` 2) `div` 2
|