-- | Hexagonal coordinate systems.
--
-- Nice article about the topic: https://www.redblobgames.com/grids/hexagons/
--
-- <<docs/haddock/Geometry/Coordinates/Hexagonal/cubes.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Coordinates/Hexagonal/cubes.svg" 360 360 $ \_ -> do
--     let cellSize = 10
--         hexagons = runST $ do
--             gen <- MWC.create
--             points <- gaussianDistributedPoints gen canvas (40*.mempty) (2^14)
--             let hexs = fmap (fromVec2 cellSize) points
--             pure $ foldl' (\weight hex -> M.insertWith (+) hex (1::Int) weight) mempty hexs
--         canvas = shrinkBoundingBox (cellSize*2) [zero, Vec2 360 360]
--         MinMax minW maxW = foldMap (\x -> MinMax x x) hexagons
--     for_ (sortOn (\(_,weight) -> weight) (M.toList hexagons)) $ \(hex, weight) -> do
--         let value = lerp ((sqrt (fromIntegral minW)), (sqrt (fromIntegral maxW))) (0,1) (sqrt (fromIntegral weight))
--             growth = lerp (0,1) (3,6) value
--         sketch (growPolygon growth (hexagonPoly cellSize hex))
--         let color = twilight value
--         setColor color
--         C.fillPreserve
--         let hexCenter = toVec2 cellSize hex
--         sketch [Line hexCenter (hexCenter +. polar (deg (d+30)) (cellSize + 2/sqrt 3*growth)) | d <- [0,120,240]]
--         setColor black
--         C.stroke
-- :}
-- Generated file: size 194KB, crc32: 0xcde33b0b
module Geometry.Coordinates.Hexagonal (
      Hex(..)
    , toVec2
    , fromVec2

    -- * Painting aid
    , hexagonalCoordinateSystem

    -- * Movement
    , Direction(..)
    , move

    -- * Arithmetic
    , hexAdd
    , hexSubtract
    , hexTimes
    , hexZero

    -- * Measurement and transformation
    , distance
    , rotateAround
    , cubeRound

    -- * Geometry
    , line
    , ring
    , hexagonsInRange
    , HexPolygon(..)
    , isOnEdge
    , pointInPolygon
    , edgePoints
    , floodFill

    -- * Drawing and interfacing
    , polygonSketch
    , hexagonPoly
) where



import           Control.DeepSeq
import           Control.Monad
import           Data.Foldable
import           Data.Maybe
import           Data.Set                 (Set)
import qualified Data.Set                 as S
import qualified Graphics.Rendering.Cairo as C hiding (x, y)

import           Draw
import           Geometry.Core          as G hiding
    (Polygon, pointInPolygon, rotateAround)
import qualified Geometry.Core          as G
import           Numerics.Interpolation
import           Util



-- $setup
-- >>> import           Control.Monad.ST
-- >>> import           Data.Foldable
-- >>> import qualified Data.Map                        as M
-- >>> import           Data.Ord.Extended
-- >>> import           Draw
-- >>> import           Data.List
-- >>> import           Geometry.Algorithms.Sampling
-- >>> import qualified System.Random.MWC               as MWC
-- >>> import qualified System.Random.MWC.Distributions as MWC



-- | Hexagonal coordinate.
data Hex = Hex !Int !Int
    -- ^ The choice of values is called »cubal«.
    -- Use 's' (= -q-r) to get the omitted coordinate’s value.

    -- This is really just a ℝ^3 with rounding occurring in every calculation,
    -- but alas, ℤ is not a field, so it isn’t a vector space.
    deriving (Int -> Hex -> ShowS
[Hex] -> ShowS
Hex -> String
(Int -> Hex -> ShowS)
-> (Hex -> String) -> ([Hex] -> ShowS) -> Show Hex
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Hex -> ShowS
showsPrec :: Int -> Hex -> ShowS
$cshow :: Hex -> String
show :: Hex -> String
$cshowList :: [Hex] -> ShowS
showList :: [Hex] -> ShowS
Show)

instance Eq Hex where
    Hex Int
q Int
r == :: Hex -> Hex -> Bool
== Hex Int
q' Int
r' = Int
q Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
q' Bool -> Bool -> Bool
&& Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
r'

instance Ord Hex where
    Hex Int
q Int
r compare :: Hex -> Hex -> Ordering
`compare` Hex Int
q' Int
r' = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
q Int
q' Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
r Int
r'

instance NFData Hex where
    rnf :: Hex -> ()
rnf Hex
_ = () -- Constructors are already strict

-- | Since \(q+r+s=0\) in cubical hexagonal coordinates, we can infer the third
-- from the other two.
s :: Int -> Int -> Int
s :: Int -> Int -> Int
s Int
q Int
r = -Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r

