{-# LANGUAGE KindSignatures, RankNTypes, GADTs, OverloadedStrings #-}
module SneathLane
(
-- * Widgets
Widget(..),
WidgetFocus(..),
zipW,
-- * Build Widgets
graphicWidget,
above,
beside,
-- * Run Widgets
runOnCanvas,
-- * Graphics
GraphicTree(..),
graphicList,
graphicTreeBounds,
-- * Events
MouseButton(..),
Key,
-- * Utility
balancedFold,
-- * Type synonyms
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
-- | Which mouse button (if any) was being pressed
data MouseButton = NoButton | LeftButton
type Key = Int
-- | A tree of graphics, used as widget output type. FMap functions are stored in the tree
-- instead of being mapped over the leaves, so that tree reconstruction is fast when a widget changes.
-- This is why GraphicTree is a GADT.
--
-- Offset: a sub-tree translated by a point
--
-- Branch: Two sub-trees; graphicTreeBounds are cached for each
--
-- Leaf: A leaf, consisting of a single graphic element
--
-- FMap: A graphic tree composed with a function.
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
-- | Construct a graphic tree from a nonempty list of graphics.
graphicList :: [Graphic] -> GraphicTree ()
graphicList gs = balancedFold (\g g' -> Branch (graphicTreeBounds g) g (graphicTreeBounds g') g') (map (\g -> Leaf g) gs)
-- | Apply a fold in a balanced fashion over a list. Recommended for
-- combining lists of widgets, so that the widget tree has
-- logarithmic depth.
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
-- | Find a rectangle containing the entire contents of the graphic tree
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
-- | Atom of a sneath lane application
data Widget z = Finish z
| Continue (Output (Widget z)) (Maybe (MouseOut (Widget z))) (Maybe (Animate (Widget z))) (WidgetFocus z)
-- | Determines the focus behavior of the widget
data WidgetFocus z = NotFocusable -- ^ Widget can not take keyboard focus
| Focusable (Widget z) (Widget z) -- ^ Widget can take keyboard focus, but does not have it now
| Focused (Widget z) (Widget z, Bool) (Widget z, Bool) (HandleKey (Widget z)) -- ^ Widget has keyboard focus
type CombineGraphics a = GraphicTree a -> GraphicTree a -> GraphicTree a
-- | Combine two widgets to run in parallel as a single widget
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); })"
-- | Run the widget on the canvas element with ID "canvas"
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)
--ce `onEvent` OnKeyDown $ (\key -> modifyIORef wref (keyEvent key) >> adjustFocus ce wref)
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
--writeLog (show $ floor $ 1000/mspf')
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
-- | A widget which just shows a constant graphic output.
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')
-- | Combine two widgets side by side
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')
-- | Combine two widgets one above the other
above :: Widget z -> Widget z -> Widget z
above = zipW combineAbove
{-
hoverWidget :: GraphicTree () -> GraphicTree () -> Widget a
hoverWidget g1 g2 = outside
where
outside = Continue (Leaf g1 (const inside)) Nothing Nothing NotFocusable
inside = Continue (Leaf g2 (const inside)) (Just outside) Nothing NotFocusable
-}
{-
hw = hoverWidget (Graphic (Rect 0 0 40 40) (RGBA 100 200 100)) (Graphic (Rect 0 0 40 40) (RGBA 200 100 100))
hw' = hoverWidget' (\frac -> Graphic (Rect 0 0 40 40) (RGBA (floor $ frac * 100) 100 100))
main :: IO ()
main = runOnCanvas (seven `above` seven)
where
one = hw' `beside` hw'
two = one `beside` one
three = two `beside` two
four = three `beside` three
five = four `above` four
six = five `above` five
seven = six `above` six
-}