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.
110 lines
5.0 KiB
110 lines
5.0 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.Board (Board(..))
|
|
import qualified Datatypes.Board as Board
|
|
import Datatypes.Cell (Cell(..))
|
|
import qualified Datatypes.Cell as Cell
|
|
import Datatypes.Game (Game(..), Command(..))
|
|
import qualified Datatypes.Game as Game
|
|
import Datatypes.Unit (Unit(..))
|
|
import qualified Datatypes.Unit as Unit
|
|
|
|
data Notes = OK
|
|
| GameOver
|
|
| Lock { rowsCleaned :: Int }
|
|
| ErrorSamePosition
|
|
| ErrorGameEnded
|
|
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 [] = []
|
|
|
|
moveScore :: Int -> Int -> Int -> Int
|
|
moveScore size lines linesOld = points + lineBonus where
|
|
points = size + 100 * ((1 + lines) * lines) `div` 2
|
|
lineBonus = if linesOld > 1
|
|
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,
|
|
visitedUnits = initialVisitedUnits otherUnits,
|
|
oldLines = clearedLines,
|
|
score = Game.score game + newScore
|
|
} where
|
|
(currentUnit:otherUnits) = Game.units game
|
|
mergedBoard = currentUnit `Unit.mergeWith` (Game.board game)
|
|
(newBoard, clearedLines) = Board.clearLines mergedBoard
|
|
size = Set.size $ Unit.members currentUnit
|
|
newScore = moveScore size clearedLines (Game.oldLines 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 =
|
|
let (unit:otherUnits) = Game.units game
|
|
newUnit = applyCommand unit 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) }
|
|
in
|
|
if shouldLock
|
|
then
|
|
if Game.completed 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) }, OK)
|
|
|
|
applyCommand :: Unit -> Command -> Unit
|
|
applyCommand unit MoveW = Unit.map move unit where
|
|
move (x, y) = (x - 1, y)
|
|
applyCommand unit MoveE = Unit.map move unit where
|
|
move (x, y) = (x + 1, y)
|
|
applyCommand unit MoveSW = Unit.map move unit where
|
|
move (x, y) = (x - ((y + 1) `mod` 2), y + 1)
|
|
applyCommand unit MoveSE = Unit.map move unit where
|
|
move (x, y) = (x + (y `mod` 2), y + 1)
|
|
applyCommand (Unit pivot members) RotateClockwise = Unit pivot (Set.map transform members) where
|
|
transform cell = Cell.rotateClockwise pivot cell
|
|
applyCommand (Unit pivot members) RotateCounterclockwise = Unit pivot (Set.map transform members) where
|
|
transform cell = Cell.rotateCounterclockwise pivot cell
|