-- | Hexagonal direction, used by 'move'.
data Direction
    = R  -- ^ Right
    | UR -- ^ Up+right
    | UL -- ^ Up+left
    | L  -- ^ Left
    | DL -- ^ Down+left
    | DR -- ^ Down+right
    deriving (Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
/= :: Direction -> Direction -> Bool
Eq, Eq Direction
Eq Direction
-> (Direction -> Direction -> Ordering)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Direction)
-> (Direction -> Direction -> Direction)
-> Ord Direction
Direction -> Direction -> Bool
Direction -> Direction -> Ordering
Direction -> Direction -> Direction
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Direction -> Direction -> Ordering
compare :: Direction -> Direction -> Ordering
$c< :: Direction -> Direction -> Bool
< :: Direction -> Direction -> Bool
$c<= :: Direction -> Direction -> Bool
<= :: Direction -> Direction -> Bool
$c> :: Direction -> Direction -> Bool
> :: Direction -> Direction -> Bool
$c>= :: Direction -> Direction -> Bool
>= :: Direction -> Direction -> Bool
$cmax :: Direction -> Direction -> Direction
max :: Direction -> Direction -> Direction
$cmin :: Direction -> Direction -> Direction
min :: Direction -> Direction -> Direction
Ord, Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Direction -> ShowS
showsPrec :: Int -> Direction -> ShowS
$cshow :: Direction -> String
show :: Direction -> String
$cshowList :: [Direction] -> ShowS
showList :: [Direction] -> ShowS
Show, Direction
Direction -> Direction -> Bounded Direction
forall a. a -> a -> Bounded a
$cminBound :: Direction
minBound :: Direction
$cmaxBound :: Direction
maxBound :: Direction
Bounded, Int -> Direction
Direction -> Int
Direction -> [Direction]
Direction -> Direction
Direction -> Direction -> [Direction]
Direction -> Direction -> Direction -> [Direction]
(Direction -> Direction)
-> (Direction -> Direction)
-> (Int -> Direction)
-> (Direction -> Int)
-> (Direction -> [Direction])
-> (Direction -> Direction -> [Direction])
-> (Direction -> Direction -> [Direction])
-> (Direction -> Direction -> Direction -> [Direction])
-> Enum Direction
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Direction -> Direction
succ :: Direction -> Direction
$cpred :: Direction -> Direction
pred :: Direction -> Direction
$ctoEnum :: Int -> Direction
toEnum :: Int -> Direction
$cfromEnum :: Direction -> Int
fromEnum :: Direction -> Int
$cenumFrom :: Direction -> [Direction]
enumFrom :: Direction -> [Direction]
$cenumFromThen :: Direction -> Direction -> [Direction]
enumFromThen :: Direction -> Direction -> [Direction]
$cenumFromTo :: Direction -> Direction -> [Direction]
enumFromTo :: Direction -> Direction -> [Direction]
$cenumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
enumFromThenTo :: Direction -> Direction -> Direction -> [Direction]
Enum)

-- | Move x steps in a direction
move :: Direction -> Int -> Hex -> Hex
move :: Direction -> Int -> Hex -> Hex
move Direction
dir Int
x (Hex Int
q Int
r) = case Direction
dir of
    Direction
R  -> Int -> Int -> Hex
Hex (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
x)  Int
r
    Direction
UR -> Int -> Int -> Hex
Hex (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
x) (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
x)
    Direction
UL -> Int -> Int -> Hex
Hex  Int
q    (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
x)
    Direction
L  -> Int -> Int -> Hex
Hex (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
x)  Int
r
    Direction
DL -> Int -> Int -> Hex
Hex (Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
x) (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
x)
    Direction
DR -> Int -> Int -> Hex
Hex  Int
q    (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
x)

-- | Add two 'Hex' coordinates.
hexAdd :: Hex -> Hex -> Hex
Hex Int
q1 Int
r1 hexAdd :: Hex -> Hex -> Hex
`hexAdd` Hex Int
q2 Int
r2 = Int -> Int -> Hex
Hex (Int
q1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
q2) (Int
r1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
r2)

-- | Subtract two 'Hex' coordinates.
hexSubtract :: Hex -> Hex -> Hex
Hex Int
q1 Int
r1 hexSubtract :: Hex -> Hex -> Hex
`hexSubtract` Hex Int
q2 Int
r2 = Int -> Int -> Hex
Hex (Int
q1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
q2) (Int
r1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r2)

