reactivity-0.3.0.0: src/FRP/Reactivity/Extras.hs

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

-- | Extra utilities.
module FRP.Reactivity.Extras where

import FRP.Reactivity.Hook
import FRP.Reactivity.UI
import FRP.Reactivity.Draw
import FRP.Reactivity.Combinators
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Applicative
import Control.Comonad (duplicate)
import Control.Exception
import Control.Concurrent.MVar
import Data.Int
import Data.Monoid
import Data.Fixed
import Data.Maybe
import qualified Data.Map as M
import Graphics.Win32 hiding (textOut, fillRect)
import Codec.BMP
import Prelude hiding (until)

import System.IO.Unsafe

-- |
dragNDrop :: (Monoid r) => (POINT -> Appearance) -> Maybe RECT -> Hook r (Event Message) Act t -> Hook r (Event Message) Act (Either t (Window, Btn, POINT, POINT))
dragNDrop appr rect h = do
	w <- window
	(x, child) <- getReturns mempty id h
	tellReturn child
	return (Left x) <> do
		-- Pick a child to follow
		w2 <- lift $ liftE $ fmap return child

		-- Wait for a child to be clicked
		(btn, pt@(origX, origY), rest) <- lift $ liftE $ justE $ fmap (\(e, rest) -> case e of
			Mouse b Down pt -> Just (return (b, pt, rest))
			_ -> Nothing)
			(withRest (event w2))

		let pos = mousePos rest

		-- Wait for the mouse to exit a "guard region" which prevents unwanted drags.
		-- If the mouse is released before exiting the guard region, the drag operation is aborted.
		lift $ liftE $ fmap return $ once $ filterE (\(x, y) -> abs (x - origX) > 20 && abs (y - origY) > 20) pos `untilE` filterE (\e -> case e of Mouse _ Up _ -> True; _ -> False) rest

		liftIO (putStrLn "Dragging")

		-- Move the drag icon in a drag operation.
		liftM fst $ getReturns1 mempty id $ hCreate "STATIC" (stepper mempty $ fmap appr pos)
			(do
			drag <- window
			lift $ liftE $ once $ justE (fmap (\e -> case e of Mouse _ Up pt2 -> Just (destroyWindow (hwnd drag) >> return (Right (w2, btn, pt, pt2))); _ -> Nothing) rest))

-- |
draggable :: (POINT -> Appearance) -> Maybe RECT -> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t -> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t
draggable appr rt h = do
	dragEvents <- liftIO (chanSource defaultFrame)
	(ei, child) <- getReturns (mempty, fmap (\(_, _, (x1, y1), (x2, y2)) a -> a { rect = shift (x2 - x1, y2 - y1) (rect a) }) (getEvent dragEvents)) id $ dragNDrop appr rt h
	either
		(\ei -> tellReturn child >> return ei)
		(\tup -> lift (liftS dragEvents $ return $ return tup) >> mzero)
		ei

dragMargin = 5

data Side = Ll | Rr | U | D | N deriving Eq

updateRect (Ll, U) (_, _, x2, y2) (x, y) = (x, y, x2, y2)
updateRect (Rr, U) (x1, _, _, y2) (x, y) = (x1, y, x, y2)
updateRect (Ll, D) (_, y1, x2, _) (x, y) = (x, y1, x2, y)
updateRect (Rr, D) (x1, y1, _, _) (x, y) = (x1, y1, x, y)
updateRect (Ll, N) (_, y1, x2, y2) (x, _) = (x, y1, x2, y2)
updateRect (Rr, N) (x1, y1, _, y2) (x, _) = (x1, y1, x, y2)
updateRect (N, U) (x1, _, x2, y2) (_, y) = (x1, y, x2, y2)
updateRect (N, D) (x1, y1, x2, _) (_, y) = (x1, y1, x2, y)
updateRect (N, N) rt _ = rt

