You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

123 lines
6.2 KiB

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