-- | Multiply a 'Hex' coordinate with a whole number.
hexTimes :: Int -> Hex -> Hex
Int
n hexTimes :: Int -> Hex -> Hex
`hexTimes` Hex Int
q Int
r = Int -> Int -> Hex
Hex (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
q) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
r)

-- | The origin of the hexagonal coordinate system.
hexZero :: Hex
hexZero :: Hex
hexZero = Int -> Int -> Hex
Hex Int
0 Int
0

-- | How many steps are between two coordinates?
distance :: Hex -> Hex -> Int
distance :: Hex -> Hex -> Int
distance (Hex Int
q1 Int
r1) (Hex Int
q2 Int
r2) = (Int -> Int
forall a. Num a => a -> a
abs (Int
q1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
q2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Num a => a -> a
abs (Int
r1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
r2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Num a => a -> a
abs (Int
s1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
s2)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  where
    s1 :: Int
s1 = Int -> Int -> Int
s Int
q1 Int
r1
    s2 :: Int
s2 = Int -> Int -> Int
s Int
q2 Int
r2

-- | Rotate clockwise by 60°
rotateCw :: Hex -> Hex
rotateCw :: Hex -> Hex
rotateCw (Hex Int
q Int
r) = Int -> Int -> Hex
Hex (-Int
r) (-Int -> Int -> Int
s Int
q Int
r)

-- | Rotate counterclockwise by 60°
rotateCcw :: Hex -> Hex
rotateCcw :: Hex -> Hex
rotateCcw (Hex Int
q Int
r) = Int -> Int -> Hex
Hex (-Int -> Int -> Int
s Int
q Int
r) (-Int
q)

-- | Mirror on the origin.
mirror0 :: Hex -> Hex
mirror0 :: Hex -> Hex
mirror0 (Hex Int
q Int
r) = Int -> Int -> Hex
Hex (-Int
q) (-Int
r)

-- | Rotate around a center by a number of 60° angles.
rotateAround
    :: Hex -- ^ Center
    -> Int -- ^ number of 60° rotations. Positive for clockwise (in Cairo coordinates).
    -> Hex -- ^ Point to rotate
    -> Hex
rotateAround :: Hex -> Int -> Hex -> Hex
rotateAround Hex
center Int
n =
    (Hex -> Hex -> Hex
`hexAdd` Hex
center) (Hex -> Hex) -> (Hex -> Hex) -> Hex -> Hex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Hex -> Hex
rotateAround0 Int
n (Hex -> Hex) -> (Hex -> Hex) -> Hex -> Hex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Hex -> Hex -> Hex
`hexSubtract` Hex
center)

-- | Rotate around the origin
rotateAround0 :: Int -> Hex -> Hex
rotateAround0 :: Int -> Hex -> Hex
rotateAround0 Int
n = Int -> Hex -> Hex
forall {a}. (Eq a, Num a, Show a) => a -> Hex -> Hex
go (Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
n Int
6)
  where
    go :: a -> Hex -> Hex
go a
0 = Hex -> Hex
forall a. a -> a
id
    go a
1 = Hex -> Hex
rotateCw
    go a
2 = Hex -> Hex
rotateCw (Hex -> Hex) -> (Hex -> Hex) -> Hex -> Hex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hex -> Hex
rotateCw
    go a
3 = Hex -> Hex
mirror0
    go a
4 = Hex -> Hex
rotateCcw (Hex -> Hex) -> (Hex -> Hex) -> Hex -> Hex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hex -> Hex
rotateCcw
    go a
5 = Hex -> Hex
rotateCcw
    go a
i = String -> String -> Hex -> Hex
forall a. String -> String -> a
bugError String
"Hexagonal.rotateAround0" (String
"Bad modulus in rotateAround, got value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i)

-- | Convert a hexagonal coordinate’s center to an Euclidean 'Vec2'.
toVec2
    :: Double -- ^ Size of a hex cell (radius, side length)
    -> Hex
    -> Vec2
toVec2 :: Double -> Hex -> Vec2
toVec2 Double
size (Hex Int
q Int
r) =
    let q' :: Double
q' = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
q
        r' :: Double
r' = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r
        x :: Double
x = Double
size Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double -> Double
forall a. Floating a => a -> a
sqrt Double
3Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
q' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Floating a => a -> a
sqrt Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
r')
        y :: Double
y = Double
size Double -> Double -> Double
forall a. Num a => a -> a -> a
* (                 Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
r')
    in Double -> Double -> Vec2
Vec2 Double
x Double
y

-- | Convert a Euclidean 'Vec2' to the coordiante of the hexagon it is in.
fromVec2
    :: Double -- ^ Size of a hex cell (radius, side length)
    -> Vec2
    -> Hex
fromVec2 :: Double -> Vec2 -> Hex
fromVec2 Double
size (Vec2 Double
x Double
y) =
    let q', r' :: Double
        q' :: Double
q' = (Double -> Double
forall a. Floating a => a -> a
sqrt Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
size
        r' :: Double
r' = (               Double
2Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
size
    in Double -> Double -> Hex
cubeRound Double
q' Double
r'

-- | 'hexAdd'
instance Semigroup Hex where
    <> :: Hex -> Hex -> Hex
(<>) = Hex -> Hex -> Hex
hexAdd

-- | 'hexZero'
instance Monoid Hex where
    mempty :: Hex
mempty = Hex
hexZero

-- | Given fractional cubical coordinates, yield the hexagon the coordinate is in.
cubeRound :: Double -> Double -> Hex
cubeRound :: Double -> Double -> Hex
cubeRound Double
q' Double
r'  =
    let s' :: Double
s' = -Double
q'Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
r'
        qq,rr,ss :: Int
        qq :: Int
qq = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
q'
        rr :: Int
rr = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
r'
        ss :: Int
ss = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
s'

        -- Rounding all three might violate the invariant that
        -- q+r+s=0, so we calculate the discrepancy and discard
        -- the value that was rounded the most.
        qDiff, rDiff, sDiff :: Double
        qDiff :: Double
qDiff = Double -> Double
forall a. Num a => a -> a
abs (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
qq Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
q')
        rDiff :: Double
rDiff = Double -> Double
forall a. Num a => a -> a
abs (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
rr Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
r')
        sDiff :: Double
sDiff = Double -> Double
forall a. Num a => a -> a
abs (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ss Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
s')
    in if
        -- q had highest diff
        | Double
qDiff Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
rDiff Bool -> Bool -> Bool
&& Double
qDiff Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
sDiff -> Int -> Int -> Hex
Hex (-Int
rrInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
ss) Int
rr
        -- r had highest diff
        | Double
rDiff Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
sDiff                  -> Int -> Int -> Hex
Hex Int
qq (-Int
qqInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
ss)
        -- s is the only one left
        | Bool
otherwise                      -> Int -> Int -> Hex
Hex Int
qq Int
rr

-- | 'Polygon' to match a 'HexagonalCoordinate'. Useful e.g. for collision
-- checking, and of course also for painting. :-)
hexagonPoly :: Double -> Hex -> G.Polygon
hexagonPoly :: Double -> Hex -> Polygon
hexagonPoly Double
sideLength Hex
hex =
    let center :: Vec2
center = Double -> Hex -> Vec2
toVec2 Double
sideLength Hex
hex
    in Transformation -> Polygon -> Polygon
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Vec2 -> Transformation
G.translate Vec2
center Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Double -> Transformation
G.scale Double
sideLength) Polygon
unitHexagon

-- | Hexagon of side length 1, centered around (0,0).
unitHexagon :: G.Polygon
unitHexagon :: Polygon
unitHexagon = [Vec2] -> Polygon
G.Polygon [Angle -> Double -> Vec2
polar (Double -> Angle
deg (Double
30Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
60Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
n)) Double
1 | Double
n <- [Double
0..Double
5]]

-- | Draw a hexagonal coordinate system as a helper grid, similar to
-- 'Draw.cartesianCoordinateSystem'.
hexagonalCoordinateSystem
    :: Double -- ^ Side length of a hexagon (equivalent to its radius)
    -> Int    -- ^ How many hexagons to draw in each direction
    -> C.Render ()
hexagonalCoordinateSystem :: Double -> Int -> Render ()
hexagonalCoordinateSystem Double
sideLength Int
range = do
    let hexagons :: [Hex]
hexagons = Int -> Hex -> [Hex]
hexagonsInRange Int
range Hex
hexZero

    Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
grouped (Double -> Render ()
C.paintWithAlpha Double
0.2) (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
        -- Variable names use Cairo coordinates, i.e. inverted y axis compared to math.

        -- First, we draw the happy path: the left-hand side of all hexagons.
        -- This will leave the ones at the top, bottom and right partially open,
        -- which we fix later.
        Double -> Render ()
C.setLineWidth Double
1
        Double -> Double -> Double -> Render ()
C.setSourceRGB Double
0 Double
0 Double
0
        [Hex] -> (Hex -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Hex]
hexagons ((Hex -> Render ()) -> Render ())
-> (Hex -> Render ()) -> Render ()
forall a b. (a -> b) -> a -> b
$ \hexCoord :: Hex
hexCoord@(Hex Int
q Int
r) -> do
            let center :: Vec2
center = Double -> Hex -> Vec2
toVec2 Double
sideLength Hex
hexCoord
                bottomCorner :: Vec2
bottomCorner = Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
0 Double
sideLength
                rotateCW :: Double -> Transformation
rotateCW Double
degrees = Vec2 -> Angle -> Transformation
G.rotateAround Vec2
center (Double -> Angle
deg Double
degrees)
                corner :: Double -> Vec2
corner Double
i = Transformation -> Vec2 -> Vec2
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Double -> Transformation
rotateCW (Double
iDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
60)) Vec2
bottomCorner
            if
                -- Rightmost corner: the only full hexagon, woo!
                | Int
q Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
range Bool -> Bool -> Bool
&& Int -> Int -> Int
s Int
q Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
range -> Polygon -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Polygon -> Render ()) -> Polygon -> Render ()
forall a b. (a -> b) -> a -> b
$ [Vec2] -> Polygon
G.Polygon [Double -> Vec2
corner Double
i | Double
i <- [Double
0, Double
1, Double
2, Double
3, Double
4, Double
5]]
                -- Upper right boundary
                | Int
q Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
range                -> Polyline -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Polyline -> Render ()) -> Polyline -> Render ()
forall a b. (a -> b) -> a -> b
$ [Vec2] -> Polyline
Polyline [Double -> Vec2
corner Double
i | Double
i <- [Double
0, Double
1, Double
2, Double
3, Double
4, Double
5]]
                -- Lower right boundary
                | Int -> Int -> Int
s Int
q Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
range           -> Polyline -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Polyline -> Render ()) -> Polyline -> Render ()
forall a b. (a -> b) -> a -> b
$ [Vec2] -> Polyline
Polyline [Double -> Vec2
corner Double
i | Double
i <- [-Double
2, -Double
1, Double
0, Double
1, Double
2, Double
3]]
                -- Upper boundary
                | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
range               -> Polyline -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Polyline -> Render ()) -> Polyline -> Render ()
forall a b. (a -> b) -> a -> b
$ [Vec2] -> Polyline
Polyline [Double -> Vec2
corner Double
i | Double
i <- [Double
0, Double
1, Double
2, Double
3, Double
4]]
                -- Lower boundary
                | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
range                -> Polyline -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Polyline -> Render ()) -> Polyline -> Render ()
forall a b. (a -> b) -> a -> b
$ [Vec2] -> Polyline
Polyline [Double -> Vec2
corner Double
i | Double
i <- [-Double
1, Double
0, Double
1, Double
2, Double
3]]
                | Bool
