SevenTasks.hs

{-# LANGUAGE RecursiveDo, ScopedTypeVariables, FlexibleContexts #-}

import Reflex.Dom
import Data.Monoid
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map

insertNew_ :: (Enum k, Ord k) => v -> Map k v -> Map k v
insertNew_ v m = case Map.maxViewWithKey m of
  Nothing -> Map.singleton (toEnum 0) v
  Just ((k, _), _) -> Map.insert (succ k) v m

main = mainWidget circles

circles :: forall t m. MonadWidget t m => m ()
circles = do
  let svgns = Just "http://www.w3.org/2000/svg"
  changeSize <- el "div" $ do
    bigger <- button "Bigger"
    smaller <- button "Smaller"
    return $ leftmost [ (5 :: Int) <$ bigger
                      , (-5) <$ smaller
                      ]
  rec mousePos <- holdDyn (-1, -1) (domEvent Mousemove svg)
      (svg, _) <- elDynAttrNS' svgns "svg" (constDyn $ "width" =: "1000" <> "height" =: "1000") $ do
        rec let circle :: Int -> Dynamic t (Int, Int) -> m (Event t ())
                circle k pos = do
                  let unselected = "yellow"
                      selected = "green"
                      staticAttrs = "stroke" =: "green" <> "stroke-width" =: "4"
                  isSelected <- getDemuxed selectedKey k
                  size <- foldDyn (+) 40 $ gate (current isSelected) changeSize
                  attrs <- combineDyn (\(x, y) (sz, sel) -> staticAttrs <> "cx" =: show x <> "cy" =: show y <> "r" =: show sz <> "fill" =: if sel then selected else unselected) pos =<< combineDyn (,) size isSelected
                  (c, _) <- elStopPropagationNS svgns "g" Click $ elDynAttrNS' svgns "circle" attrs $ return ()
                  return $ domEvent Click c
            stuff <- foldDyn ($) (Map.empty :: Map Int (Int, Int)) $ attachWith (\pos _ -> insertNew_ pos) (current mousePos) (domEvent Click svg)
            circleSelectors <- listWithKey stuff circle
            selectedKey <- liftM demux $ holdDyn (-1) $ switch $ fmap (leftmost . map (\(k, v) -> k <$ v) . Map.toList) $ current circleSelectors
        return ()
  return ()

temperatureConverter :: MonadWidget t m => m ()
temperatureConverter = do
  rec a <- textInput $ def & setValue .~ fmap reverse (_textInput_input b)
      b <- textInput $ def & setValue .~ fmap reverse (_textInput_input a)
  return ()