Hoodlums meetup 13 Jul 2017

lights.cabal

name:                lights
version:             0.1.0.0
-- synopsis:
-- description:
license:             BSD3
license-file:        LICENSE
copyright:           All Rights Reserved
category:            Web
build-type:          Simple
extra-source-files:  README.md
cabal-version:       >=1.10


executable lights
  hs-source-dirs:      app
  main-is:             Main.hs
  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
  build-depends:       base
                     , async
                     , containers
                     , threepenny-gui
  default-language:    Haskell2010

Main.hs

{-# LANGUAGE PartialTypeSignatures#-}

import Prelude hiding (lookup)
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad  (void)
import Data.List      (isPrefixOf)
import Data.Maybe
import Data.Monoid
import Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Core hiding (delete)
import Text.Printf


{-----------------------------------------------------------------------------
    Main
------------------------------------------------------------------------------}
main :: IO ()
main = void run

run = do
  triggerV <- newEmptyMVar
  async $ startGUI defaultConfig{jsStatic= Just "static"} (setup triggerV)
  takeMVar triggerV

setup :: MVar _ -> Window -> UI _
setup triggerV window =
  void $ do
    addStyleSheet window "style.css"
    t <- timer # set interval 40
    start t
    (timeFunctionEvent, trigger) <- liftIO newEvent
    liftIO $ putMVar triggerV trigger
    timeFunctionValue <- accumB (\fn n -> "black") timeFunctionEvent
    frame <- accumB 0 (const succ <$> tick t)
    let colors = ["red", "green", "yellow", "blue"]
    let colorValue n = (\f t -> f t n) <$> timeFunctionValue <*> frame
    getBody window #+
      [ grid
          [ [ createLight (colorValue (row + col * 10))
            | col <- [0..3]
            ]
          | row <- [0..9]
          ]
      ]
  where
    createLight :: Behavior String -> UI Element
    createLight color =
      let style =
            (\v ->
               [ ("background-color", v)
               ]) <$>
            color
      in new # UI.sink UI.style style #. "light"

rgb :: Integer -> Integer -> Integer -> String
rgb r g b = printf "#%02x%02x%02x" (r `mod` 256) (g `mod` 256) (b `mod` 256)
gray x = rgb x x x