otherwise                 -> Polyline -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Polyline -> Render ()) -> Polyline -> Render ()
forall a b. (a -> b) -> a -> b
$ [Vec2] -> Polyline
Polyline [Double -> Vec2
corner Double
i | Double
i <- [Double
0, Double
1, Double
2, Double
3]]
            Bool -> Render () -> Render ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Hex
hexCoord Hex -> Hex -> Bool
forall a. Eq a => a -> a -> Bool
== Hex
hexZero) (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
                let centerHexagon :: Polygon
centerHexagon = [Vec2] -> Polygon
G.Polygon [Double -> Vec2
corner Double
i | Double
i <- [Double
0, Double
1, Double
2, Double
3, Double
4, Double
5]]
                Polygon -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Transformation -> Polygon -> Polygon
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Vec2 -> Double -> Transformation
G.scaleAround Vec2
forall v. VectorSpace v => v
zero Double
0.9) Polygon
centerHexagon)
                Polygon -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Transformation -> Polygon -> Polygon
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Vec2 -> Double -> Transformation
G.scaleAround Vec2
forall v. VectorSpace v => v
zero Double
1.1) Polygon
centerHexagon)
            Render ()
C.stroke

    Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
grouped (Double -> Render ()
C.paintWithAlpha Double
0.5) (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$
        [Hex] -> (Hex -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Hex]
hexagons ((Hex -> Render ()) -> Render ())
-> (Hex -> Render ()) -> Render ()
forall a b. (a -> b) -> a -> b
$ \hexCoord :: Hex
hexCoord@(Hex Int
q Int
r) ->
            [(String, Int, Double)]
-> ((String, Int, Double) -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(String
"q" :: String, Int
q, Double
120), (String
"r", Int
r, Double
240), (String
"s", Int -> Int -> Int
s Int
q Int
r, Double
0)] (((String, Int, Double) -> Render ()) -> Render ())
-> ((String, Int, Double) -> Render ()) -> Render ()
forall a b. (a -> b) -> a -> b
$ \(String
name, Int
val, Double
angle) -> Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
                let center :: Vec2
center = Double -> Hex -> Vec2
toVec2 Double
sideLength Hex
hexCoord
                    coord :: Vec2
coord = Transformation -> Vec2 -> Vec2
forall geo. Transform geo => Transformation -> geo -> geo
G.transform (Vec2 -> Double -> Transformation
scaleAround Vec2
center Double
0.2 Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Vec2 -> Angle -> Transformation
G.rotateAround Vec2
center (Double -> Angle
deg Double
angle)) (Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
0 Double
sideLength)
                Vec2 -> Render ()
moveToVec Vec2
coord
                AlphaColor Double -> Render ()
forall color. CairoColor color => color -> Render ()
setColor (Double -> Double -> Double -> Double -> AlphaColor Double
hsva Double
angle Double
1 Double
0.7 Double
1)
                if Int -> Int -> Hex
Hex Int
q Int
r Hex -> Hex -> Bool
forall a. Eq a => a -> a -> Bool
== Hex
hexZero
                    then Render () -> Render ()
forall a. Render a -> Render a
cairoScope (Double -> Render ()
C.setFontSize Double
14 Render () -> Render () -> Render ()
forall after a. Render after -> Render a -> Render a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HAlign -> VAlign -> String -> Render ()
forall string.
CairoString string =>
HAlign -> VAlign -> string -> Render ()
showTextAligned HAlign
HCenter VAlign
VCenter String
name)
                    else HAlign -> VAlign -> String -> Render ()
forall string.
CairoString string =>
HAlign -> VAlign -> string -> Render ()
showTextAligned HAlign
HCenter VAlign
VCenter (Int -> String
forall a. Show a => a -> String
show Int
val)

-- | Hexagons reachable within a number of steps from the origin. The boundary of
-- this will be the 'ring'.
hexagonsInRange :: Int -> Hex -> [Hex]
hexagonsInRange :: Int -> Hex -> [Hex]
hexagonsInRange Int
range Hex
center = do
    Int
q <- [-Int
range,-Int
rangeInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..Int
range]
    let rMin :: Int
rMin = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (-Int
range) (-Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
range)
        rMax :: Int
rMax = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
range (-Int
qInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
range)
    Int
r <- [Int
rMin, Int
rMinInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 .. Int
rMax]
    Hex -> [Hex]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Hex
Hex Int
q Int
r Hex -> Hex -> Hex
`hexAdd` Hex
center)

