Data commit

Task/Honeycombs/Haskell/honeycombs.hs

@@ -0,0 +1,141 @@
+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)