141 lines
4.6 KiB
Haskell
141 lines
4.6 KiB
Haskell
import Data.Char (toUpper)
|
|
import Data.Function (on)
|
|
import Data.List (zipWith4)
|
|
import System.Exit
|
|
import System.Random
|
|
|
|
-- External libraries.
|
|
import Graphics.Gloss
|
|
import Graphics.Gloss.Data.Vector
|
|
import Graphics.Gloss.Geometry
|
|
import Graphics.Gloss.Interface.IO.Game
|
|
import System.Random.Shuffle
|
|
|
|
-- A record of a hexagon-letter.
|
|
data Hex =
|
|
Hex
|
|
{ hLetter :: Char -- The letter it holds.
|
|
, hSelected :: Bool -- The flag for if the hexagon has been selected.
|
|
, hPath :: Path -- The hexagon's vertices.
|
|
, hCenter :: Point -- The center of the hexagon.
|
|
}
|
|
|
|
-- A record of the world state.
|
|
data World =
|
|
World
|
|
{ wHexes :: [Hex] -- The hexagons to interact with.
|
|
, wString :: String -- An ordering of picked letters.
|
|
}
|
|
|
|
-- Assorted helper functions.
|
|
addV, subV :: Vector -> Vector -> Vector
|
|
addV (a, b) (x, y) = (a + x, b + y)
|
|
subV (a, b) (x, y) = (a - x, b - y)
|
|
|
|
translateP :: Vector -> Path -> Path
|
|
translateP v = map (addV v)
|
|
|
|
translateV :: Vector -> Picture -> Picture
|
|
translateV (x, y) p = translate x y p
|
|
|
|
lightblue, darkblue :: Color
|
|
lightblue = makeColor 0.5 0.5 1.0 1.0
|
|
darkblue = makeColor 0.0 0.0 0.5 1.0
|
|
|
|
-- Create vertices for an n-gon with the given radius to a vertex
|
|
ngon :: Int -> Float -> Path
|
|
ngon n radius =
|
|
let angle = 2 * pi / fromIntegral n
|
|
in map (mulSV radius . unitVectorAtAngle . (* angle) . fromIntegral)
|
|
[0..(n - 1)]
|
|
|
|
-- Determine if a point lies on or within a polygon.
|
|
inPolygon :: Point -> Path -> Bool
|
|
inPolygon point path =
|
|
all (>= 0) $ zipWith detV vas vbs
|
|
where
|
|
vas = zipWith subV (drop 1 $ cycle path) path
|
|
vbs = map (subV point) path
|
|
|
|
-- Construct all of the hexagons transformed to their screen coordinates
|
|
-- to make mouse picking easier to solve.
|
|
mkHexes :: RandomGen g => g -> Float -> World
|
|
mkHexes gen radius = World hexes ""
|
|
where
|
|
letters = take 20 $ shuffle' ['A'..'Z'] 26 gen
|
|
xs = concatMap (replicate 4) [-2..2]
|
|
ys = cycle [-2..1]
|
|
inRad = radius * (cos $ degToRad 30)
|
|
yOff x = if ((floor x) :: Int) `mod` 2 == 0 then inRad else 0
|
|
yStep = inRad * 2
|
|
xStep = radius * 1.5
|
|
centers = zipWith (\x y -> (x * xStep, yOff x + y * yStep)) xs ys
|
|
paths = map (flip translateP $ ngon 6 radius) centers
|
|
hexes = zipWith4 Hex letters (repeat False) paths centers
|
|
|
|
-- Draw a single hexagon-letter.
|
|
drawHex :: Hex -> Picture
|
|
drawHex (Hex letter selected path center) =
|
|
pictures [hex, outline, letterPic]
|
|
where
|
|
hex = color hcolor $ polygon path
|
|
outline = color blue $ lineLoop path
|
|
letterPic = color lcolor
|
|
$ translateV (addV (-10, -10) center)
|
|
$ scale 0.25 0.25
|
|
$ text [letter]
|
|
(hcolor, lcolor) = if selected
|
|
then (darkblue, white)
|
|
else (lightblue, black)
|
|
|
|
-- Draw the whole scene.
|
|
drawWorld :: World -> Picture
|
|
drawWorld (World hexes string) =
|
|
pictures [pictures $ map drawHex hexes
|
|
,pictures $ map drawHighHex hexes
|
|
,color (light lightblue) $ textPic
|
|
,scale 1.05 1.05 $ textPic]
|
|
where
|
|
drawHighHex hex = color black $ scale 1.05 1.05 $ lineLoop $ hPath hex
|
|
textPic = translateV (-130, -175) $ scale 0.15 0.15 $ text string
|
|
|
|
-- Handle keyboard and mouse events and update the hexagons
|
|
-- accordingly. This function checks the hexagon states and
|
|
-- invokes a system exit when all are marked selected.
|
|
handleInput :: Event -> World -> IO World
|
|
handleInput event world@(World hexes string) =
|
|
case event of
|
|
EventKey key Down _ point ->
|
|
case key of
|
|
SpecialKey KeyEsc -> exitSuccess
|
|
Char char -> hCond (\hex -> hLetter hex == toUpper char)
|
|
MouseButton _ -> hCond (\hex -> inPolygon point $ hPath hex)
|
|
_ -> return world
|
|
_ ->
|
|
return world
|
|
where
|
|
checkWorld w = if all hSelected $ wHexes w then exitSuccess else return w
|
|
hCond cond = checkWorld $ World newHexes newString
|
|
where
|
|
newHexes = flip map hexes
|
|
(\hex -> if cond hex
|
|
then hex {hSelected = True}
|
|
else hex)
|
|
diff = map fst
|
|
$ filter (uncurry ((/=) `on` hSelected))
|
|
$ zip hexes newHexes
|
|
newString = case diff of
|
|
[] -> string
|
|
(hex:_) -> string ++ [hLetter hex]
|
|
|
|
main :: IO ()
|
|
main = do
|
|
stdGen <- getStdGen
|
|
playIO
|
|
(InWindow "Honeycombs" (500, 500) (100, 100))
|
|
white
|
|
60
|
|
(mkHexes stdGen 30)
|
|
(return . drawWorld)
|
|
handleInput
|
|
(\_ x -> return x)
|