Anonymous user
Honeycombs: Difference between revisions
Add Haskell - Honeycombs
m (Added Java 8 version) |
(Add Haskell - Honeycombs) |
||
Line 978:
</Window></lang>
[[File:CSharpHoneycomb.jpg]]
=={{header|Haskell}}==
{{libheader|gloss}}
{{libheader|random-shuffle}}
<lang 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)</lang>
=={{header|Icon}} and {{header|Unicon}}==
| |||