diff --git a/hexmino.cabal b/hexmino.cabal --- a/hexmino.cabal +++ b/hexmino.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.0 +version: 0.1.1.0 -- A short (one-line) description of the package. synopsis: A small game based on domino-like hexagonal tiles @@ -79,7 +79,8 @@ random >=1.1 && <1.2, optparse-applicative >=0.14 && <0.15, directory >= 1.3 && <1.4, - filepath >= 1.3 && <1.5 + filepath >= 1.3 && <1.5, + grid == 7.8.9 -- Directories containing source files. hs-source-dirs: src diff --git a/src/Table.hs b/src/Table.hs --- a/src/Table.hs +++ b/src/Table.hs @@ -11,7 +11,7 @@ data Table = Table {tileGrid :: Grid.TileGrid, tileList :: TileList.TileList, randGen :: Rand.StdGen} deriving Show empty :: Rand.StdGen -> Table -empty gen = Table {tileGrid = Grid.empty 0, tileList = TileList.empty, randGen = gen} +empty gen = Table {tileGrid = Grid.empty, tileList = TileList.empty, randGen = gen} -- displacements; NOTE: Table keeps track of the grid and list displacement, so both can assume they are centered gridX, listX :: Float @@ -44,7 +44,7 @@ -- manipulation functions newGame :: Int -> Table -> Table newGame level table = table {tileGrid = grid, tileList = TileList.fromList level lst, randGen = newGen} - where (grid, lst, newGen) = Grid.newGame (Grid.empty level) $ randGen table + where (grid, lst, newGen) = Grid.newGame level $ randGen table clear :: Table -> Table clear = empty . randGen @@ -61,7 +61,7 @@ Just idx -> putTileInGrid tile idx table _ -> putTileInList tile table -putTileInGrid :: Tile.Tile -> Grid.Axial -> Table -> Table +putTileInGrid :: Tile.Tile -> Grid.Index -> Table -> Table putTileInGrid tile idx table | Grid.indexIsEmpty idx $ tileGrid table = table {tileGrid = Grid.putTile tile idx $ tileGrid table} | otherwise = putTileInList tile table diff --git a/src/Tile.hs b/src/Tile.hs --- a/src/Tile.hs +++ b/src/Tile.hs @@ -3,9 +3,9 @@ import qualified Hex import qualified Graphics.Gloss.Data.Color as Color import qualified Graphics.Gloss.Data.Picture as Pict +import Math.Geometry.Grid.HexagonalInternal2 (HexDirection(..)) data Tile = Tile {hexagon :: Hex.Hexagon, faces :: (Int, Int, Int)} deriving (Show) -data Cardinal = North | NorthEast | SouthEast | South | SouthWest | NorthWest deriving (Eq, Enum, Bounded, Show) empty :: Float -> Tile empty size = Tile (Hex.Hexagon (0,0) size) (0,0,0) @@ -64,26 +64,24 @@ moveBy :: Pict.Point -> Tile -> Tile moveBy point tile = tile {hexagon = Hex.moveBy point $ hexagon tile} -sideValue :: Cardinal -> Tile -> Int -sideValue car Tile {faces = (a,b,c)} = case car of +sideValue :: HexDirection -> Tile -> Int +sideValue dir Tile {faces = (a,b,c)} = case dir of North -> a - NorthEast -> a - SouthEast -> b + Northeast -> a + Southeast -> b South -> b - SouthWest -> c - NorthWest -> c - -opposedCardinal :: Cardinal -> Cardinal -opposedCardinal car = case car of - North -> South - NorthEast -> SouthWest - SouthEast -> NorthWest - South -> North - SouthWest -> NorthEast - NorthWest -> SouthEast + Southwest -> c + Northwest -> c -allCardinal :: [Cardinal] -allCardinal = [minBound..maxBound] +changeSide :: HexDirection -> Int -> Tile -> Tile +changeSide dir val tile = case dir of + North -> tile {faces = (val, b, c)} + Northeast -> tile {faces = (val, b, c)} + Southeast -> tile {faces = (a, val, c)} + South -> tile {faces = (a, val, c)} + Southwest -> tile {faces = (a, b, val)} + Northwest -> tile {faces = (a, b, val)} + where (a, b, c) = faces tile -- utility functions facesRotations :: [Float] diff --git a/src/TileGrid.hs b/src/TileGrid.hs --- a/src/TileGrid.hs +++ b/src/TileGrid.hs @@ -7,43 +7,45 @@ import qualified System.Random as Rand import qualified Graphics.Gloss.Data.Color as Color import qualified Graphics.Gloss.Data.Picture as Pict +import qualified Math.Geometry.Grid as Grid +import qualified Math.Geometry.Grid.Hexagonal2 as HexGrid +import qualified Math.Geometry.GridMap as GridMap (toGrid, toMap, lookup, insert, delete, toList, adjust, elems) +import qualified Math.Geometry.GridMap.Lazy as LGridMap +import Math.Geometry.Grid.HexagonalInternal2 (HexDirection(..)) --- implementation based on https://www.redblobgames.com/grids/hexagons/ -data TileGrid = TileGrid {tileMap :: TileMap, range :: Int, tileSize :: Float} deriving Show -type TileMap = Map.Map Axial Tile.Tile --- coordinate systems - chosen offset is odd-q -newtype Axial = Axial (Int, Int) deriving (Eq, Ord, Show) -newtype Offset = Offset (Int, Int) deriving (Eq, Ord, Show) -newtype Cubic = Cubic (Int, Int, Int) deriving (Eq, Ord, Show) +-- implementation was guided by https://www.redblobgames.com/grids/hexagons/ +-- uses grid package, for reference: flat top with Axial (x,y) coordinates +type TileGrid = LGridMap.LGridMap HexGrid.HexHexGrid Tile.Tile +type Index = Grid.Index HexGrid.HexHexGrid -- creation functions -empty :: Int -> TileGrid -empty rg = TileGrid {tileMap = Map.empty, range = rg, tileSize = rangeToSize rg} +empty :: TileGrid +empty = LGridMap.empty $ HexGrid.hexHexGrid 0 -newGame :: TileGrid -> Rand.StdGen -> (TileGrid, [Tile.Tile], Rand.StdGen) -newGame grid gen = (clear grid, lst, lastGen) +newGame :: Int -> Rand.StdGen -> (TileGrid, [Tile.Tile], Rand.StdGen) +newGame level gen = (emptyGrid, lst, lastGen) where - rg = range grid - idxedTiles = zip (everyIndex rg) . repeat . Tile.empty $ tileSize grid - (fullMap, middleGen) = foldl' fillTile (Map.fromList idxedTiles, gen) idxedTiles - (randInts, lastGen) = randomInts (totalIndexNum rg) middleGen - lst = map rotateAndTake . sortOn fst . zip randInts $ Map.elems fullMap + emptyGrid = LGridMap.empty $ HexGrid.hexHexGrid (level + 1) + (fullGrid, middleGen) = foldl' matchSides (emptyGrid, gen) $ Grid.edges emptyGrid + (randInts, lastGen) = randomInts (indicesNum emptyGrid) middleGen + lst = map rotateAndTake . sortOn fst . zip randInts $ GridMap.elems fullGrid -fillTile :: (TileMap, Rand.StdGen) -> (Axial, Tile.Tile) -> (TileMap, Rand.StdGen) -fillTile (tMap, gen) (idx, tile) = (Map.insert idx (tile {Tile.faces = (a,b,c)}) tMap, newGen) +matchSides :: (TileGrid, Rand.StdGen) -> (Index, Index) -> (TileGrid, Rand.StdGen) +matchSides (tileGrid, gen) (idxA, idxB) = case (sideA, sideB) of + (Nothing, _) -> matchSides (putTile newTile idxA tileGrid, gen) (idxA, idxB) + (_, Nothing) -> matchSides (putTile newTile idxB tileGrid, gen) (idxA, idxB) + (Just 0, Just 0) -> (adjustSide dirA newVal idxA $ adjustSide dirB newVal idxB tileGrid, newGen) + (Just n, Just k) -> ((if n /= 0 then adjustSide dirB n idxB else adjustSide dirA k idxA) tileGrid, gen) where - (a, genA) = fillFace (neighVal idx Tile.North tMap, neighVal idx Tile.NorthEast tMap) gen - (b, genB) = fillFace (neighVal idx Tile.SouthEast tMap, neighVal idx Tile.South tMap) genA - (c, newGen) = fillFace (neighVal idx Tile.SouthWest tMap, neighVal idx Tile.NorthWest tMap) genB + dirA = head $ Grid.directionTo (GridMap.toGrid tileGrid) idxA idxB + dirB = oppositeDirection dirA + sideA = Tile.sideValue dirA <$> GridMap.lookup idxA tileGrid + sideB = Tile.sideValue dirB <$> GridMap.lookup idxB tileGrid + (newVal, newGen) = Rand.randomR (1,6) gen + newTile = Tile.empty $ tileSize tileGrid -fillFace :: (Maybe Int, Maybe Int) -> Rand.StdGen -> (Int, Rand.StdGen) -fillFace neigs gen = case neigs of - (Just 0, Just 0) -> newRand - (Just n, Just k) -> if n /= 0 then (n, gen) else (k, gen) - (Nothing, Just n) -> if n /= 0 then (n, gen) else newRand - (Just n, Nothing) -> if n /= 0 then (n, gen) else newRand - _ -> (0, gen) - where newRand = Rand.randomR (1,6) gen +adjustSide :: HexDirection -> Int -> Index -> TileGrid -> TileGrid +adjustSide dir val idx = GridMap.adjust (Tile.changeSide dir val) idx randomInts :: Int -> Rand.StdGen -> ([Int], Rand.StdGen) randomInts 0 gen = ([], gen) @@ -57,129 +59,92 @@ -- rendering functions render :: Color.Color -> TileGrid -> Pict.Picture -render col grid = case range grid of - 0 -> Pict.color col $ Hex.hexagonSolidPointy 230 - rg -> Pict.pictures . map (renderIndex col grid) $ everyIndex rg +render col tileGrid + | isEmpty tileGrid = Pict.color col $ Hex.hexagonSolidPointy 230 + | otherwise = Pict.pictures . map (renderIndex col tileGrid) $ indices tileGrid -renderIndex :: Color.Color -> TileGrid -> Axial -> Pict.Picture -renderIndex col grid axi = case Map.lookup axi $ tileMap grid of +renderIndex :: Color.Color -> TileGrid -> Index -> Pict.Picture +renderIndex col tileGrid idx = case GridMap.lookup idx tileGrid of Just tile -> Tile.render tile - _ -> renderEmpty col axi $ tileSize grid + _ -> renderEmpty col idx $ tileSize tileGrid -renderEmpty :: Color.Color -> Axial -> Float -> Pict.Picture -renderEmpty col axi rad = Pict.color col $ Hex.render hex - where hex = Hex.Hexagon {Hex.center = indexCenter axi rad, Hex.radius = rad-1} +renderEmpty :: Color.Color -> Index -> Float -> Pict.Picture +renderEmpty col idx rad = Pict.color col $ Hex.render hex + where hex = Hex.Hexagon {Hex.center = indexCenter idx rad, Hex.radius = rad-1} -- manipulation functions -putTile :: Tile.Tile -> Axial -> TileGrid -> TileGrid -putTile tile idx grid = grid {tileMap = Map.insert idx fixedTile $ tileMap grid} - where fixedTile = Tile.moveTo (indexCenter idx (tileSize grid)) tile +putTile :: Tile.Tile -> Index -> TileGrid -> TileGrid +putTile tile idx tileGrid = GridMap.insert idx fixedTile tileGrid + where fixedTile = Tile.moveTo (indexCenter idx (tileSize tileGrid)) tile grab :: Pict.Point -> TileGrid -> (TileGrid, Maybe Tile.Tile) -grab point grid = case pointToIndex point grid of - Just idx -> grabIndex idx grid - _ -> (grid, Nothing) +grab point tileGrid = case pointToIndex point tileGrid of + Just idx -> grabIndex idx tileGrid + _ -> (tileGrid, Nothing) -grabIndex :: Axial -> TileGrid -> (TileGrid, Maybe Tile.Tile) -grabIndex idx grid = case Map.lookup idx $ tileMap grid of - Just tile -> (grid {tileMap = Map.delete idx $ tileMap grid}, Just tile) - _ -> (grid, Nothing) +grabIndex :: Index -> TileGrid -> (TileGrid, Maybe Tile.Tile) +grabIndex idx tileGrid = case GridMap.lookup idx tileGrid of + Just tile -> (GridMap.delete idx tileGrid, Just tile) + _ -> (tileGrid, Nothing) isFull :: TileGrid -> Bool -isFull TileGrid {tileMap = tMap, range = rg} = totalIndexNum rg == Map.size tMap +isFull tileGrid = indicesNum tileGrid == length (GridMap.toList tileGrid) isCompleted :: TileGrid -> Bool -isCompleted grid - | isFull grid = all (matchesNeighs (tileMap grid)) . everyIndex $ range grid +isCompleted tileGrid + | isFull tileGrid = all (matchingSides tileGrid) . Grid.edges $ GridMap.toGrid tileGrid | otherwise = False -clear :: TileGrid -> TileGrid -clear = empty . range - -- utility functions -rangeToSize :: Int -> Float -rangeToSize n = 418 / (2 * (fn+1) + fn) - where fn = fromIntegral n - -indexIsEmpty :: Axial -> TileGrid -> Bool -indexIsEmpty idx = Map.notMember idx . tileMap +isEmpty :: TileGrid -> Bool +isEmpty = Grid.null . GridMap.toGrid -totalIndexNum :: Int -> Int -totalIndexNum range = range * (range + 1) `div` 2 * 6 + 1 +indexIsEmpty :: Index -> TileGrid -> Bool +indexIsEmpty idx = Map.notMember idx . GridMap.toMap -everyIndex :: Int -> [Axial] -everyIndex = map cubicToAxial . everyCubicIndex +indicesNum :: TileGrid -> Int +indicesNum = Grid.tileCount . GridMap.toGrid -everyCubicIndex :: Int -> [Cubic] -everyCubicIndex range = [Cubic (x,y,z) | - x <- [(-range)..range], - y <- [(max (-range) ((-x)-range))..(min range (range-x))], - let z = (-x)-y, - x + y + z == 0 - ] +indices :: TileGrid -> [Index] +indices = Grid.indices . GridMap.toGrid -indexCenter :: Axial -> Float -> Pict.Point -indexCenter axi rad = (rad * fromIntegral cl * 1.5, (off + fromIntegral rw) * (-h)) +indexCenter :: Index -> Float -> Pict.Point -- NOTE: based on odd-q +indexCenter (x, y) radius = (radius * column * 1.5, (offset + row) * (-height)) where - Offset (cl, rw) = axialToOffset axi - h = Hex.heightFromRadius rad - off = if odd cl then 0.5 else 0 + column = fromIntegral x + row = fromIntegral $ (-x) - y + (x - (if odd x then 1 else 0)) `div` 2 + height = Hex.heightFromRadius radius + offset = if odd x then 0.5 else 0 -pointToIndex :: Pict.Point -> TileGrid -> Maybe Axial -pointToIndex point grid - | isValidIndex axi grid = Just axi +pointToIndex :: Pict.Point -> TileGrid -> Maybe Index +pointToIndex (x, y) tileGrid + | Grid.contains tileGrid idx = Just idx | otherwise = Nothing - where axi = pointToAxial point $ tileSize grid - -pointToAxial :: Pict.Point -> Float -> Axial -pointToAxial (x,y) size = Axial (round q, round r) where - q = 2/3 * x / size - r = ((-1)/3 * x + sqrt 3 / 3 * (-y)) / size - -isValidIndex :: Axial -> TileGrid -> Bool -isValidIndex axi grid = cubicDistance (Cubic (0,0,0)) (axialToCubic axi) <= range grid - -cubicDistance :: Cubic -> Cubic -> Int -cubicDistance (Cubic (x1,y1,z1)) (Cubic (x2,y2,z2)) = maximum $ map abs [x1-x2, y1-y2, z1-z2] + size = tileSize tileGrid + idxX = 2/3 * x / size + idxZ = ((-1)/3 * x + sqrt 3 / 3 * (-y)) / size + idxY = (-idxX) - idxZ + idx = (round idxX, round idxY) -matchesNeighs :: TileMap -> Axial -> Bool -matchesNeighs tMap idx = case Map.lookup idx tMap of - Just tile -> all (matchesNeighSide tile idx tMap) Tile.allCardinal +matchingSides :: TileGrid -> (Index, Index) -> Bool +matchingSides tileGrid (idxA, idxB) = case (look idxA, look idxB) of + (Just tileA, Just tileB) -> Tile.sideValue dirA tileA == Tile.sideValue dirB tileB _ -> False - -matchesNeighSide :: Tile.Tile -> Axial -> TileMap -> Tile.Cardinal -> Bool -matchesNeighSide tile idx tMap card = case neighVal idx card tMap of - Just 0 -> False - Just n -> Tile.sideValue card tile == n - Nothing -> True -- always matches an out-of-range tiles - -neighVal :: Axial -> Tile.Cardinal -> TileMap -> Maybe Int -neighVal idx card tMap = case neighTile idx card tMap of - Just tile -> Just $ Tile.sideValue (Tile.opposedCardinal card) tile - _ -> Nothing - -neighTile :: Axial -> Tile.Cardinal -> TileMap -> Maybe Tile.Tile -neighTile idx card = Map.lookup (neighAxial idx card) - -neighAxial :: Axial -> Tile.Cardinal -> Axial -neighAxial (Axial (q, r)) card = case card of - Tile.North -> Axial (q, r-1) - Tile.NorthEast -> Axial (q+1, r-1) - Tile.SouthEast -> Axial (q+1, r) - Tile.South -> Axial (q, r+1) - Tile.SouthWest -> Axial (q-1, r+1) - Tile.NorthWest -> Axial (q-1, r) - --- coordinates conversion functions -axialToOffset :: Axial -> Offset -axialToOffset = cubicToOffset . axialToCubic - -axialToCubic :: Axial -> Cubic -axialToCubic (Axial (q, r)) = Cubic (q, (-q) - r, r) + where + look = (`GridMap.lookup` tileGrid) + dirA = head $ Grid.directionTo (GridMap.toGrid tileGrid) idxA idxB + dirB = oppositeDirection dirA -cubicToOffset :: Cubic -> Offset -cubicToOffset (Cubic (x, y, z)) = Offset (x, z + (x - (if odd x then 1 else 0)) `div` 2) +tileSize :: TileGrid -> Float +tileSize tileGrid = 418 / (2 * rg + (rg-1)) + where rg = fromIntegral . Grid.size $ GridMap.toGrid tileGrid -cubicToAxial :: Cubic -> Axial -cubicToAxial (Cubic (x, _, z)) = Axial (x, z) +oppositeDirection :: HexDirection -> HexDirection +oppositeDirection car = case car of + North -> South + Northeast -> Southwest + Southeast -> Northwest + South -> North + Southwest -> Northeast + Northwest -> Southeast