-- | Linearly interpolate between two 'Hex'.
cubeLerp
    :: Hex    -- ^ Start
    -> Hex    -- ^ End
    -> Double -- [0..1] yields [start..end]
    -> Hex
cubeLerp :: Hex -> Hex -> Double -> Hex
cubeLerp (Hex Int
q1 Int
r1) (Hex Int
q2 Int
r2) Double
t =
    Double -> Double -> Hex
cubeRound
        ((Double, Double) -> (Double, Double) -> Double -> Double
forall vec.
VectorSpace vec =>
(Double, Double) -> (vec, vec) -> Double -> vec
lerp (Double
0,Double
1) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
q1, Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
q2) Double
t)
        ((Double, Double) -> (Double, Double) -> Double -> Double
forall vec.
VectorSpace vec =>
(Double, Double) -> (vec, vec) -> Double -> vec
lerp (Double
0,Double
1) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r1, Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r2) Double
t)

-- | Line between two 'Hex'.
--
-- <<docs/haddock/Geometry/Coordinates/Hexagonal/line.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Coordinates/Hexagonal/line.svg" 300 200 $ \_ -> do
--     let cellSize = 20
--         canvas = shrinkBoundingBox 10 [zero, Vec2 300 200]
--         hexes = line hexZero (move R 5 (move UR 3 hexZero))
--         polygons = map (shrinkPolygon 1 . hexagonPoly cellSize) hexes
--         fitToCanvas = transform (transformBoundingBox polygons canvas def)
--     for_ polygons $ \polygon -> cairoScope $ do
--         sketch (fitToCanvas polygon)
--         setColor (mma 0 `withOpacity` 0.3)
--         C.fillPreserve
--         setColor (mma 0 `withOpacity` 0.5)
--         C.stroke
-- :}
-- Generated file: size 6KB, crc32: 0x5ec289a8
line :: Hex -> Hex -> [Hex]
line :: Hex -> Hex -> [Hex]
line Hex
start Hex
end =
    let d :: Int