isRight (Right _) = True
isRight _ = False

-- | Functional which makes windows from the parameter 'h' into sizeable windows with draggable edges.
sizeable :: Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t ->
	Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t
sizeable h = do
	w <- window
	wit <- liftIO (chanSource defaultFrame)
	(x, child) <- getReturns (mempty, getEvent wit) (fmap (\(_, _, _, e, _) -> e) . filterE (\(hside, vside, _, _, _) -> hside == N && vside == N) . findDragEvents) h
	tellReturn child
	return x <> do
		-- Pick a child
		w2 <- lift $ liftE $ fmap return child

		-- Wait for a child to be sized
		(hside, vside, rt@(left, top, _, _), _, eRest) <- lift $ liftE $ fmap return $ findDragEvents (event w2)

		guard (hside /= N || vside /= N)

		let resizeRects = justE (fmap (\e -> case e of
			Mouse _ Mv (x, y) -> Just (updateRect (hside, vside) rt (left + x, top + y))
			_ -> Nothing) eRest)
		let endResizeRect = justE (fmap (\e -> case e of
			Mouse _ Up (x, y) -> Just (updateRect (hside, vside) rt (left + x, top + y))
			_ -> Nothing) eRest)

		-- Draw selection rectangle (the four borders)
		-- This illustrates how static controls can be used to draw shapes
		let initAppearance = Appearance (fillRect 0 (0, 0, 65536, 65536)) "" (0, 0, 0, 0)
		s1 <- hCreate' "STATIC" (initAppearance, fmap (\(x1, y1, x2, y2) a -> a { rect = (x1, y1, x2, y1 + dragMargin) }) resizeRects)
		s2 <- hCreate' "STATIC" (initAppearance, fmap (\(x1, y1, x2, y2) a -> a { rect = (x1, y1 + dragMargin, x1 + dragMargin, y2 - dragMargin) }) resizeRects)
		s3 <- hCreate' "STATIC" (initAppearance, fmap (\(x1, y1, x2, y2) a -> a { rect = (x2 - dragMargin, y1 + dragMargin, x2, y2 - dragMargin) }) resizeRects)
		s4 <- hCreate' "STATIC" (initAppearance, fmap (\(x1, y1, x2, y2) a -> a { rect = (x1, y2 - dragMargin, x2, y2) }) resizeRects)

		-- Wait for mouse cursor to release
		newRt <- lift $ liftE $ fmap return $ once endResizeRect

		-- Remove selection rectangle
		liftIO $ destroyWindow (hwnd s1) >> destroyWindow (hwnd s2) >> destroyWindow (hwnd s3) >> destroyWindow (hwnd s4)

		-- Update the rectangle
		lift $ liftS wit $ return $ return $ \a -> a { rect = newRt }
		mzero where
	findDragEvents e = fmap (\(((e, eRest), rt@(x1, y1, x2, y2)), t) -> case e of
			Mouse _ Down (x, y) ->
				let
					hside = if x < dragMargin then Ll else if x >= x2 - x1 - dragMargin then Rr else N
					vside = if y < dragMargin then U else if y >= y2 - y1 - dragMargin then D else N in
					(hside, vside, rt, e, startAt eRest (list [(t, 0.1)]))
			_ -> (N, N, rt, e, startAt eRest (list [(t, 0.1)])))
			$ withTime
			$ holdE (withRest e) (position e) (0, 0, 0, 0)

-- | Perform an action when the window is closed.
onClose :: (HWND -> IO ()) -> Hook r x Act ()
onClose f = void $ do
	w <- window
	lift $ liftS nil $ fmap (\msg -> case msg of Close -> liftIO $ f (hwnd w); _ -> return ()) (event w)

-- | Causes the current window to close when the user closes it.
autoclose :: Hook r x Act ()
autoclose = onClose destroyWindow

