{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module CodeWorld.CanvasM where
import Control.Monad.Reader
import Data.Text (Text)
#ifdef ghcjs_HOST_OS
import Data.JSString.Text
import GHCJS.DOM
import GHCJS.DOM.Document
import GHCJS.DOM.Element
import GHCJS.DOM.Node
import GHCJS.DOM.NonElementParentNode
import GHCJS.Types
import qualified JavaScript.Web.Canvas as Canvas
import qualified JavaScript.Web.Canvas.Internal as Canvas
#else
import Data.Text (pack)
import qualified Graphics.Blank as Canvas
import Graphics.Blank (Canvas)
import Text.Printf
#endif
class (Monad m, MonadIO m) => MonadCanvas m where
type Image m
save :: m ()
restore :: m ()
transform ::
Double -> Double -> Double -> Double -> Double -> Double -> m ()
translate :: Double -> Double -> m ()
scale :: Double -> Double -> m ()
newImage :: Int -> Int -> m (Image m)
builtinImage :: Text -> m (Maybe (Image m))
withImage :: Image m -> m a -> m a
drawImage :: Image m -> Int -> Int -> Int -> Int -> m ()
drawImgURL :: Text -> Text -> Double -> Double -> m ()
globalCompositeOperation :: Text -> m ()
globalAlpha :: Double -> m ()
lineWidth :: Double -> m ()
strokeColor :: Int -> Int -> Int -> Double -> m ()
fillColor :: Int -> Int -> Int -> Double -> m ()
font :: Text -> m ()
textCenter :: m ()
textMiddle :: m ()
beginPath :: m ()
closePath :: m ()
moveTo :: (Double, Double) -> m ()
lineTo :: (Double, Double) -> m ()
quadraticCurveTo :: (Double, Double) -> (Double, Double) -> m ()
bezierCurveTo ::
(Double, Double) -> (Double, Double) -> (Double, Double) -> m ()
arc :: Double -> Double -> Double -> Double -> Double -> Bool -> m ()
rect :: Double -> Double -> Double -> Double -> m ()
clip :: m ()
fill :: m ()
stroke :: m ()
fillRect :: Double -> Double -> Double -> Double -> m ()
fillText :: Text -> (Double, Double) -> m ()
measureText :: Text -> m Double
isPointInPath :: (Double, Double) -> m Bool
isPointInStroke :: (Double, Double) -> m Bool
getScreenWidth :: m Double
getScreenHeight :: m Double
saveRestore :: MonadCanvas m => m a -> m a
saveRestore :: forall (m :: * -> *) a. MonadCanvas m => m a -> m a
saveRestore m a
m = do
forall (m :: * -> *). MonadCanvas m => m ()
save
a
r <- m a
m
forall (m :: * -> *). MonadCanvas m => m ()
restore
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
#if defined(ghcjs_HOST_OS)
data CanvasM a = CanvasM
{ unCanvasM :: (Double, Double) -> Canvas.Context -> IO a
} deriving (Functor)
runCanvasM :: (Double, Double) -> Canvas.Context -> CanvasM a -> IO a
runCanvasM dim ctx m = unCanvasM m dim ctx
instance Applicative CanvasM where
pure x = CanvasM (\_ _ -> return x)
f <*> x = CanvasM (\dim ctx -> unCanvasM f dim ctx <*> unCanvasM x dim ctx)
instance Monad CanvasM where
return = pure
m >>= f = CanvasM $ \dim ctx -> do
x <- unCanvasM m dim ctx
unCanvasM (f x) dim ctx
foreign import javascript "$6.drawImage($1, $2, $3, $4, $5);"
js_drawImage :: Element -> Double -> Double -> Double -> Double -> Canvas.Context -> IO ()
foreign import javascript "$2.globalCompositeOperation = $1;"
js_globalCompositeOperation :: JSString -> Canvas.Context -> IO ()
foreign import javascript "$2.globalAlpha = $1;"
js_globalAlpha :: Double -> Canvas.Context -> IO ()
foreign import javascript "$r = $3.isPointInPath($1, $2);"
js_isPointInPath :: Double -> Double -> Canvas.Context -> IO Bool
foreign import javascript "$r = $3.isPointInStroke($1, $2);"
js_isPointInStroke :: Double -> Double -> Canvas.Context -> IO Bool
foreign import javascript interruptible "$1.onload = $c; $1.src = $2;"
js_loadImage :: Element -> JSString -> IO ()
instance MonadIO CanvasM where
liftIO action = CanvasM $ \_ _ -> action
createOrGetImage :: Text -> Text -> IO Element
createOrGetImage name url = do
Just doc <- currentDocument
maybeImg <- getElementById doc name
case maybeImg of
Just img -> return img
Nothing -> do
img <- createElement doc (textToJSString "img")
setAttribute img (textToJSString "style") (textToJSString "display: none")
setAttribute img (textToJSString "id") name
Just body <- getBody doc
_ <- appendChild body img
js_loadImage img (textToJSString url)
return img
instance MonadCanvas CanvasM where
type Image CanvasM = Canvas.Canvas
save = CanvasM (const Canvas.save)
restore = CanvasM (const Canvas.restore)
transform a b c d e f = CanvasM (const (Canvas.transform a b c d e f))
translate x y = CanvasM (const (Canvas.translate x y))
scale x y = CanvasM (const (Canvas.scale x y))
newImage w h = liftIO (Canvas.create w h)
builtinImage name = liftIO $ do
Just doc <- currentDocument
canvas <- getElementById doc (textToJSString name)
return (Canvas.Canvas . unElement <$> canvas)
withImage img m = liftIO $ do
ctx <- Canvas.getContext img
w <- realToFrac <$> Canvas.width img
h <- realToFrac <$> Canvas.height img
unCanvasM m (w, h) ctx
drawImage (Canvas.Canvas c) x y w h =
CanvasM (const (Canvas.drawImage (Canvas.Image c) x y w h))
drawImgURL name url w h = CanvasM $ \ _ ctx -> do
img <- createOrGetImage name url
js_drawImage img (-w/2) (-h/2) w h ctx
globalCompositeOperation op =
CanvasM (const (js_globalCompositeOperation (textToJSString op)))
globalAlpha a = CanvasM (const (js_globalAlpha a))
lineWidth w = CanvasM (const (Canvas.lineWidth w))
strokeColor r g b a = CanvasM (const (Canvas.strokeStyle r g b a))
fillColor r g b a = CanvasM (const (Canvas.fillStyle r g b a))
font t = CanvasM (const (Canvas.font (textToJSString t)))
textCenter = CanvasM (const (Canvas.textAlign Canvas.Center))
textMiddle = CanvasM (const (Canvas.textBaseline Canvas.Middle))
beginPath = CanvasM (const Canvas.beginPath)
closePath = CanvasM (const Canvas.closePath)
moveTo (x, y) = CanvasM (const (Canvas.moveTo x y))
lineTo (x, y) = CanvasM (const (Canvas.lineTo x y))
quadraticCurveTo (x1, y1) (x2, y2) =
CanvasM (const (Canvas.quadraticCurveTo x1 y1 x2 y2))
bezierCurveTo (x1, y1) (x2, y2) (x3, y3) =
CanvasM (const (Canvas.bezierCurveTo x1 y1 x2 y2 x3 y3))
arc x y r a1 a2 dir = CanvasM (const (Canvas.arc x y r a1 a2 dir))
rect x y w h = CanvasM (const (Canvas.rect x y w h))
clip = CanvasM (const Canvas.clip)
fill = CanvasM (const Canvas.fill)
stroke = CanvasM (const Canvas.stroke)
fillRect x y w h = CanvasM (const (Canvas.fillRect x y w h))
fillText t (x, y) = CanvasM (const (Canvas.fillText (textToJSString t) x y))
measureText t = CanvasM (const (Canvas.measureText (textToJSString t)))
isPointInPath (x, y) = CanvasM (const (js_isPointInPath x y))
isPointInStroke (x, y) = CanvasM (const (js_isPointInStroke x y))
getScreenWidth = CanvasM $ \(w, _) _ -> return w
getScreenHeight = CanvasM $ \(_, h) _ -> return h
#else
data CanvasM a = CanvasOp (Maybe Canvas.CanvasContext) (Canvas (CanvasM a))
| NativeOp (Canvas.DeviceContext -> IO (CanvasM a))
| PureOp a
deriving (forall a b. a -> CanvasM b -> CanvasM a
forall a b. (a -> b) -> CanvasM a -> CanvasM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CanvasM b -> CanvasM a
$c<$ :: forall a b. a -> CanvasM b -> CanvasM a
fmap :: forall a b. (a -> b) -> CanvasM a -> CanvasM b
$cfmap :: forall a b. (a -> b) -> CanvasM a -> CanvasM b
Functor)
doCanvas :: Maybe Canvas.CanvasContext -> Canvas a -> Canvas a
doCanvas :: forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
Nothing Canvas a
m = Canvas a
m
doCanvas (Just CanvasContext
ctx) Canvas a
m = forall a. CanvasContext -> Canvas a -> Canvas a
Canvas.with CanvasContext
ctx Canvas a
m
interpCanvas :: CanvasM a -> Canvas (CanvasM a)
interpCanvas :: forall a. CanvasM a -> Canvas (CanvasM a)
interpCanvas (CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
op) = forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
mctx Canvas (CanvasM a)
op forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. CanvasM a -> Canvas (CanvasM a)
interpCanvas
interpCanvas CanvasM a
other = forall (m :: * -> *) a. Monad m => a -> m a
return CanvasM a
other
runCanvasM :: Canvas.DeviceContext -> CanvasM a -> IO a
runCanvasM :: forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
_ (PureOp a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
runCanvasM DeviceContext
dctx (NativeOp DeviceContext -> IO (CanvasM a)
fm) = DeviceContext -> IO (CanvasM a)
fm DeviceContext
dctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
dctx
runCanvasM DeviceContext
dctx CanvasM a
m = forall a. DeviceContext -> Canvas a -> IO a
Canvas.send DeviceContext
dctx (forall a. CanvasM a -> Canvas (CanvasM a)
interpCanvas CanvasM a
m) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
dctx
instance Applicative CanvasM where
pure :: forall a. a -> CanvasM a
pure = forall a. a -> CanvasM a
PureOp
(CanvasOp Maybe CanvasContext
mctx1 Canvas (CanvasM (a -> b))
f) <*> :: forall a b. CanvasM (a -> b) -> CanvasM a -> CanvasM b
<*> (CanvasOp Maybe CanvasContext
mctx2 Canvas (CanvasM a)
x) = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp Maybe CanvasContext
mctx1 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) Canvas (CanvasM (a -> b))
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
mctx2 Canvas (CanvasM a)
x)
CanvasM (a -> b)
f <*> CanvasM a
x = CanvasM (a -> b)
f forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` CanvasM a
x
instance Monad CanvasM where
return :: forall a. a -> CanvasM a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
PureOp a
x >>= :: forall a b. CanvasM a -> (a -> CanvasM b) -> CanvasM b
>>= a -> CanvasM b
f = a -> CanvasM b
f a
x
NativeOp DeviceContext -> IO (CanvasM a)
op >>= a -> CanvasM b
f = forall a. (DeviceContext -> IO (CanvasM a)) -> CanvasM a
NativeOp forall a b. (a -> b) -> a -> b
$ \DeviceContext
dctx -> do
CanvasM a
next <- DeviceContext -> IO (CanvasM a)
op DeviceContext
dctx
forall (m :: * -> *) a. Monad m => a -> m a
return (CanvasM a
next forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> CanvasM b
f)
CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
op >>= a -> CanvasM b
f = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp Maybe CanvasContext
mctx forall a b. (a -> b) -> a -> b
$ forall a b.
Canvas (CanvasM a) -> (a -> CanvasM b) -> Canvas (CanvasM b)
bindCanvas (forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
mctx Canvas (CanvasM a)
op) a -> CanvasM b
f
bindCanvas :: Canvas (CanvasM a) -> (a -> CanvasM b) -> Canvas (CanvasM b)
bindCanvas :: forall a b.
Canvas (CanvasM a) -> (a -> CanvasM b) -> Canvas (CanvasM b)
bindCanvas Canvas (CanvasM a)
m a -> CanvasM b
cont = do
CanvasM a
next <- Canvas (CanvasM a)
m
case CanvasM a
next of
CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
op -> forall a b.
Canvas (CanvasM a) -> (a -> CanvasM b) -> Canvas (CanvasM b)
bindCanvas (forall a. Maybe CanvasContext -> Canvas a -> Canvas a
doCanvas Maybe CanvasContext
mctx Canvas (CanvasM a)
op) a -> CanvasM b
cont
CanvasM a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (CanvasM a
next forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> CanvasM b
cont)
instance MonadIO CanvasM where
liftIO :: forall a. IO a -> CanvasM a
liftIO IO a
x = forall a. (DeviceContext -> IO (CanvasM a)) -> CanvasM a
NativeOp forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> CanvasM a
PureOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
x
liftCanvas :: Canvas a -> CanvasM a
liftCanvas :: forall a. Canvas a -> CanvasM a
liftCanvas Canvas a
m = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp forall a. Maybe a
Nothing (forall a. a -> CanvasM a
PureOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Canvas a
m)
instance MonadCanvas CanvasM where
type Image CanvasM = Canvas.CanvasContext
save :: CanvasM ()
save = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.save ()
restore :: CanvasM ()
restore = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.restore ()
transform :: Double
-> Double -> Double -> Double -> Double -> Double -> CanvasM ()
transform Double
a Double
b Double
c Double
d Double
e Double
f = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double, Double, Double, Double, Double) -> Canvas ()
Canvas.transform (Double
a, Double
b, Double
c, Double
d, Double
e, Double
f)
translate :: Double -> Double -> CanvasM ()
translate Double
x Double
y = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
Canvas.translate (Double
x, Double
y)
scale :: Double -> Double -> CanvasM ()
scale Double
x Double
y = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
Canvas.scale (Double
x, Double
y)
newImage :: Int -> Int -> CanvasM (Image CanvasM)
newImage Int
w Int
h = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Canvas CanvasContext
Canvas.newCanvas (Int
w, Int
h)
builtinImage :: Text -> CanvasM (Maybe (Image CanvasM))
builtinImage Text
_name = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
withImage :: forall a. Image CanvasM -> CanvasM a -> CanvasM a
withImage Image CanvasM
ctx (CanvasOp Maybe CanvasContext
Nothing Canvas (CanvasM a)
m) = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp (forall a. a -> Maybe a
Just Image CanvasM
ctx) Canvas (CanvasM a)
m
withImage Image CanvasM
_ (CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
m) = forall a. Maybe CanvasContext -> Canvas (CanvasM a) -> CanvasM a
CanvasOp Maybe CanvasContext
mctx Canvas (CanvasM a)
m
withImage Image CanvasM
ctx (NativeOp DeviceContext -> IO (CanvasM a)
fm) = forall a. (DeviceContext -> IO (CanvasM a)) -> CanvasM a
NativeOp forall a b. (a -> b) -> a -> b
$ \DeviceContext
dctx -> forall (m :: * -> *) a. MonadCanvas m => Image m -> m a -> m a
withImage Image CanvasM
ctx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DeviceContext -> IO (CanvasM a)
fm DeviceContext
dctx
withImage Image CanvasM
_ (PureOp a
x) = forall a. a -> CanvasM a
PureOp a
x
drawImage :: Image CanvasM -> Int -> Int -> Int -> Int -> CanvasM ()
drawImage Image CanvasM
img Int
x Int
y Int
w Int
h = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$
forall image.
Image image =>
(image, Double, Double, Double, Double) -> Canvas ()
Canvas.drawImageSize
( Image CanvasM
img
, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y
, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
drawImgURL :: Text -> Text -> Double -> Double -> CanvasM ()
drawImgURL Text
_name Text
_url Double
_w Double
_h = forall (m :: * -> *) a. Monad m => a -> m a
return ()
globalCompositeOperation :: Text -> CanvasM ()
globalCompositeOperation Text
op = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Text -> Canvas ()
Canvas.globalCompositeOperation Text
op
globalAlpha :: Double -> CanvasM ()
globalAlpha Double
a = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Double -> Canvas ()
Canvas.globalAlpha Double
a
lineWidth :: Double -> CanvasM ()
lineWidth Double
w = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Double -> Canvas ()
Canvas.lineWidth Double
w
strokeColor :: Int -> Int -> Int -> Double -> CanvasM ()
strokeColor Int
r Int
g Int
b Double
a = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Text -> Canvas ()
Canvas.strokeStyle
(String -> Text
pack (forall r. PrintfType r => String -> r
printf String
"rgba(%d,%d,%d,%.2f)" Int
r Int
g Int
b Double
a))
fillColor :: Int -> Int -> Int -> Double -> CanvasM ()
fillColor Int
r Int
g Int
b Double
a = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Text -> Canvas ()
Canvas.fillStyle
(String -> Text
pack (forall r. PrintfType r => String -> r
printf String
"rgba(%d,%d,%d,%.2f)" Int
r Int
g Int
b Double
a))
font :: Text -> CanvasM ()
font Text
t = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ Text -> Canvas ()
Canvas.font Text
t
textCenter :: CanvasM ()
textCenter = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ TextAnchorAlignment -> Canvas ()
Canvas.textAlign TextAnchorAlignment
Canvas.CenterAnchor
textMiddle :: CanvasM ()
textMiddle = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ TextBaselineAlignment -> Canvas ()
Canvas.textBaseline TextBaselineAlignment
Canvas.MiddleBaseline
beginPath :: CanvasM ()
beginPath = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.beginPath ()
closePath :: CanvasM ()
closePath = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.closePath ()
moveTo :: (Double, Double) -> CanvasM ()
moveTo (Double
x, Double
y) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
Canvas.moveTo (Double
x, Double
y)
lineTo :: (Double, Double) -> CanvasM ()
lineTo (Double
x, Double
y) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
Canvas.lineTo (Double
x, Double
y)
quadraticCurveTo :: (Double, Double) -> (Double, Double) -> CanvasM ()
quadraticCurveTo (Double
x1, Double
y1) (Double
x2, Double
y2) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$
(Double, Double, Double, Double) -> Canvas ()
Canvas.quadraticCurveTo (Double
x1, Double
y1, Double
x2, Double
y2)
bezierCurveTo :: (Double, Double)
-> (Double, Double) -> (Double, Double) -> CanvasM ()
bezierCurveTo (Double
x1, Double
y1) (Double
x2, Double
y2) (Double
x3, Double
y3) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$
(Double, Double, Double, Double, Double, Double) -> Canvas ()
Canvas.bezierCurveTo (Double
x1, Double
y1, Double
x2, Double
y2, Double
x3, Double
y3)
arc :: Double
-> Double -> Double -> Double -> Double -> Bool -> CanvasM ()
arc Double
x Double
y Double
r Double
a1 Double
a2 Bool
dir = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$
(Double, Double, Double, Double, Double, Bool) -> Canvas ()
Canvas.arc (Double
x, Double
y, Double
r, Double
a1, Double
a2, Bool
dir)
rect :: Double -> Double -> Double -> Double -> CanvasM ()
rect Double
x Double
y Double
w Double
h = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double, Double, Double) -> Canvas ()
Canvas.rect (Double
x, Double
y, Double
w, Double
h)
clip :: CanvasM ()
clip = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.clip ()
fill :: CanvasM ()
fill = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.fill ()
stroke :: CanvasM ()
stroke = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
Canvas.stroke ()
fillRect :: Double -> Double -> Double -> Double -> CanvasM ()
fillRect Double
x Double
y Double
w Double
h = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double, Double, Double) -> Canvas ()
Canvas.fillRect (Double
x, Double
y, Double
w, Double
h)
fillText :: Text -> (Double, Double) -> CanvasM ()
fillText Text
t (Double
x, Double
y) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Text, Double, Double) -> Canvas ()
Canvas.fillText (Text
t, Double
x, Double
y)
measureText :: Text -> CanvasM Double
measureText Text
t = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ do
Canvas.TextMetrics Double
w <- Text -> Canvas TextMetrics
Canvas.measureText Text
t
forall (m :: * -> *) a. Monad m => a -> m a
return Double
w
isPointInPath :: (Double, Double) -> CanvasM Bool
isPointInPath (Double
x, Double
y) = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas Bool
Canvas.isPointInPath (Double
x, Double
y)
isPointInStroke :: (Double, Double) -> CanvasM Bool
isPointInStroke (Double, Double)
_ = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
getScreenWidth :: CanvasM Double
getScreenWidth = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ forall image a. (Image image, Num a) => image -> a
Canvas.width forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Canvas CanvasContext
Canvas.myCanvasContext
getScreenHeight :: CanvasM Double
getScreenHeight = forall a. Canvas a -> CanvasM a
liftCanvas forall a b. (a -> b) -> a -> b
$ forall image a. (Image image, Num a) => image -> a
Canvas.height forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Canvas CanvasContext
Canvas.myCanvasContext
#endif