d = Hex -> Hex -> Int
distance Hex
start Hex
end
    in [ Hex -> Hex -> Double -> Hex
cubeLerp Hex
start Hex
end (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) | Int
i <- [Int
0..Int
d] ]

-- | All 'Hex' reachable only with one exact number of steps. 'floodFill'ing it
-- will yield 'hexagonsInRange'.
--
-- <<docs/haddock/Geometry/Coordinates/Hexagonal/ring.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Coordinates/Hexagonal/ring.svg" 200 200 $ \_ -> do
--     let cellSize = 20
--         canvas = shrinkBoundingBox 10 [zero, Vec2 200 200]
--         hexes = ring 2 hexZero
--         polygons = map (shrinkPolygon 1 . hexagonPoly cellSize) hexes
--         fitToCanvas = transform (transformBoundingBox polygons canvas def)
--     for_ polygons $ \polygon -> cairoScope $ do
--         sketch (fitToCanvas polygon)
--         setColor (mma 1 `withOpacity` 0.3)
--         C.fillPreserve
--         setColor (mma 1 `withOpacity` 0.5)
--         C.stroke
-- :}
-- Generated file: size 7KB, crc32: 0xacce7f95
ring
    :: Int -- ^ Radius
    -> Hex -- ^ Center
    -> [Hex]