realign (lo, hi) (mn, mx) x = if x < lo then
		mn
	else if x > hi then
		mx
	else
		(x - lo) * (mx - mn) / (hi - lo) + mn

-- | Given,
--   * A behavior 'b'
--   * An event
--   * A display range 'rng'
--   * Sampling rate (number of samples per second)
--   * And a colour functional 'clrF',
--   Gives a behavior that graphs 'b' in the range 'rng'. The event indicates when to resize
--   the graph in the display window.
graphBehavior :: (RealFrac t) => Behavior t -> Event RECT -> (t, t) -> Int32 -> (t -> COLORREF) -> Behavior (Draw ())
graphBehavior b pos (nY, mY) samps clr = switcher (pure mempty)
	$ fmap (\(rt@(x1, y1, x2, y2), b) -> (\t f -> graph (t - fromIntegral (x2 - x1) / fromIntegral samps, nY, t, mY) (dim rt) f clr)
		<$> time
		<*> history (fromIntegral $ samps * (x2 - x1)) b)
		(snapshot pos (duplicate b))

vertLine x (y1, y2) = fillRect 0 (x, y1, x + 1, y2)

horzLine (x1, x2) y = fillRect 0 (x1, y, x2, y + 1)

maxOfRange :: (RealFrac t) => t -> (Int32, Fixed E6)
maxOfRange mx = (ceiling (mx / 10 ^^ n), 10 ^^ n)
	where n = floor (log (fromRational (toRational mx) * 0.75) / log 10)

-- | Graphs a function in a specific range.
--
-- Parameters;
--
--   * (mX, mY) - The maximum data values of the graph.
--
--   * (x1, y1) - The dimensions of the graph, in pixels.
--
--   * f - The function to graph.
--
--   * clrF - A colour functional.
graph :: (RealFrac t, RealFrac u) => (t, u, t, u) -> POINT -> (t -> u) -> (u -> COLORREF) -> Draw ()
graph (nX, nY, mX, mY) (x1, y1) f clrF = do
	-- Draw abscissa/ordinate
	mapM_ (\n -> do
		let x2 = 30 + (x1 - 40) * n `div` mxX
		textOut (showFixed True $ fromRational (toRational nX) + fromIntegral n * incrementX) (x2 - 5, 5) defFont
		vertLine x2 (20, 25)) [0..mxX]
	mapM_ (\n -> do
		let y2 = 25 + (y1 - 35) * n `div` mxY
		textOut (showFixed True $ fromRational (toRational nY) + fromIntegral n * incrementY) (0, y2 - 5) defFont
		horzLine (25, 30) y2) [0..mxY]
	horzLine (30, x1) 25
	vertLine 30 (25, y1)

	-- Draw graph
	function (31, 26, x1, y1) (\c x y -> let
			v = f (realign (31, fromIntegral (x1 - 10)) (nX, mX) (fromIntegral x))
			aln = realign (nY, mY) (26, fromIntegral $ y1 - 10) v in
		if y > floor aln then c else clrF v)
	where
		(mxX, incrementX) = maxOfRange (mX - nX)
		(mxY, incrementY) = maxOfRange (mY - nY)

-- | This is for anything with text. Upon double-clicking on the object, it displays
--   an edit control (which can be dismissed by hitting ENTER).
editableText :: Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t ->
	Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t
editableText h = do
	wnd <- window
	changes <- liftIO (chanSource defaultFrame)
	(x, child) <- getReturns (mempty, fmap (\t a -> a { text = t }) (getEvent changes)) id h
	tellReturn child
	return x <> do
		((w, txt), rect) <- lift $ liftE $ child >>= \w -> fmap return $ holdE (holdE (fmap (const w) $ filterE (\e -> case e of
			Mouse _ Dbl _ -> True
			_ -> False) (event w)) (texts (event w)) "")
			(position (event w)) (0, 0, 0, 0)
		
		liftIO $ showWindow (hwnd w) sW_HIDE
		w2 <- hCreate' "EDIT" (Appearance mempty txt rect, mempty)

		let finish = fmap (\(_, txt) -> destroyWindow (hwnd w2) >> return txt) $ once $ holdE (filterE (\e -> case e of
			Key True key -> key == vK_RETURN
			_ -> False) (event w2))
			(texts (event w2)) txt

		liftIO $ showWindow (hwnd w) sW_SHOW
		lift $ liftS changes finish
		mzero

