The task is to produce a matrix of 20 hexagon shaped widgets in a honeycomb arrangement. The matrix should be arranged in such a manner that there are five
columns of four hexagons. The hexagons in columns one, three and five are aligned horizontally, whereas the hexagons in columns two and four occupy a lower position within the arrangement. Each hexagon should be the same colour, and should
display a unique randomly selected single capital letter on the front. The application should now wait for the user to select a hexagon, either by using a pointing device, or by pressing a key that carries a corresponding letter on a hexagon. For platforms that support pointing devices and keyboards, the application should support both methods of selection. A record of the chosen letters should be maintained and the code should be suitably commented, at the point where the the selected letter has been determined. The selected hexagon should now change colour on the display. The cycle repeats until the user has chosen all of the letters. Note that each letter can only be selected once and previously selected hexagons retain their colour after selection. The program terminates when all letters have been chosen.

Optionally: output the list of selected letters and show the last selected letter, cater for a different number of columns or a different number of hexagons in each column, cater for two players, (turns alternate and the hexagons change a different colour depending on whether they were selected by player one or player two and records of both players selections are maintained.)



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)