module SneathLane
(
Widget(..),
WidgetFocus(..),
zipW,
graphicWidget,
above,
beside,
runOnCanvas,
GraphicTree(..),
graphicList,
graphicTreeBounds,
MouseButton(..),
Key,
balancedFold,
Output,
CombineGraphics,
Animate,
MouseOut,
HandleKey,
TimeDifference
)
where
import Control.Applicative (Applicative(..), liftA2)
import Control.Monad (mplus)
import Data.Functor ((<$))
import Data.Maybe (fromMaybe)
import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef)
import Haste (elemById, writeLog, onEvent, setTimeout, focus, blur, mkCallback, attr, style, set, (=:), Event (..), Elem, JSFun, JSString)
import Haste.Foreign (ffi)
import SneathLane.Graphics
data MouseButton = NoButton | LeftButton
type Key = Int
data GraphicTree :: * -> * where
Offset :: Point -> GraphicTree a -> GraphicTree a
Branch :: Rect -> GraphicTree a -> Rect -> GraphicTree a -> GraphicTree a
Leaf :: Graphic -> GraphicTree ()
FMap :: (a -> b) -> GraphicTree a -> GraphicTree b
instance Functor GraphicTree where
fmap = FMap
graphicList :: [Graphic] -> GraphicTree ()
graphicList gs = balancedFold (\g g' -> Branch (graphicTreeBounds g) g (graphicTreeBounds g') g') (map (\g -> Leaf g) gs)
balancedFold :: (a -> a -> a) -> [a] -> a
balancedFold _ [] = error "balancedFold: empty list"
balancedFold _ [x] = x
balancedFold fn xs = balancedFold fn (combinePairs xs)
where
combinePairs [] = []
combinePairs [x] = [x]
combinePairs (x:y:xs') = fn x y : combinePairs xs'
graphicAtPoint :: Point -> GraphicTree a -> Maybe (Point, a)
graphicAtPoint (x,y) gt = case gt of
Offset (x',y') gt' -> graphicAtPoint (x x', y y') gt'
Branch bounds gt' bounds' gt'' ->
case ((x,y) `inRect` bounds, (x,y) `inRect` bounds') of
(False, False) -> Nothing
(False, True) -> graphicAtPoint (x,y) gt''
(True, False) -> graphicAtPoint (x,y) gt'
(True, True) -> graphicAtPoint (x,y) gt'' `mplus` graphicAtPoint (x,y) gt'
Leaf g -> if (x,y) `inGraphic` g then Just ((x,y), ()) else Nothing
FMap fn gt' -> fmap (\(pt,a) -> (pt, fn a)) (graphicAtPoint (x,y) gt')
drawGraphicTree :: Canvas -> GraphicTree a -> IO ()
drawGraphicTree canv gt = render canv $ go (0,0) gt
where
go :: Point -> GraphicTree a -> Picture ()
go (x,y) (Offset (x',y') gt') = go (x + x', y + y') gt'
go pt (Branch _ gt' _ gt'') = go pt gt' >> go pt gt''
go pt (FMap _ gt') = go pt gt'
go pt (Leaf g) = drawGraphic g pt
graphicTreeBounds :: GraphicTree a -> Rect
graphicTreeBounds gt = case gt of
Offset (x,y) gt' -> let (Rect x' y' w h) = graphicTreeBounds gt' in Rect (x+x') (y+y') w h
Branch (Rect x y w h) _ (Rect x' y' w' h') _ -> Rect (min x x') (min y y') (max (x + w) (x' + w') min x x') (max (y + h) (y' + h') min y y')
FMap _ gt' -> graphicTreeBounds gt'
Leaf g -> graphicBounds g
type Output a = GraphicTree ((Point,MouseButton) -> a)
type MouseOut a = a
type HandleKey a = Key -> a
type TimeDifference = Double
type Animate a = TimeDifference -> a
data Widget z = Finish z
| Continue (Output (Widget z)) (Maybe (MouseOut (Widget z))) (Maybe (Animate (Widget z))) (WidgetFocus z)
data WidgetFocus z = NotFocusable
| Focusable (Widget z) (Widget z)
| Focused (Widget z) (Widget z, Bool) (Widget z, Bool) (HandleKey (Widget z))
type CombineGraphics a = GraphicTree a -> GraphicTree a -> GraphicTree a
zipW :: CombineGraphics ((Point, MouseButton) -> Widget z) -> Widget z -> Widget z -> Widget z
bindW :: (a -> Widget b) -> Widget a -> Widget b
bindW fn (Finish w) = fn w
bindW fn (Continue out mouseOut anim foc) =
let
out' = (fmap.fmap) (bindW fn) out
mouseOut' = fmap (bindW fn) mouseOut
anim' = (fmap.fmap) (bindW fn) anim
foc' = case foc of
NotFocusable -> NotFocusable
Focusable fromLeft fromRight -> Focusable (bindW fn fromLeft) (bindW fn fromRight)
Focused blur (tabLeft,ld) (tabRight,rd) key -> Focused (bindW fn blur) (bindW fn tabLeft,ld) (bindW fn tabRight,rd) (fmap (bindW fn) key)
in Continue out' mouseOut' anim' foc'
instance Functor Widget where
fmap fn = bindW (Finish . fn)
instance Applicative Widget where
pure = Finish
(<*>) wf w = bindW (\fn -> bindW (Finish . fn) w) wf
instance Monad Widget where
return = Finish
(>>=) = flip bindW
zipW comb lw rw = case (lw, rw) of
(Finish z, _) -> Finish z
(_, Finish z) -> Finish z
(Continue _ _ _ (Focused blur _ _ _), Continue _ _ _ (Focused _ _ _ _)) -> zipW comb blur rw
(Continue out mouseOut anim foc, Continue out' mouseOut' anim' foc') ->
let
updateLeft lw' rw' = case (lw', rw') of
(Continue _ _ _ (Focused _ _ _ _), Continue _ _ _ (Focused blur _ _ _)) -> zipW comb lw' blur
_ -> zipW comb lw' rw'
out'' = comb
((fmap.fmap) (\lw' -> updateLeft lw' (fromMaybe rw mouseOut')) out)
((fmap.fmap) (\rw' -> zipW comb (fromMaybe lw mouseOut) rw') out')
mouseOut'' = case (mouseOut, mouseOut') of
(Nothing, Nothing) -> Nothing
(Just lw', Nothing) -> Just $ updateLeft lw' rw
(_, Just rw') -> Just $ zipW comb (fromMaybe lw mouseOut) rw'
anim'' = case (anim, anim') of
(Nothing, Nothing) -> Nothing
(Just animFn, Nothing) -> Just $ \t -> updateLeft (animFn t) rw
(_, Just animFn') -> Just $ liftA2 (zipW comb) (fromMaybe (const lw) anim) animFn'
foc'' = case (foc, foc') of
(NotFocusable, NotFocusable) -> NotFocusable
(Focused _ _ _ _, Focused _ _ _ _) -> error "paired focus elements should cause blur above"
(NotFocusable, Focusable fromLeft fromRight) -> Focusable (zipW comb lw fromLeft) (zipW comb lw fromRight)
(Focusable fromLeft fromRight, NotFocusable) -> Focusable (updateLeft fromLeft rw) (updateLeft fromRight rw)
(Focusable fromLeft _, Focusable _ fromRight) -> Focusable (updateLeft fromLeft rw) (zipW comb lw fromRight)
(Focused blur (tabLeft,ld) (tabRight,False) key, Focusable fromLeft _) ->
Focused (updateLeft blur rw) (updateLeft tabLeft rw, ld) (updateLeft tabRight fromLeft, True) (fmap (\lw' -> updateLeft lw' rw) key)
(Focusable _ fromRight, Focused blur (tabLeft,False) (tabRight,rd) key) ->
Focused (zipW comb lw blur) (zipW comb fromRight tabLeft, True) (zipW comb lw tabRight, rd) (fmap (\rw' -> zipW comb lw rw') key)
(Focused blur (tabLeft,ld) (tabRight,rd) key, _) ->
Focused (updateLeft blur rw) (updateLeft tabLeft rw, ld) (updateLeft tabRight rw, rd) (fmap (\lw' -> updateLeft lw' rw) key)
(_, Focused blur (tabLeft,ld) (tabRight,rd) key) ->
Focused (zipW comb lw blur) (zipW comb lw tabLeft, ld) (zipW comb lw tabRight, rd) (fmap (\rw' -> zipW comb lw rw') key)
in Continue out'' mouseOut'' anim'' foc''
jsNow :: IO Double
jsNow = ffi "(function() { return new Date().getTime(); })"
jsKeyDown :: Elem -> (Int -> Bool -> IO Bool) -> IO ()
jsKeyDown = ffi "(function(elem, onKey) { elem.addEventListener('keydown', function(ev) { if(!onKey(ev.keyCode,ev.shiftKey)){ev.preventDefault();} })})"
jsRequestAnimationFrame :: (() -> IO ()) -> IO ()
jsRequestAnimationFrame = ffi "(function(fn) { window.requestAnimationFrame(fn); })"
runOnCanvas :: String -> Double -> Double -> (forall z. Widget z) -> IO ()
runOnCanvas elemId width height w = do
wref <- newIORef w
Just ce <- elemById elemId
set ce [attr "width" =: show (pixelRatio * width),
attr "height" =: show (pixelRatio * height),
style "width" =: (show width ++ "px"),
style "height" =: (show height ++ "px")]
(Just canvas) <- getCanvas ce
ce `onEvent` OnMouseDown $ (\_ pt -> modifyIORef wref (mouseEvent (fromIntegral $ fst pt, fromIntegral $ snd pt) LeftButton) >> adjustFocus ce wref)
ce `onEvent` OnMouseMove $ (\pt -> modifyIORef wref (mouseEvent (fromIntegral $ fst pt, fromIntegral $ snd pt) NoButton) >> adjustFocus ce wref)
jsKeyDown ce (\key shift -> keyEvent wref key shift)
tm <- jsNow
renderFrame 16.0 tm canvas wref
return ()
where
adjustFocus ce wref = do
Continue _ _ _ foc <- readIORef wref
case foc of
Focused _ _ _ _ -> focus ce
_ -> blur ce
renderFrame mspf prevTime canvas wref = do
Continue out _ anim _ <- readIORef wref
drawGraphicTree canvas out
tm <- jsNow
case anim of
Just fn -> writeIORef wref (fn $ tm prevTime)
_ -> return ()
let mspf' = mspf*0.95 + (tm prevTime)*0.05
jsRequestAnimationFrame (\_ -> renderFrame mspf' tm canvas wref)
mouseEvent _ _ (Finish _) = error "top-level finish"
mouseEvent pt button w'@(Continue out mouseOut _ _) =
case graphicAtPoint pt out of
Nothing -> fromMaybe w' mouseOut
Just (oset, fw) -> fw (oset, button)
keyEvent wref key shift = do
Continue _ _ _ foc <- readIORef wref
case (key,shift) of
(9,False) -> case foc of
Focused _ _ (tabRight, rd) _ -> writeIORef wref tabRight >> return (not rd)
Focusable fromLeft _ -> writeIORef wref fromLeft >> return False
(9,True) -> case foc of
Focused _ (tabLeft, ld) _ _ -> writeIORef wref tabLeft >> return (not ld)
Focusable _ fromRight -> writeIORef wref fromRight >> return False
_ -> case foc of
Focused _ _ _ onKey -> case onKey key of
w'@(Continue _ _ _ (Focused _ _ _ _)) -> writeIORef wref w' >> return False
w' -> writeIORef wref w' >> return True
graphicWidget :: GraphicTree () -> Widget a
graphicWidget g = Continue (const (graphicWidget g) <$ g) Nothing Nothing NotFocusable
combineBeside :: CombineGraphics a
combineBeside gt gt' =
let bounds@(Rect l t w h) = graphicTreeBounds gt
(Rect l' t' w' h') = graphicTreeBounds gt'
in Branch bounds gt (Rect (l + w) t' w' h') (Offset (l + w l', 0) gt')
beside :: Widget z -> Widget z -> Widget z
beside = zipW combineBeside
combineAbove :: CombineGraphics a
combineAbove gt gt' =
let bounds@(Rect l t w h) = graphicTreeBounds gt
(Rect l' t' w' h') = graphicTreeBounds gt'
in Branch bounds gt (Rect l' (t+h) w' h') (Offset (0, t + h t') gt')
above :: Widget z -> Widget z -> Widget z
above = zipW combineAbove