ring :: Int -> Hex -> [Hex]
ring Int
n Hex
center = do
    (Direction
startDir, Direction
walkDir) <- [Direction] -> [Direction] -> [(Direction, Direction)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Direction
R, Direction
UR, Direction
UL, Direction
L, Direction
DL, Direction
DR] [Direction
UL, Direction
L, Direction
DL, Direction
DR, Direction
R, Direction
UR]
    let start :: Hex
start = Direction -> Int -> Hex -> Hex
move Direction
startDir Int
n Hex
center
    [ Direction -> Int -> Hex -> Hex
move Direction
walkDir Int
i Hex
start | Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]

newtype HexPolygon = HexPolygon [Hex]
    deriving (HexPolygon -> HexPolygon -> Bool
(HexPolygon -> HexPolygon -> Bool)
-> (HexPolygon -> HexPolygon -> Bool) -> Eq HexPolygon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HexPolygon -> HexPolygon -> Bool
== :: HexPolygon -> HexPolygon -> Bool
$c/= :: HexPolygon -> HexPolygon -> Bool
/= :: HexPolygon -> HexPolygon -> Bool
Eq, Eq HexPolygon
Eq HexPolygon
-> (HexPolygon -> HexPolygon -> Ordering)
-> (HexPolygon -> HexPolygon -> Bool)
-> (HexPolygon -> HexPolygon -> Bool)
-> (HexPolygon -> HexPolygon -> Bool)
-> (HexPolygon -> HexPolygon -> Bool)
-> (HexPolygon -> HexPolygon -> HexPolygon)
-> (HexPolygon -> HexPolygon -> HexPolygon)
-> Ord HexPolygon
HexPolygon -> HexPolygon -> Bool
HexPolygon -> HexPolygon -> Ordering
HexPolygon -> HexPolygon -> HexPolygon
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HexPolygon -> HexPolygon -> Ordering
compare :: HexPolygon -> HexPolygon -> Ordering
$c< :: HexPolygon -> HexPolygon -> Bool
< :: HexPolygon -> HexPolygon -> Bool
$c<= :: HexPolygon -> HexPolygon -> Bool
<= :: HexPolygon -> HexPolygon -> Bool
$c> :: HexPolygon -> HexPolygon -> Bool
> :: HexPolygon -> HexPolygon -> Bool
$c>= :: HexPolygon -> HexPolygon -> Bool
>= :: HexPolygon -> HexPolygon -> Bool
$cmax :: HexPolygon -> HexPolygon -> HexPolygon
max :: HexPolygon -> HexPolygon -> HexPolygon
$cmin :: HexPolygon -> HexPolygon -> HexPolygon
min :: HexPolygon -> HexPolygon -> HexPolygon
Ord, Int -> HexPolygon -> ShowS
[HexPolygon] -> ShowS
HexPolygon -> String
(Int -> HexPolygon -> ShowS)
-> (HexPolygon -> String)
-> ([HexPolygon] -> ShowS)
-> Show HexPolygon
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HexPolygon -> ShowS
showsPrec :: Int -> HexPolygon -> ShowS
$cshow :: HexPolygon -> String
show :: HexPolygon -> String
$cshowList :: [HexPolygon] -> ShowS
showList :: [HexPolygon] -> ShowS
Show)

-- | Given a hexagonal polygon, is the 'Hex' on its edge?
isOnEdge :: Hex -> HexPolygon -> Bool
isOnEdge :: Hex -> HexPolygon -> Bool
isOnEdge Hex
hex (HexPolygon [Hex]
corners) =
    let edges :: [Hex]