data Pair t u = Pair t u deriving Show

instance (Ord t, Ord u, Bounded t, Bounded u) => Monoid (Pair t u) where
	mempty = Pair minBound minBound
	mappend (Pair a1 b1) (Pair a2 b2) = Pair (max a1 a2) (max b1 b2)

{-# INLINE convert #-}
convert reac ev = (mempty { text = "0,0,0" },
	(\(pos, (rt, mx)) _ -> let (wid, ht) = dim rt in
	Appearance (return ()) (show mx
		++ ',' : show pos
		++ ",0") rt)
	<$>
	snapshot ev reac)

{-# INLINE extent #-}
extent = monoid . fmap (stepper (Pair 0 0) . justE . fmap (\msg -> case msg of
	Move (_, _, x, y) -> Just (Pair x y)
	Close -> Just (Pair 0 0)
	_ -> Nothing))

shiftControls :: Event (Int32, Int32)
	-> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t
	-> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act (t, Event Window)
shiftControls displacement h = do
	-- Add a hook to move controls around
	-- and a hook to make this invisible to other components
 	let adjust = (\((x, y), (x2, y2)) appr ->
		appr { rect = shift (x2 - x, y2 - y) (rect appr) })
		<$>
		withPrev (cons (0, 0) 0 displacement)
	getReturns (mempty, adjust) id h

	{-let adjust2 ev = (\(msg, (xPos, yPos)) -> case msg of
		Move rt -> Move $ shift (xPos, yPos) rt
		_ -> msg)
		<$>
		holdE
			ev
			(zipE (getChanges (event hw)) 0 (getChanges (event vw)) 0)
			(0, 0)-}

-- | If some child controls are out of view,
-- adds scroll bars that allow the user to access them.
scroll :: Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t -> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t
scroll h = do
	wnd <- window
	adjustStream <- liftIO $ chanSource defaultFrame
	~(x, children) <- shiftControls (getEvent adjustStream) h
	let changes = justE $ fmap (\msg -> case msg of Move rt -> Just (dim rt); _ -> Nothing) (event wnd)
	let hDim = fmap (\(wid, ht) -> (0, ht - barSize, wid - barSize, ht)) changes
	let vDim = fmap (\(wid, ht) -> (wid - barSize, 0, wid, ht - barSize)) changes
	let ext = extent (fmap event children)
	hw <- hCreate' "HSCROLLBAR" $ convert ((,)
		<$> stepper empt hDim
		<*> fmap (\(Pair x _) -> x) ext)
		(fmap (\(_, _, x, _) -> x) $ position (event wnd))
	vw <- hCreate' "SCROLLBAR" $ convert ((,)
		<$> stepper empt vDim
		<*> fmap (\(Pair _ x) -> x) ext)
		(fmap (\(_, _, _, y) -> y) $ position (event wnd))
	lift $ liftS adjustStream $ return <$> zipE (negate <$> getChanges (event hw)) 0 (negate <$> getChanges (event vw)) 0
	return x where
	empt = (0, 0, 0, 0)
	getChanges = justE . fmap (\msg -> case msg of Change s -> Just (read s); _ -> Nothing)

barSize :: LONG
barSize = 18

theStyle h = getReturns (fillRect 0xbebed4 (0, 0, 32767, 32767)
	>> mapM_ (\y -> mapM_ (\x -> blend (fromIntegral y / 200) (x, y) 0x404092) [0..199]) [0..399])
	h