helmlenses.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}

import Control.Applicative
import FRP.Elerea.Simple
import GHC.Float
import FRP.Helm hiding (join, x, y)
import Control.Monad
import Control.Arrow ((&&&), first, second)
import Control.Lens
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import System.IO.Unsafe 
import qualified FRP.Helm.Keyboard as Keyboard
import qualified FRP.Helm.Window as Window

type Vector = (Float, Float)
instance (Num a, Num b) => Num (a,b) where
  (x,y) + (x2,y2) = (x + x2, y + y2)
  (x,y) - (x2,y2) = (x - x2, y - y2)
  (*) = undefined
  abs = abs.fst &&& abs.snd
  negate = negate.fst &&& negate.snd
  signum = signum.fst &&& signum.snd
  fromInteger = fromInteger &&& fromInteger
  
(|*|) = \(x,y) -> ((*x) &&& (*y))
both f (x,y) = (f x, f y)

data Entity = Entity
  { _position :: Vector
  }

data World = World
  { _ent :: Entity
  }

makeLenses ''World
makeLenses ''Entity

x,y :: Lens' Entity Float
x = lens (fst . _position) (\entity v -> Entity {_position = (v, fst . _position $ entity) })
y = lens (snd . _position) (\entity v -> Entity {_position = (snd . _position $ entity, v) })

render :: (Int, Int) -> World -> Element
render (w,h) wrld = collage w h [move (float2Double (wrld^.ent.x), float2Double (wrld^.ent.y)) $ filled white $ square 100]

main :: IO ()
main = run $ do
  dimensions <- Window.dimensions
  world <- stateful initWorld (\a -> unsafePerformIO $ execStateT update a)
  
  return $ render <$> dimensions <*> world

initWorld :: World
initWorld = World {_ent = Entity (0,0)}

liftSignal :: SignalGen (Signal a) -> StateT s IO a
liftSignal = lift . join . start

update :: StateT World IO ()
update = do
  arrows <- liftSignal Keyboard.arrows
  ent.position += both int2Float arrows