content: 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)
  