edges = [[Hex]] -> [Hex]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Hex -> Hex -> [Hex]) -> [Hex] -> [Hex] -> [[Hex]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Hex -> Hex -> [Hex]
line [Hex]
corners ([Hex] -> [Hex]
forall a. HasCallStack => [a] -> [a]
tail ([Hex] -> [Hex]
forall a. HasCallStack => [a] -> [a]
cycle [Hex]
corners)))
    in Maybe Hex -> Bool
forall a. Maybe a -> Bool
isJust ((Hex -> Bool) -> [Hex] -> Maybe Hex
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Hex -> Hex -> Bool
forall a. Eq a => a -> a -> Bool
== Hex
hex) [Hex]
edges)

-- | Is the 'Hex' inside the polygon (including its edge)?
pointInPolygon :: Hex -> HexPolygon -> Bool
pointInPolygon :: Hex -> HexPolygon -> Bool
pointInPolygon Hex
hex polygon :: HexPolygon
polygon@(HexPolygon [Hex]
corners) = Bool
onEdge Bool -> Bool -> Bool
|| Bool
inside
  where
    -- | This elimintes numerical instabilities
    onEdge :: Bool
onEdge = Hex -> HexPolygon -> Bool
isOnEdge Hex
hex HexPolygon
polygon

    -- This feels like cheating
    inside :: Bool
inside = Vec2 -> Polygon -> Bool
G.pointInPolygon (Double -> Hex -> Vec2
toVec2 Double
1 Hex
hex) ([Vec2] -> Polygon
G.Polygon ((Hex -> Vec2) -> [Hex] -> [Vec2]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Hex -> Vec2
toVec2 Double
1) [Hex]
corners))

-- | All points on a polygon’s edge.
edgePoints :: HexPolygon -> S.Set Hex
edgePoints :: HexPolygon -> Set Hex
edgePoints (HexPolygon [Hex]
corners) = [Hex] -> Set Hex
forall a. Ord a => [a] -> Set a
S.fromList ([[Hex]] -> [Hex]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Hex -> Hex -> [Hex]) -> [Hex] -> [Hex] -> [[Hex]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Hex -> Hex -> [Hex]
line [Hex]
corners ([Hex] -> [Hex]
forall a. HasCallStack => [a] -> [a]
tail ([Hex] -> [Hex]
forall a. HasCallStack => [a] -> [a]
cycle [Hex]
corners))))

-- | Sketch a hexagonal polygon.
polygonSketch
    :: Double -- ^ Cell size
    -> HexPolygon
    -> C.Render ()
polygonSketch :: Double -> HexPolygon -> Render ()
polygonSketch Double
cellSize HexPolygon
polygon =
    Set Hex -> (Hex -> Render ()) -> Render ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (HexPolygon -> Set Hex
edgePoints HexPolygon
polygon) ((Hex -> Render ()) -> Render ())
-> (Hex -> Render ()) -> Render ()
forall a b. (a -> b) -> a -> b
$ \Hex
hex ->
        Polygon -> Render ()
forall a. Sketch a => a -> Render ()
sketch (Double -> Hex -> Polygon
hexagonPoly Double
cellSize Hex
hex)

-- | Fill all neighbours of a point, and their neighbours, and…

-- Diverges if the geometry is not closed, or the starting point is not contained
-- in it!
floodFill
    :: Hex -- ^ Starting point
    -> Set Hex
    -> Set Hex
floodFill :: Hex -> Set Hex -> Set Hex
floodFill Hex
p = Set Hex -> Set Hex -> Set Hex
go (Hex -> Set Hex
forall a. a -> Set a
S.singleton Hex
p)
  where
    go :: Set Hex -> Set Hex -> Set Hex
    go :: Set Hex -> Set Hex -> Set Hex
go Set Hex
toVisit Set Hex
filled = case Set Hex -> Maybe (Hex, Set Hex)
forall a. Set a -> Maybe (a, Set a)
S.minView Set Hex
toVisit of
        Maybe (Hex, Set Hex)
Nothing -> Set Hex
filled
        Just (Hex
hex, Set Hex
rest) ->
            let neighbours :: Set Hex
neighbours = [Hex] -> Set Hex
forall a. Ord a => [a] -> Set a
S.fromList (Int -> Hex -> [Hex]
ring Int
1 Hex
hex)
                filled' :: Set Hex
filled' = Set Hex
filled Set Hex -> Set Hex -> Set Hex
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Hex
neighbours
                toVisit' :: Set Hex
toVisit' = Set Hex
rest Set Hex -> Set Hex -> Set Hex
forall a. Ord a => Set a -> Set a -> Set a
`S.union` (Set Hex
neighbours Set Hex -> Set Hex -> Set Hex
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Hex
filled)
            in Set Hex -> Set Hex -> Set Hex
go Set Hex
toVisit' Set Hex
filled'