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 + lineBonus + 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 = 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 testStep2 = let unit = Unit (Set.fromList [(0,3),(1,3),(2,3),(3,3),(1,4),(2,4),(3,4), (1,5),(2,5),(2,6)]) (2,4) 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 (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