hexmino 0.1.0.0 → 0.1.1.0
raw patch · 4 files changed
+115/−151 lines, 4 filesdep +grid
Dependencies added: grid
Files
- hexmino.cabal +3/−2
- src/Table.hs +3/−3
- src/Tile.hs +16/−18
- src/TileGrid.hs +93/−128
hexmino.cabal view
@@ -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
src/Table.hs view
@@ -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
src/Tile.hs view
@@ -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]
src/TileGrid.hs view
@@ -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