import Data.Char (toUpper)
import Data.Function (on)
import Data.List (zipWith4)
import System.Exit
import System.Random


import Graphics.Gloss
import Graphics.Gloss.Data.Vector
import Graphics.Gloss.Geometry
import Graphics.Gloss.Interface.IO.Game
import System.Random.Shuffle


data Hex =
  Hex
  { hLetter   :: Char  
  , hSelected :: Bool  
  , hPath     :: Path  
  , hCenter   :: Point 
  }


data World =
  World
  { wHexes  :: [Hex]  
  , wString :: String 
  }


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


ngon :: Int -> Float -> Path
ngon n radius =
  let angle = 2 * pi / fromIntegral n
  in map (mulSV radius . unitVectorAtAngle . (* angle) . fromIntegral)
     [0..(n - 1)]


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



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


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)


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




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)