{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-name-shadowing
                -Wno-orphans
                -Wno-unticked-promoted-constructors
                -Wno-incomplete-uni-patterns
  #-}

{-
  Copyright 2020 The CodeWorld Authors. All rights reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}
module CodeWorld.Driver where

import qualified CodeWorld.CanvasM as CM
import CodeWorld.Color
import CodeWorld.DrawState
import CodeWorld.Event
import CodeWorld.Picture
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Loops
import Control.Monad.Reader
import Control.Monad.Ref
import Data.Bool
import Data.Char (chr)
import Data.Dependent.Sum
import Data.Foldable
import Data.IORef
import Data.List (intercalate, zip4)
import Data.Maybe
import Data.Serialize
import Data.Serialize.Text ()
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Fingerprint.Type
import GHC.Generics
import GHC.Stack
import GHC.StaticPtr
import Numeric (showFFloatAlt)
import qualified Reflex as R
import qualified Reflex.Host.Class as R
import System.IO.Unsafe
import System.Mem.StableName
import System.Random
import Text.Printf
import Text.Read

#if MIN_VERSION_witherable(0, 4, 0)
import Witherable
#else
import Data.Witherable
#endif

#ifdef ghcjs_HOST_OS

import CodeWorld.CanvasM (MonadCanvas, CanvasM, runCanvasM)
import CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState)
import qualified CodeWorld.CollaborationUI as CUI
import CodeWorld.Message
import CodeWorld.Prediction
import Control.DeepSeq
import Control.Monad.Identity
import qualified Control.Monad.Trans.State as State
import Data.Aeson (ToJSON(..), (.=), object)
import Data.Hashable
import qualified Data.JSString
import GHCJS.Concurrent (withoutPreemption)
import GHCJS.DOM
import qualified GHCJS.DOM.DOMRect as DOMRect
import GHCJS.DOM.Document (createElement, getBodyUnsafe)
import GHCJS.DOM.Element
import GHCJS.DOM.EventM
import GHCJS.DOM.GlobalEventHandlers hiding (error, keyPress)
import GHCJS.DOM.KeyboardEvent
import GHCJS.DOM.MouseEvent
import GHCJS.DOM.Node (appendChild)
import GHCJS.DOM.NonElementParentNode
import GHCJS.DOM.Types (Window, Element, unElement)
import GHCJS.Foreign.Callback
import GHCJS.Marshal
import GHCJS.Marshal.Pure
import GHCJS.Types
import JavaScript.Object
import qualified JavaScript.Web.Canvas as Canvas
import qualified JavaScript.Web.Canvas.Internal as Canvas
import qualified JavaScript.Web.Location as Loc
import qualified JavaScript.Web.MessageEvent as WS
import qualified JavaScript.Web.Performance as Performance
import qualified JavaScript.Web.WebSocket as WS
import Unsafe.Coerce

#else

import CodeWorld.CanvasM (MonadCanvas, runCanvasM)
import Data.Time.Clock
import qualified Graphics.Blank as Canvas
import System.Environment

#endif

-- | Applies the affine transformation from the DrawState and prepares to draw
-- with it.  This does not set the color at the same time, because different
-- pictures need to apply the color, if any, in different ways, often outside of
-- the action that sets up the geometry.
withDS :: MonadCanvas m => DrawState -> m a -> m a
withDS :: forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS (DrawState (AffineTransformation Double
ta Double
tb Double
tc Double
td Double
te Double
tf) Maybe Color
_col) m a
action =
  forall (m :: * -> *) a. MonadCanvas m => m a -> m a
CM.saveRestore forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> Double -> Double -> m ()
CM.transform Double
ta Double
tb Double
tc Double
td Double
te Double
tf
    forall (m :: * -> *). MonadCanvas m => m ()
CM.beginPath
    m a
action

setColor :: MonadCanvas m => Color -> m ()
setColor :: forall (m :: * -> *). MonadCanvas m => Color -> m ()
setColor (RGBA Double
r Double
g Double
b Double
a) = do
  forall (m :: * -> *).
MonadCanvas m =>
Int -> Int -> Int -> Double -> m ()
CM.strokeColor
    (forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
r forall a. Num a => a -> a -> a
* Double
255)
    (forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
g forall a. Num a => a -> a -> a
* Double
255)
    (forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
b forall a. Num a => a -> a -> a
* Double
255)
    Double
a
  forall (m :: * -> *).
MonadCanvas m =>
Int -> Int -> Int -> Double -> m ()
CM.fillColor
    (forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
r forall a. Num a => a -> a -> a
* Double
255)
    (forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
g forall a. Num a => a -> a -> a
* Double
255)
    (forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
b forall a. Num a => a -> a -> a
* Double
255)
    Double
a

applyColor :: MonadCanvas m => DrawState -> m ()
applyColor :: forall (m :: * -> *). MonadCanvas m => DrawState -> m ()
applyColor DrawState
ds = case DrawState -> Maybe Color
getColorDS DrawState
ds of
  Maybe Color
Nothing -> forall (m :: * -> *). MonadCanvas m => Color -> m ()
setColor (Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
1)
  Just Color
c -> forall (m :: * -> *). MonadCanvas m => Color -> m ()
setColor Color
c

-- | A slower way to draw a picture, which has some useful properties.  It
-- can draw images in non-standard colors, and apply transparent colors
-- properly to overlapping compositions of basic shapes.  There must be a
-- color in the DrawState.
viaOffscreen :: MonadCanvas m => Color -> (Color -> m ()) -> m ()
viaOffscreen :: forall (m :: * -> *).
MonadCanvas m =>
Color -> (Color -> m ()) -> m ()
viaOffscreen (RGBA Double
r Double
g Double
b Double
a) Color -> m ()
pic = do
  Double
w <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenWidth
  Double
h <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenHeight
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
w forall a. Ord a => a -> a -> Bool
> Double
0.5 Bool -> Bool -> Bool
&& Double
h forall a. Ord a => a -> a -> Bool
> Double
0.5) forall a b. (a -> b) -> a -> b
$ do
    Image m
img <- forall (m :: * -> *). MonadCanvas m => Int -> Int -> m (Image m)
CM.newImage (forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
h)
    forall (m :: * -> *) a. MonadCanvas m => Image m -> m a -> m a
CM.withImage Image m
img forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *). MonadCanvas m => Int -> Int -> m ()
setupScreenContext (forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
h)
      Color -> m ()
pic (Double -> Double -> Double -> Double -> Color
RGBA Double
r Double
g Double
b Double
1)
    forall (m :: * -> *) a. MonadCanvas m => m a -> m a
CM.saveRestore forall a b. (a -> b) -> a -> b
$ do
      Double
px <- forall (m :: * -> *). MonadCanvas m => m Double
pixelSize
      forall (m :: * -> *). MonadCanvas m => Double -> Double -> m ()
CM.scale Double
px (- Double
px)
      forall (m :: * -> *). MonadCanvas m => Double -> m ()
CM.globalAlpha Double
a
      forall (m :: * -> *).
MonadCanvas m =>
Image m -> Int -> Int -> Int -> Int -> m ()
CM.drawImage Image m
img (forall a b. (RealFrac a, Integral b) => a -> b
round (- Double
w forall a. Fractional a => a -> a -> a
/ Double
2)) (forall a b. (RealFrac a, Integral b) => a -> b
round (- Double
h forall a. Fractional a => a -> a -> a
/ Double
2)) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
h)

followPath :: MonadCanvas m => [Point] -> Bool -> Bool -> m ()
followPath :: forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> Bool -> m ()
followPath [] Bool
_ Bool
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
followPath [Point
_] Bool
_ Bool
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
followPath ((Double
sx, Double
sy) : [Point]
ps) Bool
closed Bool
False = do
  forall (m :: * -> *). MonadCanvas m => Point -> m ()
CM.moveTo (Double
sx, Double
sy)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Point]
ps forall a b. (a -> b) -> a -> b
$ \(Double
x, Double
y) -> forall (m :: * -> *). MonadCanvas m => Point -> m ()
CM.lineTo (Double
x, Double
y)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
closed forall (m :: * -> *). MonadCanvas m => m ()
CM.closePath
followPath [Point
p1, Point
p2] Bool
False Bool
True = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> Bool -> m ()
followPath [Point
p1, Point
p2] Bool
False Bool
False
followPath [Point]
ps Bool
False Bool
True = do
  let [p1 :: Point
p1@(Double
x1, Double
y1), p2 :: Point
p2@(Double
x2, Double
y2), p3 :: Point
p3@(Double
x3, Double
y3)] = forall a. Int -> [a] -> [a]
take Int
3 [Point]
ps
      dprev :: Double
dprev = Point -> Point -> Double
euclideanDistance Point
p1 Point
p2
      dnext :: Double
dnext = Point -> Point -> Double
euclideanDistance Point
p2 Point
p3
      p :: Double
p = Double
dprev forall a. Fractional a => a -> a -> a
/ (Double
dprev forall a. Num a => a -> a -> a
+ Double
dnext)
      cx :: Double
cx = Double
x2 forall a. Num a => a -> a -> a
+ Double
p forall a. Num a => a -> a -> a
* (Double
x1 forall a. Num a => a -> a -> a
- Double
x3) forall a. Fractional a => a -> a -> a
/ Double
2
      cy :: Double
cy = Double
y2 forall a. Num a => a -> a -> a
+ Double
p forall a. Num a => a -> a -> a
* (Double
y1 forall a. Num a => a -> a -> a
- Double
y3) forall a. Fractional a => a -> a -> a
/ Double
2
  forall (m :: * -> *). MonadCanvas m => Point -> m ()
CM.moveTo (Double
x1, Double
y1)
  forall (m :: * -> *). MonadCanvas m => Point -> Point -> m ()
CM.quadraticCurveTo (Double
cx, Double
cy) (Double
x2, Double
y2)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Point]
ps (forall a. [a] -> [a]
tail [Point]
ps) (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Point]
ps) (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Point]
ps)) forall a b. (a -> b) -> a -> b
$ \(p1 :: Point
p1@(Double
x1, Double
y1), p2 :: Point
p2@(Double
x2, Double
y2), p3 :: Point
p3@(Double
x3, Double
y3), p4 :: Point
p4@(Double
x4, Double
y4)) -> do
    let dp :: Double
dp = Point -> Point -> Double
euclideanDistance Point
p1 Point
p2
        d1 :: Double
d1 = Point -> Point -> Double
euclideanDistance Point
p2 Point
p3
        d2 :: Double
d2 = Point -> Point -> Double
euclideanDistance Point
p3 Point
p4
        p :: Double
p = Double
d1 forall a. Fractional a => a -> a -> a
/ (Double
d1 forall a. Num a => a -> a -> a
+ Double
d2)
        r :: Double
r = Double
d1 forall a. Fractional a => a -> a -> a
/ (Double
dp forall a. Num a => a -> a -> a
+ Double
d1)
        cx1 :: Double
cx1 = Double
x2 forall a. Num a => a -> a -> a
+ Double
r forall a. Num a => a -> a -> a
* (Double
x3 forall a. Num a => a -> a -> a
- Double
x1) forall a. Fractional a => a -> a -> a
/ Double
2
        cy1 :: Double
cy1 = Double
y2 forall a. Num a => a -> a -> a
+ Double
r forall a. Num a => a -> a -> a
* (Double
y3 forall a. Num a => a -> a -> a
- Double
y1) forall a. Fractional a => a -> a -> a
/ Double
2
        cx2 :: Double
cx2 = Double
x3 forall a. Num a => a -> a -> a
+ Double
p forall a. Num a => a -> a -> a
* (Double
x2 forall a. Num a => a -> a -> a
- Double
x4) forall a. Fractional a => a -> a -> a
/ Double
2
        cy2 :: Double
cy2 = Double
y3 forall a. Num a => a -> a -> a
+ Double
p forall a. Num a => a -> a -> a
* (Double
y2 forall a. Num a => a -> a -> a
- Double
y4) forall a. Fractional a => a -> a -> a
/ Double
2
    forall (m :: * -> *).
MonadCanvas m =>
Point -> Point -> Point -> m ()
CM.bezierCurveTo
      (Double
cx1, Double
cy1)
      (Double
cx2, Double
cy2)
      (Double
x3, Double
y3)
  let [p1 :: Point
p1@(Double
x1, Double
y1), p2 :: Point
p2@(Double
x2, Double
y2), p3 :: Point
p3@(Double
x3, Double
y3)] = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
3 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Point]
ps
      dp :: Double
dp = Point -> Point -> Double
euclideanDistance Point
p1 Point
p2
      d1 :: Double
d1 = Point -> Point -> Double
euclideanDistance Point
p2 Point
p3
      r :: Double
r = Double
d1 forall a. Fractional a => a -> a -> a
/ (Double
dp forall a. Num a => a -> a -> a
+ Double
d1)
      cx :: Double
cx = Double
x2 forall a. Num a => a -> a -> a
+ Double
r forall a. Num a => a -> a -> a
* (Double
x3 forall a. Num a => a -> a -> a
- Double
x1) forall a. Fractional a => a -> a -> a
/ Double
2
      cy :: Double
cy = Double
y2 forall a. Num a => a -> a -> a
+ Double
r forall a. Num a => a -> a -> a
* (Double
y3 forall a. Num a => a -> a -> a
- Double
y1) forall a. Fractional a => a -> a -> a
/ Double
2
  forall (m :: * -> *). MonadCanvas m => Point -> Point -> m ()
CM.quadraticCurveTo (Double
cx, Double
cy) (Double
x3, Double
y3)
followPath ps :: [Point]
ps@(Point
_ : (Double
sx, Double
sy) : [Point]
_) Bool
True Bool
True = do
  forall (m :: * -> *). MonadCanvas m => Point -> m ()
CM.moveTo (Double
sx, Double
sy)
  let rep :: [Point]
rep = forall a. [a] -> [a]
cycle [Point]
ps
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 [Point]
ps (forall a. [a] -> [a]
tail [Point]
rep) (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Point]
rep) (forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [Point]
rep)) forall a b. (a -> b) -> a -> b
$ \(p1 :: Point
p1@(Double
x1, Double
y1), p2 :: Point
p2@(Double
x2, Double
y2), p3 :: Point
p3@(Double
x3, Double
y3), p4 :: Point
p4@(Double
x4, Double
y4)) -> do
    let dp :: Double
dp = Point -> Point -> Double
euclideanDistance Point
p1 Point
p2
        d1 :: Double
d1 = Point -> Point -> Double
euclideanDistance Point
p2 Point
p3
        d2 :: Double
d2 = Point -> Point -> Double
euclideanDistance Point
p3 Point
p4
        p :: Double
p = Double
d1 forall a. Fractional a => a -> a -> a
/ (Double
d1 forall a. Num a => a -> a -> a
+ Double
d2)
        r :: Double
r = Double
d1 forall a. Fractional a => a -> a -> a
/ (Double
dp forall a. Num a => a -> a -> a
+ Double
d1)
        cx1 :: Double
cx1 = Double
x2 forall a. Num a => a -> a -> a
+ Double
r forall a. Num a => a -> a -> a
* (Double
x3 forall a. Num a => a -> a -> a
- Double
x1) forall a. Fractional a => a -> a -> a
/ Double
2
        cy1 :: Double
cy1 = Double
y2 forall a. Num a => a -> a -> a
+ Double
r forall a. Num a => a -> a -> a
* (Double
y3 forall a. Num a => a -> a -> a
- Double
y1) forall a. Fractional a => a -> a -> a
/ Double
2
        cx2 :: Double
cx2 = Double
x3 forall a. Num a => a -> a -> a
+ Double
p forall a. Num a => a -> a -> a
* (Double
x2 forall a. Num a => a -> a -> a
- Double
x4) forall a. Fractional a => a -> a -> a
/ Double
2
        cy2 :: Double
cy2 = Double
y3 forall a. Num a => a -> a -> a
+ Double
p forall a. Num a => a -> a -> a
* (Double
y2 forall a. Num a => a -> a -> a
- Double
y4) forall a. Fractional a => a -> a -> a
/ Double
2
    forall (m :: * -> *).
MonadCanvas m =>
Point -> Point -> Point -> m ()
CM.bezierCurveTo
      (Double
cx1, Double
cy1)
      (Double
cx2, Double
cy2)
      (Double
x3, Double
y3)
  forall (m :: * -> *). MonadCanvas m => m ()
CM.closePath

euclideanDistance :: Point -> Point -> Double
euclideanDistance :: Point -> Point -> Double
euclideanDistance (Double
x1, Double
y1) (Double
x2, Double
y2) = forall a. Floating a => a -> a
sqrt forall a b. (a -> b) -> a -> b
$ forall {a}. Num a => a -> a
square (Double
x2 forall a. Num a => a -> a -> a
- Double
x1) forall a. Num a => a -> a -> a
+ forall {a}. Num a => a -> a
square (Double
y2 forall a. Num a => a -> a -> a
- Double
y1)
  where
    square :: a -> a
square a
x = a
x forall a. Num a => a -> a -> a
* a
x

drawFigure :: MonadCanvas m => DrawState -> Double -> m () -> m ()
drawFigure :: forall (m :: * -> *).
MonadCanvas m =>
DrawState -> Double -> m () -> m ()
drawFigure DrawState
ds Double
w m ()
figure = do
  forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds forall a b. (a -> b) -> a -> b
$ do
    m ()
figure
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
w forall a. Eq a => a -> a -> Bool
/= Double
0) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *). MonadCanvas m => Double -> m ()
CM.lineWidth Double
w
      forall (m :: * -> *). MonadCanvas m => DrawState -> m ()
applyColor DrawState
ds
      forall (m :: * -> *). MonadCanvas m => m ()
CM.stroke
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
w forall a. Eq a => a -> a -> Bool
== Double
0) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). MonadCanvas m => Double -> m ()
CM.lineWidth forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadCanvas m => m Double
pixelSize
    forall (m :: * -> *). MonadCanvas m => DrawState -> m ()
applyColor DrawState
ds
    forall (m :: * -> *). MonadCanvas m => m ()
CM.stroke

fillFigure :: MonadCanvas m => DrawState -> m () -> m ()
fillFigure :: forall (m :: * -> *). MonadCanvas m => DrawState -> m () -> m ()
fillFigure DrawState
ds m ()
figure = do
  forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds m ()
figure
  forall (m :: * -> *). MonadCanvas m => DrawState -> m ()
applyColor DrawState
ds
  forall (m :: * -> *). MonadCanvas m => m ()
CM.fill

--------------------------------------------------------------------------------

drawPicture :: MonadCanvas m => Picture -> DrawState -> m ()
drawPicture :: forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture (SolidClosedCurve Maybe SrcLoc
_ [Point]
pts) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> m ()
drawPolygon [Point]
pts Bool
True DrawState
ds
drawPicture (SolidPolygon Maybe SrcLoc
_ [Point]
pts) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> m ()
drawPolygon [Point]
pts Bool
False DrawState
ds
drawPicture (Polygon Maybe SrcLoc
_ [Point]
pts) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath [Point]
pts Double
0 Bool
True Bool
False DrawState
ds
drawPicture (ThickPolygon Maybe SrcLoc
_ [Point]
pts Double
w) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath [Point]
pts Double
w Bool
True Bool
False DrawState
ds
drawPicture (Rectangle Maybe SrcLoc
_ Double
w Double
h) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath (Double -> Double -> [Point]
rectangleVertices Double
w Double
h) Double
0 Bool
True Bool
False DrawState
ds
drawPicture (SolidRectangle Maybe SrcLoc
_ Double
w Double
h) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> m ()
drawPolygon (Double -> Double -> [Point]
rectangleVertices Double
w Double
h) Bool
False DrawState
ds
drawPicture (ThickRectangle Maybe SrcLoc
_ Double
lw Double
w Double
h) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath (Double -> Double -> [Point]
rectangleVertices Double
w Double
h) Double
lw Bool
True Bool
False DrawState
ds
drawPicture (ClosedCurve Maybe SrcLoc
_ [Point]
pts) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath [Point]
pts Double
0 Bool
True Bool
True DrawState
ds
drawPicture (ThickClosedCurve Maybe SrcLoc
_ [Point]
pts Double
w) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath [Point]
pts Double
w Bool
True Bool
True DrawState
ds
drawPicture (Circle Maybe SrcLoc
_ Double
r) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> DrawState -> m ()
drawArc Double
0 (Double
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi) Double
r Double
0 DrawState
ds
drawPicture (SolidCircle Maybe SrcLoc
_ Double
r) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> DrawState -> m ()
drawSector Double
0 (Double
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi) Double
r DrawState
ds
drawPicture (ThickCircle Maybe SrcLoc
_ Double
lw Double
r) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> DrawState -> m ()
drawArc Double
0 (Double
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi) Double
r Double
lw DrawState
ds
drawPicture (Polyline Maybe SrcLoc
_ [Point]
pts) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath [Point]
pts Double
0 Bool
False Bool
False DrawState
ds
drawPicture (ThickPolyline Maybe SrcLoc
_ [Point]
pts Double
w) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath [Point]
pts Double
w Bool
False Bool
False DrawState
ds
drawPicture (Curve Maybe SrcLoc
_ [Point]
pts) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath [Point]
pts Double
0 Bool
False Bool
True DrawState
ds
drawPicture (ThickCurve Maybe SrcLoc
_ [Point]
pts Double
w) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath [Point]
pts Double
w Bool
False Bool
True DrawState
ds
drawPicture (Sector Maybe SrcLoc
_ Double
b Double
e Double
r) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> DrawState -> m ()
drawSector Double
b Double
e Double
r DrawState
ds
drawPicture (Arc Maybe SrcLoc
_ Double
b Double
e Double
r) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> DrawState -> m ()
drawArc Double
b Double
e Double
r Double
0 DrawState
ds
drawPicture (ThickArc Maybe SrcLoc
_ Double
b Double
e Double
r Double
w) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> DrawState -> m ()
drawArc Double
b Double
e Double
r Double
w DrawState
ds
drawPicture (Lettering Maybe SrcLoc
_ Text
txt) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
TextStyle -> Font -> Text -> DrawState -> m ()
drawText TextStyle
Plain Font
Serif Text
txt DrawState
ds
drawPicture (Blank Maybe SrcLoc
_) DrawState
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
drawPicture (StyledLettering Maybe SrcLoc
_ TextStyle
sty Font
fnt Text
txt) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
TextStyle -> Font -> Text -> DrawState -> m ()
drawText TextStyle
sty Font
fnt Text
txt DrawState
ds
drawPicture (Sketch Maybe SrcLoc
_ Text
name Text
url Double
w Double
h) DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
Text -> Text -> Double -> Double -> DrawState -> m ()
drawImage Text
name Text
url Double
w Double
h DrawState
ds
drawPicture (CoordinatePlane Maybe SrcLoc
_) DrawState
ds = forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
coordinatePlanePic DrawState
ds
drawPicture (Color Maybe SrcLoc
_ Color
col Picture
p) DrawState
ds
  | Picture -> Bool
isSimplePic Picture
p Bool -> Bool -> Bool
|| Color -> Bool
isOpaque Color
col = forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p (Color -> DrawState -> DrawState
setColorDS Color
col DrawState
ds)
  | Bool
otherwise = forall (m :: * -> *).
MonadCanvas m =>
Color -> (Color -> m ()) -> m ()
viaOffscreen Color
col forall a b. (a -> b) -> a -> b
$ \Color
c -> forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p (Color -> DrawState -> DrawState
setColorDS Color
c DrawState
ds)
drawPicture (Translate Maybe SrcLoc
_ Double
x Double
y Picture
p) DrawState
ds = forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p (Double -> Double -> DrawState -> DrawState
translateDS Double
x Double
y DrawState
ds)
drawPicture (Scale Maybe SrcLoc
_ Double
x Double
y Picture
p) DrawState
ds = forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p (Double -> Double -> DrawState -> DrawState
scaleDS Double
x Double
y DrawState
ds)
drawPicture (Dilate Maybe SrcLoc
_ Double
k Picture
p) DrawState
ds = forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p (Double -> Double -> DrawState -> DrawState
scaleDS Double
k Double
k DrawState
ds)
drawPicture (Rotate Maybe SrcLoc
_ Double
r Picture
p) DrawState
ds = forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p (Double -> DrawState -> DrawState
rotateDS Double
r DrawState
ds)
drawPicture (Reflect Maybe SrcLoc
_ Double
r Picture
p) DrawState
ds = forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p (Double -> DrawState -> DrawState
reflectDS Double
r DrawState
ds)
drawPicture (Clip Maybe SrcLoc
_ Double
x Double
y Picture
p) DrawState
ds = do
  forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> Bool -> m ()
followPath (Double -> Double -> [Point]
rectangleVertices Double
x Double
y) Bool
True Bool
False
  forall (m :: * -> *) a. MonadCanvas m => m a -> m a
CM.saveRestore forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadCanvas m => m ()
CM.clip forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p DrawState
ds
drawPicture (Pictures Maybe SrcLoc
_ [Picture]
ps) DrawState
ds = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse [Picture]
ps) forall a b. (a -> b) -> a -> b
$ \Picture
p -> forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p DrawState
ds
drawPicture (PictureAnd Maybe SrcLoc
_ [Picture]
ps) DrawState
ds = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse [Picture]
ps) forall a b. (a -> b) -> a -> b
$ \Picture
p -> forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
p DrawState
ds

pictureContains :: MonadCanvas m => Picture -> DrawState -> Point -> m Bool
pictureContains :: forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains (SolidClosedCurve Maybe SrcLoc
_ [Point]
pts) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> Point -> m Bool
polygonContains [Point]
pts Bool
True DrawState
ds Point
pt
pictureContains (SolidPolygon Maybe SrcLoc
_ [Point]
pts) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> Point -> m Bool
polygonContains [Point]
pts Bool
False DrawState
ds Point
pt
pictureContains (Polygon Maybe SrcLoc
_ [Point]
pts) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains [Point]
pts Double
0 Bool
True Bool
False DrawState
ds Point
pt
pictureContains (ThickPolygon Maybe SrcLoc
_ [Point]
pts Double
w) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains [Point]
pts Double
w Bool
True Bool
False DrawState
ds Point
pt
pictureContains (Rectangle Maybe SrcLoc
_ Double
w Double
h) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains (Double -> Double -> [Point]
rectangleVertices Double
w Double
h) Double
0 Bool
True Bool
False DrawState
ds Point
pt
pictureContains (SolidRectangle Maybe SrcLoc
_ Double
w Double
h) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> Point -> m Bool
polygonContains (Double -> Double -> [Point]
rectangleVertices Double
w Double
h) Bool
False DrawState
ds Point
pt
pictureContains (ThickRectangle Maybe SrcLoc
_ Double
lw Double
w Double
h) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains (Double -> Double -> [Point]
rectangleVertices Double
w Double
h) Double
lw Bool
True Bool
False DrawState
ds Point
pt
pictureContains (ClosedCurve Maybe SrcLoc
_ [Point]
pts) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains [Point]
pts Double
0 Bool
True Bool
True DrawState
ds Point
pt
pictureContains (ThickClosedCurve Maybe SrcLoc
_ [Point]
pts Double
w) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains [Point]
pts Double
w Bool
True Bool
True DrawState
ds Point
pt
pictureContains (Circle Maybe SrcLoc
_ Double
r) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Double
-> Double -> Double -> Double -> DrawState -> Point -> m Bool
arcContains Double
0 (Double
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi) Double
r Double
0 DrawState
ds Point
pt
pictureContains (SolidCircle Maybe SrcLoc
_ Double
r) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> DrawState -> Point -> m Bool
sectorContains Double
0 (Double
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi) Double
r DrawState
ds Point
pt
pictureContains (ThickCircle Maybe SrcLoc
_ Double
lw Double
r) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Double
-> Double -> Double -> Double -> DrawState -> Point -> m Bool
arcContains Double
0 (Double
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi) Double
r Double
lw DrawState
ds Point
pt
pictureContains (Polyline Maybe SrcLoc
_ [Point]
pts) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains [Point]
pts Double
0 Bool
False Bool
False DrawState
ds Point
pt
pictureContains (ThickPolyline Maybe SrcLoc
_ [Point]
pts Double
w) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains [Point]
pts Double
w Bool
False Bool
False DrawState
ds Point
pt
pictureContains (Curve Maybe SrcLoc
_ [Point]
pts) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains [Point]
pts Double
0 Bool
False Bool
True DrawState
ds Point
pt
pictureContains (ThickCurve Maybe SrcLoc
_ [Point]
pts Double
w) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains [Point]
pts Double
w Bool
False Bool
True DrawState
ds Point
pt
pictureContains (Sector Maybe SrcLoc
_ Double
b Double
e Double
r) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> DrawState -> Point -> m Bool
sectorContains Double
b Double
e Double
r DrawState
ds Point
pt
pictureContains (Arc Maybe SrcLoc
_ Double
b Double
e Double
r) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Double
-> Double -> Double -> Double -> DrawState -> Point -> m Bool
arcContains Double
b Double
e Double
r Double
0 DrawState
ds Point
pt
pictureContains (ThickArc Maybe SrcLoc
_ Double
b Double
e Double
r Double
w) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Double
-> Double -> Double -> Double -> DrawState -> Point -> m Bool
arcContains Double
b Double
e Double
r Double
w DrawState
ds Point
pt
pictureContains (Lettering Maybe SrcLoc
_ Text
txt) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
TextStyle -> Font -> Text -> DrawState -> Point -> m Bool
textContains TextStyle
Plain Font
Serif Text
txt DrawState
ds Point
pt
pictureContains (Blank Maybe SrcLoc
_) DrawState
_ Point
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
pictureContains (StyledLettering Maybe SrcLoc
_ TextStyle
sty Font
fnt Text
txt) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
TextStyle -> Font -> Text -> DrawState -> Point -> m Bool
textContains TextStyle
sty Font
fnt Text
txt DrawState
ds Point
pt
pictureContains (Sketch Maybe SrcLoc
_ Text
name Text
url Double
w Double
h) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Text -> Text -> Double -> Double -> DrawState -> Point -> m Bool
imageContains Text
name Text
url Double
w Double
h DrawState
ds Point
pt
pictureContains (CoordinatePlane Maybe SrcLoc
_) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
coordinatePlanePic DrawState
ds Point
pt
pictureContains (Color Maybe SrcLoc
_ Color
_ Picture
p) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p DrawState
ds Point
pt
pictureContains (Translate Maybe SrcLoc
_ Double
x Double
y Picture
p) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p (Double -> Double -> DrawState -> DrawState
translateDS Double
x Double
y DrawState
ds) Point
pt
pictureContains (Scale Maybe SrcLoc
_ Double
x Double
y Picture
p) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p (Double -> Double -> DrawState -> DrawState
scaleDS Double
x Double
y DrawState
ds) Point
pt
pictureContains (Dilate Maybe SrcLoc
_ Double
k Picture
p) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p (Double -> Double -> DrawState -> DrawState
scaleDS Double
k Double
k DrawState
ds) Point
pt
pictureContains (Rotate Maybe SrcLoc
_ Double
r Picture
p) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p (Double -> DrawState -> DrawState
rotateDS Double
r DrawState
ds) Point
pt
pictureContains (Reflect Maybe SrcLoc
_ Double
r Picture
p) DrawState
ds Point
pt = forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p (Double -> DrawState -> DrawState
reflectDS Double
r DrawState
ds) Point
pt
pictureContains (Clip Maybe SrcLoc
_ Double
x Double
y Picture
p) DrawState
ds Point
pt =
  Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> Point -> m Bool
polygonContains (Double -> Double -> [Point]
rectangleVertices Double
x Double
y) Bool
False DrawState
ds Point
pt
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p DrawState
ds Point
pt
pictureContains (Pictures Maybe SrcLoc
_ [Picture]
ps) DrawState
ds Point
pt = forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM [forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p DrawState
ds Point
pt | Picture
p <- [Picture]
ps]
pictureContains (PictureAnd Maybe SrcLoc
_ [Picture]
ps) DrawState
ds Point
pt = forall (m :: * -> *). Monad m => [m Bool] -> m Bool
orM [forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p DrawState
ds Point
pt | Picture
p <- [Picture]
ps]

isSimplePic :: Picture -> Bool
isSimplePic :: Picture -> Bool
isSimplePic (Pictures Maybe SrcLoc
_ []) = Bool
True
isSimplePic (Pictures Maybe SrcLoc
_ [Picture
p]) = Picture -> Bool
isSimplePic Picture
p
isSimplePic (Pictures Maybe SrcLoc
_ [Picture]
_) = Bool
False
isSimplePic (PictureAnd Maybe SrcLoc
_ []) = Bool
True
isSimplePic (PictureAnd Maybe SrcLoc
_ [Picture
p]) = Picture -> Bool
isSimplePic Picture
p
isSimplePic (PictureAnd Maybe SrcLoc
_ [Picture]
_) = Bool
False
isSimplePic (Translate Maybe SrcLoc
_ Double
_ Double
_ Picture
p) = Picture -> Bool
isSimplePic Picture
p
isSimplePic (Scale Maybe SrcLoc
_ Double
_ Double
_ Picture
p) = Picture -> Bool
isSimplePic Picture
p
isSimplePic (Dilate Maybe SrcLoc
_ Double
_ Picture
p) = Picture -> Bool
isSimplePic Picture
p
isSimplePic (Rotate Maybe SrcLoc
_ Double
_ Picture
p) = Picture -> Bool
isSimplePic Picture
p
isSimplePic (Reflect Maybe SrcLoc
_ Double
_ Picture
p) = Picture -> Bool
isSimplePic Picture
p
isSimplePic (Clip Maybe SrcLoc
_ Double
_ Double
_ Picture
p) = Picture -> Bool
isSimplePic Picture
p
isSimplePic (Color Maybe SrcLoc
_ Color
c Picture
p) = Bool -> Bool
not (Color -> Bool
isOpaque Color
c) Bool -> Bool -> Bool
|| Picture -> Bool
isSimplePic Picture
p
isSimplePic Picture
_ = Bool
True

isOpaque :: Color -> Bool
isOpaque :: Color -> Bool
isOpaque (RGBA Double
_ Double
_ Double
_ Double
1) = Bool
True
isOpaque Color
_ = Bool
False

drawPolygon :: MonadCanvas m => [Point] -> Bool -> DrawState -> m ()
drawPolygon :: forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> m ()
drawPolygon [Point]
ps Bool
smooth DrawState
ds = forall (m :: * -> *). MonadCanvas m => DrawState -> m () -> m ()
fillFigure DrawState
ds forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> Bool -> m ()
followPath [Point]
ps Bool
True Bool
smooth

polygonContains :: MonadCanvas m => [Point] -> Bool -> DrawState -> Point -> m Bool
polygonContains :: forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> Point -> m Bool
polygonContains [Point]
ps Bool
smooth DrawState
ds Point
p = do
  forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> Bool -> m ()
followPath [Point]
ps Bool
True Bool
smooth
  forall (m :: * -> *). MonadCanvas m => Point -> m Bool
CM.isPointInPath Point
p

drawPath :: MonadCanvas m => [Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath :: forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> m ()
drawPath [Point]
ps Double
w Bool
closed Bool
smooth DrawState
ds = forall (m :: * -> *).
MonadCanvas m =>
DrawState -> Double -> m () -> m ()
drawFigure DrawState
ds Double
w forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> Bool -> m ()
followPath [Point]
ps Bool
closed Bool
smooth

pathContains :: MonadCanvas m => [Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains :: forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool
pathContains [Point]
ps Double
w Bool
closed Bool
smooth DrawState
ds Point
p = do
  Double
s <- forall (m :: * -> *). MonadCanvas m => m Double
pixelSize
  forall (m :: * -> *).
MonadCanvas m =>
DrawState -> Double -> m () -> m ()
drawFigure DrawState
ds (forall a. Ord a => a -> a -> a
max Double
s Double
w) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> Bool -> m ()
followPath [Point]
ps Bool
closed Bool
smooth
  forall (m :: * -> *). MonadCanvas m => Point -> m Bool
CM.isPointInStroke Point
p

drawSector :: MonadCanvas m => Double -> Double -> Double -> DrawState -> m ()
drawSector :: forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> DrawState -> m ()
drawSector Double
b Double
e Double
r DrawState
ds =
  forall (m :: * -> *). MonadCanvas m => DrawState -> m () -> m ()
fillFigure DrawState
ds forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> Double -> Bool -> m ()
CM.arc Double
0 Double
0 (forall {a}. Num a => a -> a
abs Double
r) Double
b Double
e (Double
b forall a. Ord a => a -> a -> Bool
> Double
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadCanvas m => Point -> m ()
CM.lineTo (Double
0, Double
0)

sectorContains :: MonadCanvas m => Double -> Double -> Double -> DrawState -> Point -> m Bool
sectorContains :: forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> DrawState -> Point -> m Bool
sectorContains Double
b Double
e Double
r DrawState
ds Point
p = do
  forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> Double -> Bool -> m ()
CM.arc Double
0 Double
0 (forall {a}. Num a => a -> a
abs Double
r) Double
b Double
e (Double
b forall a. Ord a => a -> a -> Bool
> Double
e) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadCanvas m => Point -> m ()
CM.lineTo (Double
0, Double
0)
  forall (m :: * -> *). MonadCanvas m => Point -> m Bool
CM.isPointInPath Point
p

drawArc :: MonadCanvas m => Double -> Double -> Double -> Double -> DrawState -> m ()
drawArc :: forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> DrawState -> m ()
drawArc Double
b Double
e Double
r Double
w DrawState
ds =
  forall (m :: * -> *).
MonadCanvas m =>
DrawState -> Double -> m () -> m ()
drawFigure DrawState
ds Double
w forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> Double -> Bool -> m ()
CM.arc Double
0 Double
0 (forall {a}. Num a => a -> a
abs Double
r) Double
b Double
e (Double
b forall a. Ord a => a -> a -> Bool
> Double
e)

arcContains :: MonadCanvas m => Double -> Double -> Double -> Double -> DrawState -> Point -> m Bool
arcContains :: forall (m :: * -> *).
MonadCanvas m =>
Double
-> Double -> Double -> Double -> DrawState -> Point -> m Bool
arcContains Double
b Double
e Double
r Double
w DrawState
ds Point
p = do
  Double
s <- forall (m :: * -> *). MonadCanvas m => m Double
pixelSize
  let width :: Double
width = forall a. Ord a => a -> a -> a
max Double
s Double
w
  forall (m :: * -> *). MonadCanvas m => Double -> m ()
CM.lineWidth Double
width
  forall (m :: * -> *).
MonadCanvas m =>
DrawState -> Double -> m () -> m ()
drawFigure DrawState
ds Double
width forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> Double -> Bool -> m ()
CM.arc Double
0 Double
0 (forall {a}. Num a => a -> a
abs Double
r) Double
b Double
e (Double
b forall a. Ord a => a -> a -> Bool
> Double
e)
  forall (m :: * -> *). MonadCanvas m => Point -> m Bool
CM.isPointInStroke Point
p

drawText :: MonadCanvas m => TextStyle -> Font -> Text -> DrawState -> m ()
drawText :: forall (m :: * -> *).
MonadCanvas m =>
TextStyle -> Font -> Text -> DrawState -> m ()
drawText TextStyle
sty Font
fnt Text
txt DrawState
ds = forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *). MonadCanvas m => Double -> Double -> m ()
CM.scale (Double
1 forall a. Fractional a => a -> a -> a
/ Double
25) (-Double
1 forall a. Fractional a => a -> a -> a
/ Double
25)
  forall (m :: * -> *). MonadCanvas m => DrawState -> m ()
applyColor DrawState
ds
  forall (m :: * -> *). MonadCanvas m => Text -> m ()
CM.font (TextStyle -> Font -> Text
fontString TextStyle
sty Font
fnt)
  forall (m :: * -> *). MonadCanvas m => Text -> Point -> m ()
CM.fillText Text
txt (Double
0, Double
0)

textContains :: MonadCanvas m => TextStyle -> Font -> Text -> DrawState -> Point -> m Bool
textContains :: forall (m :: * -> *).
MonadCanvas m =>
TextStyle -> Font -> Text -> DrawState -> Point -> m Bool
textContains TextStyle
sty Font
fnt Text
txt DrawState
ds Point
p = do
  forall (m :: * -> *). MonadCanvas m => Text -> m ()
CM.font (TextStyle -> Font -> Text
fontString TextStyle
sty Font
fnt)
  Double
width <- (forall a. Fractional a => a -> a -> a
/ Double
25) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadCanvas m => Text -> m Double
CM.measureText Text
txt
  let height :: Double
height = Double
1 -- constant, defined in fontString
  forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> m ()
CM.rect ((-Double
0.5) forall a. Num a => a -> a -> a
* Double
width) ((-Double
0.5) forall a. Num a => a -> a -> a
* Double
height) Double
width Double
height
  forall (m :: * -> *). MonadCanvas m => Point -> m Bool
CM.isPointInPath Point
p

fontString :: TextStyle -> Font -> Text
fontString :: TextStyle -> Font -> Text
fontString TextStyle
style Font
font = forall {a}. IsString a => TextStyle -> a
stylePrefix TextStyle
style forall a. Semigroup a => a -> a -> a
<> Text
"25px " forall a. Semigroup a => a -> a -> a
<> Font -> Text
fontName Font
font
  where
    stylePrefix :: TextStyle -> a
stylePrefix TextStyle
Plain = a
""
    stylePrefix TextStyle
Bold = a
"bold "
    stylePrefix TextStyle
Italic = a
"italic "
    fontName :: Font -> Text
fontName Font
SansSerif = Text
"sans-serif"
    fontName Font
Serif = Text
"serif"
    fontName Font
Monospace = Text
"monospace"
    fontName Font
Handwriting = Text
"cursive"
    fontName Font
Fancy = Text
"fantasy"
    fontName (NamedFont Text
txt) = Text
"\"" forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
'"') Text
txt forall a. Semigroup a => a -> a -> a
<> Text
"\""

drawImage :: MonadCanvas m => Text -> Text -> Double -> Double -> DrawState -> m ()
drawImage :: forall (m :: * -> *).
MonadCanvas m =>
Text -> Text -> Double -> Double -> DrawState -> m ()
drawImage Text
name Text
url Double
imgw Double
imgh DrawState
ds = case DrawState -> Maybe Color
getColorDS DrawState
ds of
  -- Fast path: draw in original color.
  Maybe Color
Nothing -> forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). MonadCanvas m => Double -> Double -> m ()
CM.scale Double
1 (-Double
1)
    forall (m :: * -> *).
MonadCanvas m =>
Text -> Text -> Double -> Double -> m ()
CM.drawImgURL Text
name Text
url Double
imgw Double
imgh

  -- Slow path: draw in a different color via an offscreen canvas.
  Just Color
oc -> forall (m :: * -> *).
MonadCanvas m =>
Color -> (Color -> m ()) -> m ()
viaOffscreen Color
oc forall a b. (a -> b) -> a -> b
$ \Color
c -> do
    forall (m :: * -> *). MonadCanvas m => Color -> m ()
setColor Color
c
    Double
w <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenWidth
    Double
h <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenHeight
    forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> m ()
CM.fillRect (- Double
w forall a. Fractional a => a -> a -> a
/ Double
2) (- Double
h forall a. Fractional a => a -> a -> a
/ Double
2) Double
w Double
h
    forall (m :: * -> *). MonadCanvas m => Text -> m ()
CM.globalCompositeOperation Text
"destination-in"
    forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *). MonadCanvas m => Double -> Double -> m ()
CM.scale Double
1 (-Double
1)
      forall (m :: * -> *).
MonadCanvas m =>
Text -> Text -> Double -> Double -> m ()
CM.drawImgURL Text
name Text
url Double
imgw Double
imgh

imageContains :: MonadCanvas m => Text -> Text -> Double -> Double -> DrawState -> Point -> m Bool
imageContains :: forall (m :: * -> *).
MonadCanvas m =>
Text -> Text -> Double -> Double -> DrawState -> Point -> m Bool
imageContains Text
_ Text
_ Double
imgw Double
imgh DrawState
ds Point
p = forall (m :: * -> *) a. MonadCanvas m => DrawState -> m a -> m a
withDS DrawState
ds forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> m ()
CM.rect (- Double
imgw forall a. Fractional a => a -> a -> a
/ Double
2) (- Double
imgh forall a. Fractional a => a -> a -> a
/ Double
2) Double
imgw Double
imgh
  forall (m :: * -> *). MonadCanvas m => Point -> m Bool
CM.isPointInPath Point
p

coordinatePlanePic :: Picture
coordinatePlanePic :: Picture
coordinatePlanePic = Picture
axes forall a. Semigroup a => a -> a -> a
<> Picture
numbers forall a. Semigroup a => a -> a -> a
<> Picture
guidelines
  where
    xline :: Double -> Picture
xline Double
y = HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
0.25) forall a b. (a -> b) -> a -> b
$ HasCallStack => [Point] -> Picture
polyline [(-Double
10, Double
y), (Double
10, Double
y)]
    xaxis :: Picture
xaxis = HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
0.75) forall a b. (a -> b) -> a -> b
$ HasCallStack => [Point] -> Picture
polyline [(-Double
10, Double
0), (Double
10, Double
0)]
    axes :: Picture
axes = Picture
xaxis forall a. Semigroup a => a -> a -> a
<> HasCallStack => Double -> Picture -> Picture
rotated (forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
2) Picture
xaxis
    xguidelines :: Picture
xguidelines = HasCallStack => [Picture] -> Picture
pictures [Double -> Picture
xline Double
k | Double
k <- [-Double
10, -Double
9 .. Double
10]]
    guidelines :: Picture
guidelines = Picture
xguidelines forall a. Semigroup a => a -> a -> a
<> HasCallStack => Double -> Picture -> Picture
rotated (forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
2) Picture
xguidelines
    numbers :: Picture
numbers = Picture
xnumbers forall a. Semigroup a => a -> a -> a
<> Picture
ynumbers
    xnumbers :: Picture
xnumbers =
      HasCallStack => [Picture] -> Picture
pictures
        [ HasCallStack => Double -> Double -> Picture -> Picture
translated
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k)
            Double
0.3
            (HasCallStack => Double -> Double -> Picture -> Picture
scaled Double
0.5 Double
0.5 (HasCallStack => Text -> Picture
lettering (String -> Text
T.pack (forall a. Show a => a -> String
show Int
k))))
          | Int
k <- [-Int
9, -Int
8 .. Int
9],
            Int
k forall a. Eq a => a -> a -> Bool
/= (Int
0 :: Int)
        ]
    ynumbers :: Picture
ynumbers =
      HasCallStack => [Picture] -> Picture
pictures
        [ HasCallStack => Double -> Double -> Picture -> Picture
translated
            Double
0.3
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k)
            (HasCallStack => Double -> Double -> Picture -> Picture
scaled Double
0.5 Double
0.5 (HasCallStack => Text -> Picture
lettering (String -> Text
T.pack (forall a. Show a => a -> String
show Int
k))))
          | Int
k <- [-Int
9, -Int
8 .. Int
9],
            Int
k forall a. Eq a => a -> a -> Bool
/= (Int
0 :: Int)
        ]

--------------------------------------------------------------------------------

clearScreen :: MonadCanvas m => m ()
clearScreen :: forall (m :: * -> *). MonadCanvas m => m ()
clearScreen = do
  Double
w <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenWidth
  Double
h <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenHeight
  Double
px <- forall (m :: * -> *). MonadCanvas m => m Double
pixelSize
  forall (m :: * -> *).
MonadCanvas m =>
Int -> Int -> Int -> Double -> m ()
CM.fillColor Int
255 Int
255 Int
255 Double
1
  forall (m :: * -> *).
MonadCanvas m =>
Double -> Double -> Double -> Double -> m ()
CM.fillRect (- Double
w forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
* Double
px) (- Double
h forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
* Double
px) (Double
w forall a. Num a => a -> a -> a
* Double
px) (Double
h forall a. Num a => a -> a -> a
* Double
px)

drawFrame :: MonadCanvas m => Picture -> m ()
drawFrame :: forall (m :: * -> *). MonadCanvas m => Picture -> m ()
drawFrame Picture
pic = forall (m :: * -> *). MonadCanvas m => m ()
clearScreen forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadCanvas m => Picture -> DrawState -> m ()
drawPicture Picture
pic DrawState
initialDS

pixelSize :: MonadCanvas m => m Double
pixelSize :: forall (m :: * -> *). MonadCanvas m => m Double
pixelSize = do
  Double
cw <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenWidth
  Double
ch <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenHeight
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max (Double
20 forall a. Fractional a => a -> a -> a
/ forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
cw) (Double
20 forall a. Fractional a => a -> a -> a
/ forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
ch)

setupScreenContext :: MonadCanvas m => Int -> Int -> m ()
setupScreenContext :: forall (m :: * -> *). MonadCanvas m => Int -> Int -> m ()
setupScreenContext Int
cw Int
ch = do
  forall (m :: * -> *). MonadCanvas m => Double -> Double -> m ()
CM.translate (forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
cw forall a. Fractional a => a -> a -> a
/ Double
2) (forall a b. (Real a, Fractional b) => a -> b
realToFrac Int
ch forall a. Fractional a => a -> a -> a
/ Double
2)
  Double
s <- forall (m :: * -> *). MonadCanvas m => m Double
pixelSize
  forall (m :: * -> *). MonadCanvas m => Double -> Double -> m ()
CM.scale (Double
1 forall a. Fractional a => a -> a -> a
/ Double
s) (-Double
1 forall a. Fractional a => a -> a -> a
/ Double
s)
  forall (m :: * -> *). MonadCanvas m => Double -> m ()
CM.lineWidth Double
0
  forall (m :: * -> *). MonadCanvas m => m ()
CM.textCenter
  forall (m :: * -> *). MonadCanvas m => m ()
CM.textMiddle

--------------------------------------------------------------------------------

-- A NodeId a unique id for each node in a Picture, chosen by the order the node
-- appears in DFS.  Always >=0.
newtype NodeId = NodeId {NodeId -> Int
getNodeId :: Int}
  deriving (NodeId -> NodeId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeId -> NodeId -> Bool
$c/= :: NodeId -> NodeId -> Bool
== :: NodeId -> NodeId -> Bool
$c== :: NodeId -> NodeId -> Bool
Eq, Eq NodeId
NodeId -> NodeId -> Bool
NodeId -> NodeId -> Ordering
NodeId -> NodeId -> NodeId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NodeId -> NodeId -> NodeId
$cmin :: NodeId -> NodeId -> NodeId
max :: NodeId -> NodeId -> NodeId
$cmax :: NodeId -> NodeId -> NodeId
>= :: NodeId -> NodeId -> Bool
$c>= :: NodeId -> NodeId -> Bool
> :: NodeId -> NodeId -> Bool
$c> :: NodeId -> NodeId -> Bool
<= :: NodeId -> NodeId -> Bool
$c<= :: NodeId -> NodeId -> Bool
< :: NodeId -> NodeId -> Bool
$c< :: NodeId -> NodeId -> Bool
compare :: NodeId -> NodeId -> Ordering
$ccompare :: NodeId -> NodeId -> Ordering
Ord, Int -> NodeId
NodeId -> Int
NodeId -> [NodeId]
NodeId -> NodeId
NodeId -> NodeId -> [NodeId]
NodeId -> NodeId -> NodeId -> [NodeId]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: NodeId -> NodeId -> NodeId -> [NodeId]
$cenumFromThenTo :: NodeId -> NodeId -> NodeId -> [NodeId]
enumFromTo :: NodeId -> NodeId -> [NodeId]
$cenumFromTo :: NodeId -> NodeId -> [NodeId]
enumFromThen :: NodeId -> NodeId -> [NodeId]
$cenumFromThen :: NodeId -> NodeId -> [NodeId]
enumFrom :: NodeId -> [NodeId]
$cenumFrom :: NodeId -> [NodeId]
fromEnum :: NodeId -> Int
$cfromEnum :: NodeId -> Int
toEnum :: Int -> NodeId
$ctoEnum :: Int -> NodeId
pred :: NodeId -> NodeId
$cpred :: NodeId -> NodeId
succ :: NodeId -> NodeId
$csucc :: NodeId -> NodeId
Enum, Int -> NodeId -> String -> String
[NodeId] -> String -> String
NodeId -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [NodeId] -> String -> String
$cshowList :: [NodeId] -> String -> String
show :: NodeId -> String
$cshow :: NodeId -> String
showsPrec :: Int -> NodeId -> String -> String
$cshowsPrec :: Int -> NodeId -> String -> String
Show)

getChildNodes :: Picture -> [Picture]
getChildNodes :: Picture -> [Picture]
getChildNodes (Color Maybe SrcLoc
_ Color
_ Picture
p) = [Picture
p]
getChildNodes (Translate Maybe SrcLoc
_ Double
_ Double
_ Picture
p) = [Picture
p]
getChildNodes (Scale Maybe SrcLoc
_ Double
_ Double
_ Picture
p) = [Picture
p]
getChildNodes (Dilate Maybe SrcLoc
_ Double
_ Picture
p) = [Picture
p]
getChildNodes (Rotate Maybe SrcLoc
_ Double
_ Picture
p) = [Picture
p]
getChildNodes (Reflect Maybe SrcLoc
_ Double
_ Picture
p) = [Picture
p]
getChildNodes (Clip Maybe SrcLoc
_ Double
_ Double
_ Picture
p) = [Picture
p]
getChildNodes (Pictures Maybe SrcLoc
_ [Picture]
ps) = [Picture]
ps
getChildNodes (PictureAnd Maybe SrcLoc
_ [Picture]
ps) = [Picture]
ps
getChildNodes Picture
_ = []

findTopShape :: MonadCanvas m => DrawState -> Picture -> Double -> Double -> m (Maybe NodeId)
findTopShape :: forall (m :: * -> *).
MonadCanvas m =>
DrawState -> Picture -> Double -> Double -> m (Maybe NodeId)
findTopShape DrawState
ds Picture
pic Double
x Double
y = do
  (Bool
found, Int
n) <- forall {f :: * -> *} {a}.
(Num a, MonadCanvas f) =>
DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle DrawState
ds Picture
pic Double
x Double
y
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    if Bool
found
      then forall a. a -> Maybe a
Just (Int -> NodeId
NodeId Int
n)
      else forall a. Maybe a
Nothing
  where
    searchSingle :: DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle DrawState
ds (Color Maybe SrcLoc
_ Color
_ Picture
p) Double
x Double
y =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle DrawState
ds Picture
p Double
x Double
y
    searchSingle DrawState
ds (Translate Maybe SrcLoc
_ Double
dx Double
dy Picture
p) Double
x Double
y =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle (Double -> Double -> DrawState -> DrawState
translateDS Double
dx Double
dy DrawState
ds) Picture
p Double
x Double
y
    searchSingle DrawState
ds (Scale Maybe SrcLoc
_ Double
sx Double
sy Picture
p) Double
x Double
y =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle (Double -> Double -> DrawState -> DrawState
scaleDS Double
sx Double
sy DrawState
ds) Picture
p Double
x Double
y
    searchSingle DrawState
ds (Dilate Maybe SrcLoc
_ Double
k Picture
p) Double
x Double
y =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle (Double -> Double -> DrawState -> DrawState
scaleDS Double
k Double
k DrawState
ds) Picture
p Double
x Double
y
    searchSingle DrawState
ds (Rotate Maybe SrcLoc
_ Double
a Picture
p) Double
x Double
y =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle (Double -> DrawState -> DrawState
rotateDS Double
a DrawState
ds) Picture
p Double
x Double
y
    searchSingle DrawState
ds (Reflect Maybe SrcLoc
_ Double
a Picture
p) Double
x Double
y =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle (Double -> DrawState -> DrawState
reflectDS Double
a DrawState
ds) Picture
p Double
x Double
y
    searchSingle DrawState
ds (Clip Maybe SrcLoc
_ Double
w Double
h Picture
p) Double
x Double
y = do
      Bool
inClip <- forall (m :: * -> *).
MonadCanvas m =>
[Point] -> Bool -> DrawState -> Point -> m Bool
polygonContains (Double -> Double -> [Point]
rectangleVertices Double
w Double
h) Bool
False DrawState
ds (Double
x, Double
y)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
1)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool
inClip
          then DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle DrawState
ds Picture
p Double
x Double
y
          else forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, forall {a}. Num a => Picture -> a
countNodes Picture
p)
    searchSingle DrawState
ds (Pictures Maybe SrcLoc
_ [Picture]
ps) Double
x Double
y =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawState -> [Picture] -> Double -> Double -> f (Bool, a)
searchMulti DrawState
ds [Picture]
ps Double
x Double
y
    searchSingle DrawState
ds (PictureAnd Maybe SrcLoc
_ [Picture]
ps) Double
x Double
y =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawState -> [Picture] -> Double -> Double -> f (Bool, a)
searchMulti DrawState
ds [Picture]
ps Double
x Double
y
    searchSingle DrawState
ds Picture
p Double
x Double
y = do
      Bool
contained <- forall (m :: * -> *).
MonadCanvas m =>
Picture -> DrawState -> Point -> m Bool
pictureContains Picture
p DrawState
ds (Double
x, Double
y)
      if Bool
contained
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, a
0)
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, a
1)
    searchMulti :: DrawState -> [Picture] -> Double -> Double -> f (Bool, a)
searchMulti DrawState
_ [] Double
_ Double
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, a
0)
    searchMulti DrawState
ds (Picture
pic : [Picture]
pics) Double
x Double
y = do
      (Bool
found, a
count) <- DrawState -> Picture -> Double -> Double -> f (Bool, a)
searchSingle DrawState
ds Picture
pic Double
x Double
y
      if Bool
found
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, a
count)
        else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ a
count) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawState -> [Picture] -> Double -> Double -> f (Bool, a)
searchMulti DrawState
ds [Picture]
pics Double
x Double
y
    countNodes :: Picture -> a
countNodes Picture
p = a
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map Picture -> a
countNodes (Picture -> [Picture]
getChildNodes Picture
p))

-- If a picture is found, the result will include an array of the base picture
-- and all transformations.
findTopShapeFromPoint :: MonadCanvas m => Point -> Picture -> m (Maybe NodeId)
findTopShapeFromPoint :: forall (m :: * -> *).
MonadCanvas m =>
Point -> Picture -> m (Maybe NodeId)
findTopShapeFromPoint (Double
x, Double
y) Picture
pic = do
  Double
cw <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenWidth
  Double
ch <- forall (m :: * -> *). MonadCanvas m => m Double
CM.getScreenHeight
  Image m
img <- forall (m :: * -> *). MonadCanvas m => Int -> Int -> m (Image m)
CM.newImage (forall a b. (RealFrac a, Integral b) => a -> b
round Double
cw) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
ch)
  forall (m :: * -> *) a. MonadCanvas m => Image m -> m a -> m a
CM.withImage Image m
img forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). MonadCanvas m => Int -> Int -> m ()
setupScreenContext (forall a b. (RealFrac a, Integral b) => a -> b
round Double
cw) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
ch)
    forall (m :: * -> *).
MonadCanvas m =>
DrawState -> Picture -> Double -> Double -> m (Maybe NodeId)
findTopShape DrawState
initialDS Picture
pic Double
x Double
y

trim :: Int -> String -> String
trim :: Int -> String -> String
trim Int
x String
y
  | Int
x forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length String
y = String
y
  | Bool
otherwise = forall a. Int -> [a] -> [a]
take Int
mid String
y forall a. [a] -> [a] -> [a]
++ String
"..." forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse (forall a. Int -> [a] -> [a]
take Int
mid forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse String
y)
  where
    mid :: Int
mid = (Int
x forall a. Num a => a -> a -> a
- Int
3) forall a. Integral a => a -> a -> a
`div` Int
2

showFloat :: Bool -> Double -> String
showFloat :: Bool -> Double -> String
showFloat Bool
needNegParens Double
x
  | Bool
needNegParens Bool -> Bool -> Bool
&& Double
x forall a. Ord a => a -> a -> Bool
< Double
0 = String
"(" forall a. [a] -> [a] -> [a]
++ String
result forall a. [a] -> [a] -> [a]
++ String
")"
  | Bool
otherwise = String
result
  where
    result :: String
result = String -> String
stripZeros (forall a. RealFloat a => Maybe Int -> a -> String -> String
showFFloatAlt (forall a. a -> Maybe a
Just Int
4) Double
x String
"")
    stripZeros :: String -> String
stripZeros = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'.') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'0') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

showPoints :: [Point] -> String
showPoints :: [Point] -> String
showPoints [Point]
pts =
  String
"["
    forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate
      String
", "
      [ String
"(" forall a. [a] -> [a] -> [a]
++ Bool -> Double -> String
showFloat Bool
False Double
x forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Bool -> Double -> String
showFloat Bool
False Double
y forall a. [a] -> [a] -> [a]
++ String
")"
        | (Double
x, Double
y) <- [Point]
pts
      ]
    forall a. [a] -> [a] -> [a]
++ String
"]"

showColor :: Color -> String
showColor :: Color -> String
showColor c :: Color
c@(RGBA Double
r Double
g Double
b Double
a)
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
black = String
"black"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
white = String
"white"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
red = String
"red"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
green = String
"green"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
blue = String
"blue"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
yellow = String
"yellow"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
orange = String
"orange"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
brown = String
"brown"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
pink = String
"pink"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
purple = String
"purple"
  | Color
c forall a. Eq a => a -> a -> Bool
== Color
gray = String
"gray"
  | Bool
haskellMode,
    Double
a forall a. Eq a => a -> a -> Bool
== Double
1 =
    forall r. PrintfType r => String -> r
printf String
"(RGB %s %s %s)" (Bool -> Double -> String
showFloat Bool
True Double
r) (Bool -> Double -> String
showFloat Bool
True Double
g) (Bool -> Double -> String
showFloat Bool
True Double
b)
  | Double
a forall a. Eq a => a -> a -> Bool
== Double
1 =
    forall r. PrintfType r => String -> r
printf String
"RGB(%s, %s, %s)" (Bool -> Double -> String
showFloat Bool
False Double
r) (Bool -> Double -> String
showFloat Bool
False Double
g) (Bool -> Double -> String
showFloat Bool
False Double
b)
  | Bool
haskellMode =
    forall r. PrintfType r => String -> r
printf String
"(RGBA %s %s %s %s)" (Bool -> Double -> String
showFloat Bool
True Double
r) (Bool -> Double -> String
showFloat Bool
True Double
g) (Bool -> Double -> String
showFloat Bool
True Double
b) (Bool -> Double -> String
showFloat Bool
True Double
a)
  | Bool
otherwise =
    forall r. PrintfType r => String -> r
printf String
"RGBA(%s, %s, %s, %s)" (Bool -> Double -> String
showFloat Bool
False Double
r) (Bool -> Double -> String
showFloat Bool
False Double
g) (Bool -> Double -> String
showFloat Bool
False Double
b) (Bool -> Double -> String
showFloat Bool
False Double
a)

describePicture :: Picture -> String
describePicture :: Picture -> String
describePicture (Rectangle Maybe SrcLoc
_ Double
w Double
h)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"rectangle %s %s" (Bool -> Double -> String
showFloat Bool
True Double
w) (Bool -> Double -> String
showFloat Bool
True Double
h)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"rectangle(%s, %s)" (Bool -> Double -> String
showFloat Bool
False Double
w) (Bool -> Double -> String
showFloat Bool
False Double
h)
describePicture (SolidRectangle Maybe SrcLoc
_ Double
w Double
h)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"solidRectangle %s %s" (Bool -> Double -> String
showFloat Bool
True Double
w) (Bool -> Double -> String
showFloat Bool
True Double
h)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"solidRectangle(%s, %s)" (Bool -> Double -> String
showFloat Bool
False Double
w) (Bool -> Double -> String
showFloat Bool
False Double
h)
describePicture (ThickRectangle Maybe SrcLoc
_ Double
lw Double
w Double
h)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"thickRectangle %s %s %s" (Bool -> Double -> String
showFloat Bool
True Double
lw) (Bool -> Double -> String
showFloat Bool
True Double
w) (Bool -> Double -> String
showFloat Bool
True Double
h)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"thickRectangle(%s, %s, %s)" (Bool -> Double -> String
showFloat Bool
False Double
w) (Bool -> Double -> String
showFloat Bool
False Double
h) (Bool -> Double -> String
showFloat Bool
False Double
lw)
describePicture (Circle Maybe SrcLoc
_ Double
r)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"circle %s" (Bool -> Double -> String
showFloat Bool
True Double
r)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"circle(%s)" (Bool -> Double -> String
showFloat Bool
False Double
r)
describePicture (SolidCircle Maybe SrcLoc
_ Double
r)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"solidCircle %s" (Bool -> Double -> String
showFloat Bool
True Double
r)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"solidCircle(%s)" (Bool -> Double -> String
showFloat Bool
False Double
r)
describePicture (ThickCircle Maybe SrcLoc
_ Double
lw Double
r)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"thickCircle %s %s" (Bool -> Double -> String
showFloat Bool
True Double
lw) (Bool -> Double -> String
showFloat Bool
True Double
r)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"thickCircle(%s, %s)" (Bool -> Double -> String
showFloat Bool
False Double
r) (Bool -> Double -> String
showFloat Bool
False Double
lw)
describePicture (SolidPolygon Maybe SrcLoc
_ [Point]
pts)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"solidPolygon %s" ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"solidPolygon(%s)" ([Point] -> String
showPoints [Point]
pts)
describePicture (SolidClosedCurve Maybe SrcLoc
_ [Point]
pts)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"solidClosedCurve %s" ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"solidClosedCurve(%s)" ([Point] -> String
showPoints [Point]
pts)
describePicture (Polygon Maybe SrcLoc
_ [Point]
pts)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"polygon %s" ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"polygon(%s)" ([Point] -> String
showPoints [Point]
pts)
describePicture (ThickPolygon Maybe SrcLoc
_ [Point]
pts Double
w)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"thickPolygon %s %s" (Bool -> Double -> String
showFloat Bool
True Double
w) ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"thickPolygon(%s, %s)" ([Point] -> String
showPoints [Point]
pts) (Bool -> Double -> String
showFloat Bool
False Double
w)
describePicture (ClosedCurve Maybe SrcLoc
_ [Point]
pts)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"closedCurve %s" ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"closedCurve(%s)" ([Point] -> String
showPoints [Point]
pts)
describePicture (ThickClosedCurve Maybe SrcLoc
_ [Point]
pts Double
w)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"thickClosedCurve %s %s" (Bool -> Double -> String
showFloat Bool
True Double
w) ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"thickClosedCurve(%s, %s)" ([Point] -> String
showPoints [Point]
pts) (Bool -> Double -> String
showFloat Bool
False Double
w)
describePicture (Polyline Maybe SrcLoc
_ [Point]
pts)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"polyline %s" ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"polyline(%s)" ([Point] -> String
showPoints [Point]
pts)
describePicture (ThickPolyline Maybe SrcLoc
_ [Point]
pts Double
w)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"thickPolyline %s %s" (Bool -> Double -> String
showFloat Bool
True Double
w) ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"thickPolyline(%s, %s)" ([Point] -> String
showPoints [Point]
pts) (Bool -> Double -> String
showFloat Bool
False Double
w)
describePicture (Curve Maybe SrcLoc
_ [Point]
pts)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"curve %s" ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"curve(%s)" ([Point] -> String
showPoints [Point]
pts)
describePicture (ThickCurve Maybe SrcLoc
_ [Point]
pts Double
w)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"thickCurve %s %s" (Bool -> Double -> String
showFloat Bool
True Double
w) ([Point] -> String
showPoints [Point]
pts)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"thickCurve(%s, %s)" ([Point] -> String
showPoints [Point]
pts) (Bool -> Double -> String
showFloat Bool
False Double
w)
describePicture (Sector Maybe SrcLoc
_ Double
b Double
e Double
r)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"sector %s %s %s" (Bool -> Double -> String
showFloat Bool
True Double
b) (Bool -> Double -> String
showFloat Bool
True Double
e) (Bool -> Double -> String
showFloat Bool
True Double
r)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"sector(%s°, %s°, %s)" (Bool -> Double -> String
showFloat Bool
False (Double
180 forall a. Num a => a -> a -> a
* Double
b forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi)) (Bool -> Double -> String
showFloat Bool
False (Double
180 forall a. Num a => a -> a -> a
* Double
e forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi)) (Bool -> Double -> String
showFloat Bool
False Double
r)
describePicture (Arc Maybe SrcLoc
_ Double
b Double
e Double
r)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"arc %s %s %s" (Bool -> Double -> String
showFloat Bool
True Double
b) (Bool -> Double -> String
showFloat Bool
True Double
e) (Bool -> Double -> String
showFloat Bool
True Double
r)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"arc(%s°, %s°, %s)" (Bool -> Double -> String
showFloat Bool
False (Double
180 forall a. Num a => a -> a -> a
* Double
b forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi)) (Bool -> Double -> String
showFloat Bool
False (Double
180 forall a. Num a => a -> a -> a
* Double
e forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi)) (Bool -> Double -> String
showFloat Bool
False Double
r)
describePicture (ThickArc Maybe SrcLoc
_ Double
b Double
e Double
r Double
w)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"thickArc %s %s %s %s" (Bool -> Double -> String
showFloat Bool
True Double
w) (Bool -> Double -> String
showFloat Bool
True Double
b) (Bool -> Double -> String
showFloat Bool
True Double
e) (Bool -> Double -> String
showFloat Bool
True Double
r)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"thickArc(%s°, %s°, %s, %s)" (Bool -> Double -> String
showFloat Bool
False (Double
180 forall a. Num a => a -> a -> a
* Double
b forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi)) (Bool -> Double -> String
showFloat Bool
False (Double
180 forall a. Num a => a -> a -> a
* Double
e forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi)) (Bool -> Double -> String
showFloat Bool
False Double
r) (Bool -> Double -> String
showFloat Bool
False Double
w)
describePicture (Lettering Maybe SrcLoc
_ Text
txt)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"lettering %s" (forall a. Show a => a -> String
show Text
txt)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"lettering(%s)" (forall a. Show a => a -> String
show Text
txt)
describePicture (Blank Maybe SrcLoc
_) = String
"blank"
describePicture (StyledLettering Maybe SrcLoc
_ TextStyle
style Font
font Text
txt)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"styledLettering %s %s %s" (forall a. Show a => Int -> a -> String -> String
showsPrec Int
10 TextStyle
style String
"") (forall a. Show a => Int -> a -> String -> String
showsPrec Int
10 Font
font String
"") (forall a. Show a => a -> String
show Text
txt)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"styledLettering(%s, %s, %s)" (forall a. Show a => a -> String
show Text
txt) (forall a. Show a => a -> String
show Font
font) (forall a. Show a => a -> String
show TextStyle
style)
describePicture (Color Maybe SrcLoc
_ Color
c Picture
_)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"colored %s" (Color -> String
showColor Color
c)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"colored(..., %s)" (Color -> String
showColor Color
c)
describePicture (Translate Maybe SrcLoc
_ Double
x Double
y Picture
_)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"translated %s %s" (Bool -> Double -> String
showFloat Bool
True Double
x) (Bool -> Double -> String
showFloat Bool
True Double
y)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"translated(..., %s, %s)" (Bool -> Double -> String
showFloat Bool
False Double
x) (Bool -> Double -> String
showFloat Bool
False Double
y)
describePicture (Scale Maybe SrcLoc
_ Double
x Double
y Picture
_)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"scaled %s %s" (Bool -> Double -> String
showFloat Bool
True Double
x) (Bool -> Double -> String
showFloat Bool
True Double
y)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"scaled(..., %s, %s)" (Bool -> Double -> String
showFloat Bool
False Double
x) (Bool -> Double -> String
showFloat Bool
False Double
y)
describePicture (Rotate Maybe SrcLoc
_ Double
angle Picture
_)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"rotated %s" (Bool -> Double -> String
showFloat Bool
True Double
angle)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"rotated(..., %s°)" (Bool -> Double -> String
showFloat Bool
False (Double
180 forall a. Num a => a -> a -> a
* Double
angle forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi))
describePicture (Reflect Maybe SrcLoc
_ Double
angle Picture
_)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"reflected %s" (Bool -> Double -> String
showFloat Bool
True Double
angle)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"reflected(..., %s°)" (Bool -> Double -> String
showFloat Bool
False (Double
180 forall a. Num a => a -> a -> a
* Double
angle forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a
pi))
describePicture (Clip Maybe SrcLoc
_ Double
x Double
y Picture
_)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"clipped %s %s" (Bool -> Double -> String
showFloat Bool
True Double
x) (Bool -> Double -> String
showFloat Bool
True Double
y)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"clipped(..., %s, %s)" (Bool -> Double -> String
showFloat Bool
False Double
x) (Bool -> Double -> String
showFloat Bool
False Double
y)
describePicture (Dilate Maybe SrcLoc
_ Double
k Picture
_)
  | Bool
haskellMode = forall r. PrintfType r => String -> r
printf String
"dilated %s" (Bool -> Double -> String
showFloat Bool
True Double
k)
  | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"dilated(..., %s)" (Bool -> Double -> String
showFloat Bool
False Double
k)
describePicture (Sketch Maybe SrcLoc
_ Text
name Text
_ Double
_ Double
_) = Text -> String
T.unpack Text
name
describePicture (CoordinatePlane Maybe SrcLoc
_) = String
"coordinatePlane"
describePicture (Pictures Maybe SrcLoc
_ [Picture]
_)
  | Bool
haskellMode = String
"pictures"
  | Bool
otherwise = String
"pictures(...)"
describePicture (PictureAnd Maybe SrcLoc
_ [Picture]
_)
  | Bool
haskellMode = String
"(&)"
  | Bool
otherwise = String
"... & ..."

getPictureSrcLoc :: Picture -> Maybe SrcLoc
getPictureSrcLoc :: Picture -> Maybe SrcLoc
getPictureSrcLoc (SolidPolygon Maybe SrcLoc
loc [Point]
_) = Maybe SrcLoc
loc
getPictureSrcLoc (SolidClosedCurve Maybe SrcLoc
loc [Point]
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Polygon Maybe SrcLoc
loc [Point]
_) = Maybe SrcLoc
loc
getPictureSrcLoc (ThickPolygon Maybe SrcLoc
loc [Point]
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Rectangle Maybe SrcLoc
loc Double
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (SolidRectangle Maybe SrcLoc
loc Double
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (ThickRectangle Maybe SrcLoc
loc Double
_ Double
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (ClosedCurve Maybe SrcLoc
loc [Point]
_) = Maybe SrcLoc
loc
getPictureSrcLoc (ThickClosedCurve Maybe SrcLoc
loc [Point]
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Circle Maybe SrcLoc
loc Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (SolidCircle Maybe SrcLoc
loc Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (ThickCircle Maybe SrcLoc
loc Double
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Polyline Maybe SrcLoc
loc [Point]
_) = Maybe SrcLoc
loc
getPictureSrcLoc (ThickPolyline Maybe SrcLoc
loc [Point]
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Curve Maybe SrcLoc
loc [Point]
_) = Maybe SrcLoc
loc
getPictureSrcLoc (ThickCurve Maybe SrcLoc
loc [Point]
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Sector Maybe SrcLoc
loc Double
_ Double
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Arc Maybe SrcLoc
loc Double
_ Double
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (ThickArc Maybe SrcLoc
loc Double
_ Double
_ Double
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Lettering Maybe SrcLoc
loc Text
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Blank Maybe SrcLoc
loc) = Maybe SrcLoc
loc
getPictureSrcLoc (StyledLettering Maybe SrcLoc
loc TextStyle
_ Font
_ Text
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Color Maybe SrcLoc
loc Color
_ Picture
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Translate Maybe SrcLoc
loc Double
_ Double
_ Picture
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Scale Maybe SrcLoc
loc Double
_ Double
_ Picture
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Dilate Maybe SrcLoc
loc Double
_ Picture
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Rotate Maybe SrcLoc
loc Double
_ Picture
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Reflect Maybe SrcLoc
loc Double
_ Picture
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Clip Maybe SrcLoc
loc Double
_ Double
_ Picture
_) = Maybe SrcLoc
loc
getPictureSrcLoc (Sketch Maybe SrcLoc
loc Text
_ Text
_ Double
_ Double
_) = Maybe SrcLoc
loc
getPictureSrcLoc (CoordinatePlane Maybe SrcLoc
loc) = Maybe SrcLoc
loc
getPictureSrcLoc (Pictures Maybe SrcLoc
loc [Picture]
_) = Maybe SrcLoc
loc
getPictureSrcLoc (PictureAnd Maybe SrcLoc
loc [Picture]
_) = Maybe SrcLoc
loc

#ifdef ghcjs_HOST_OS

--------------------------------------------------------------------------------
-- GHCJS implementation of drawing

-- Debug Mode logic
foreign import javascript unsafe "$1.drawImage($2, $3, $4, $5, $6);"
    canvasDrawImage :: Canvas.Context -> Element -> Int -> Int -> Int -> Int -> IO ()

foreign import javascript unsafe "$1.getContext('2d', { alpha: false })"
    getCodeWorldContext :: Canvas.Canvas -> IO Canvas.Context

getCanvas :: IO Element
getCanvas = do
    js_showCanvas
    Just doc <- currentDocument
    mcanvas <- getElementById doc ("screen" :: JSString)
    case mcanvas of
        Just canvas -> return canvas
        Nothing -> do
            body <- getBodyUnsafe doc
            setAttribute body ("style" :: JSString)
                ("margin: 0; overflow: hidden" :: JSString)
            canvas <- createElement doc ("canvas" :: JSString)
            setAttribute canvas ("id" :: JSString) ("screen" :: JSString)
            setAttribute canvas ("style" :: JSString)
                ("cursor: default; width: 100vw; height: 100vh;" :: JSString)
            _ <- appendChild body canvas
            return canvas

foreign import javascript unsafe "showCanvas()"
    js_showCanvas :: IO ()

canvasFromElement :: Element -> Canvas.Canvas
canvasFromElement = Canvas.Canvas . unElement

elementFromCanvas :: Canvas.Canvas -> Element
elementFromCanvas = pFromJSVal . jsval

createFrameRenderer :: Element -> IO (Picture -> IO ())
createFrameRenderer canvas = do
    offscreenCanvas <- Canvas.create 500 500
    screen <- getCodeWorldContext (canvasFromElement canvas)
    return $ \pic -> withoutPreemption $ do
        setCanvasSize (elementFromCanvas offscreenCanvas) canvas
        rect <- getBoundingClientRect canvas
        withScreen (elementFromCanvas offscreenCanvas) rect (drawFrame pic)
        cw <- DOMRect.getWidth rect
        ch <- DOMRect.getHeight rect
        when (cw > 0.5 && ch > 0.5) $
            canvasDrawImage screen (elementFromCanvas offscreenCanvas)
                            0 0 (round cw) (round ch)

getTime :: IO Double
getTime = (/ 1000) <$> Performance.now

nextFrame :: IO Double
nextFrame = (/ 1000) <$> waitForAnimationFrame

data Node = Node
  { nodeId :: NodeId
  , nodeName :: String
  , nodeSrcLoc :: Maybe SrcLoc
  , nodeSubs :: SubNodes
  }

data SubNodes
    = NoSubNodes
    | SubNode Node
    | SubNodes [Node]

instance ToJSON Node where
    toJSON (Node id name srcLoc subs) =
        object $
            ["id" .= getNodeId id , "name" .= name]
            <> srcLoc'
            <> subs'
      where
        srcLoc' = case srcLoc of
            Nothing -> []
            Just loc -> [ "startLine" .= srcLocStartLine loc
                        , "startCol" .= srcLocStartCol loc
                        , "endLine" .= srcLocEndLine loc
                        , "endCol" .= srcLocEndCol loc
                        ]
        subs' = case subs of
            NoSubNodes -> []
            SubNode node -> ["picture" .= node]
            SubNodes nodes -> ["pictures" .= nodes]

pictureToNode :: Picture -> Node
pictureToNode = flip State.evalState (NodeId 0) . go
  where
    go pic = case pic of
        Pictures _ ps -> nodeWithChildren pic ps
        PictureAnd _ ps -> nodeWithChildren pic ps
        Color _ _ p -> nodeWithChild pic p
        Translate _ _ _ p -> nodeWithChild pic p
        Scale _ _ _ p -> nodeWithChild pic p
        Dilate _ _ p -> nodeWithChild pic p
        Rotate _ _ p -> nodeWithChild pic p
        Reflect _ _ p -> nodeWithChild pic p
        Clip _ _ _ p -> nodeWithChild pic p
        SolidPolygon _ _ -> leafNode pic
        SolidClosedCurve _ _ -> leafNode pic
        Polygon _ _ -> leafNode pic
        ThickPolygon _ _ _ -> leafNode pic
        Rectangle _ _ _ -> leafNode pic
        SolidRectangle _ _ _ -> leafNode pic
        ThickRectangle _ _ _ _ -> leafNode pic
        ClosedCurve _ _ -> leafNode pic
        ThickClosedCurve _ _ _ -> leafNode pic
        Polyline _ _ -> leafNode pic
        ThickPolyline _ _ _ -> leafNode pic
        Curve _ _ -> leafNode pic
        ThickCurve _ _ _ -> leafNode pic
        Circle _ _ -> leafNode pic
        SolidCircle _ _ -> leafNode pic
        ThickCircle _ _ _ -> leafNode pic
        Sector _ _ _ _ -> leafNode pic
        Arc _ _ _ _ -> leafNode pic
        ThickArc _ _ _ _ _ -> leafNode pic
        StyledLettering _ _ _ _ -> leafNode pic
        Lettering _ _ -> leafNode pic
        CoordinatePlane _ -> leafNode pic
        Sketch _ _ _ _ _ -> leafNode pic
        Blank _ -> leafNode pic

    nodeWithChildren pic subs = node pic (SubNodes <$> traverse go subs)
    nodeWithChild pic sub = node pic (SubNode <$> go sub)
    leafNode pic = node pic (pure NoSubNodes)

    node pic getSubNodes = do
        nodeId <- State.get <* State.modify' succ
        let nodeName = trim 80 . describePicture $ pic
        let nodeSrcLoc = getPictureSrcLoc pic
        nodeSubs <- getSubNodes
        pure (Node {..})

foreign import javascript unsafe "/\\bmode=haskell\\b/.test(location.search)"
    haskellMode :: Bool

withScreen :: Element -> DOMRect.DOMRect -> CanvasM a -> IO a
withScreen canvas rect action = do
    cw <- realToFrac <$> DOMRect.getWidth rect
    ch <- realToFrac <$> DOMRect.getHeight rect
    ctx <- getCodeWorldContext (canvasFromElement canvas)
    runCanvasM (cw, ch) ctx $ CM.saveRestore $ do
        setupScreenContext (round cw) (round ch)
        action

setCanvasSize :: Element -> Element -> IO ()
setCanvasSize target canvas = do
    rect <- getBoundingClientRect canvas
    cx <- DOMRect.getWidth rect
    cy <- DOMRect.getHeight rect
    setAttribute target ("width" :: JSString) (show (round cx :: Int))
    setAttribute target ("height" :: JSString) (show (round cy :: Int))

#else

--------------------------------------------------------------------------------
-- Stand-alone implementation of drawing

haskellMode :: Bool
haskellMode :: Bool
haskellMode = Bool
True

type Port = Int

readPortFromEnv :: String -> Port -> IO Port
readPortFromEnv :: String -> Int -> IO Int
readPortFromEnv String
envName Int
defaultPort = do
    Maybe String
ms <- String -> IO (Maybe String)
lookupEnv String
envName
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a -> a
fromMaybe Int
defaultPort (Maybe String
ms forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Read a => String -> Maybe a
readMaybe))

runBlankCanvas :: (Canvas.DeviceContext -> IO ()) -> IO ()
runBlankCanvas :: (DeviceContext -> IO ()) -> IO ()
runBlankCanvas DeviceContext -> IO ()
act = do
    Int
port <- String -> Int -> IO Int
readPortFromEnv String
"CODEWORLD_API_PORT" Int
3000
    let options :: Options
options =
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port)
            { events :: [Text]
Canvas.events =
                  [Text
"mousedown", Text
"mouseup", Text
"mousemove", Text
"keydown", Text
"keyup"],
              middleware :: [Middleware]
Canvas.middleware = []
            }
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"Open me on http://127.0.0.1:%d/" (Options -> Int
Canvas.port Options
options)
    Options -> (DeviceContext -> IO ()) -> IO ()
Canvas.blankCanvas Options
options forall a b. (a -> b) -> a -> b
$ \DeviceContext
context -> do
        String -> IO ()
putStrLn String
"Program is starting..."
        DeviceContext -> IO ()
act DeviceContext
context

#endif

--------------------------------------------------------------------------------
-- Common event handling and core interaction code

keyCodeToText :: Word -> Text
keyCodeToText :: Word -> Text
keyCodeToText Word
n =
  case Word
n of
    Word
_ | Word
n forall a. Ord a => a -> a -> Bool
>= Word
47 Bool -> Bool -> Bool
&& Word
n forall a. Ord a => a -> a -> Bool
<= Word
90 -> forall {a}. Integral a => a -> Text
fromAscii Word
n
    Word
_ | Word
n forall a. Ord a => a -> a -> Bool
>= Word
96 Bool -> Bool -> Bool
&& Word
n forall a. Ord a => a -> a -> Bool
<= Word
105 -> forall {a}. Show a => a -> Text
fromNum (Word
n forall a. Num a => a -> a -> a
- Word
96)
    Word
_ | Word
n forall a. Ord a => a -> a -> Bool
>= Word
112 Bool -> Bool -> Bool
&& Word
n forall a. Ord a => a -> a -> Bool
<= Word
135 -> Text
"F" forall a. Semigroup a => a -> a -> a
<> forall {a}. Show a => a -> Text
fromNum (Word
n forall a. Num a => a -> a -> a
- Word
111)
    Word
3 -> Text
"Cancel"
    Word
6 -> Text
"Help"
    Word
8 -> Text
"Backspace"
    Word
9 -> Text
"Tab"
    Word
12 -> Text
"5"
    Word
13 -> Text
"Enter"
    Word
16 -> Text
"Shift"
    Word
17 -> Text
"Ctrl"
    Word
18 -> Text
"Alt"
    Word
19 -> Text
"Break"
    Word
20 -> Text
"CapsLock"
    Word
27 -> Text
"Esc"
    Word
32 -> Text
" "
    Word
33 -> Text
"PageUp"
    Word
34 -> Text
"PageDown"
    Word
35 -> Text
"End"
    Word
36 -> Text
"Home"
    Word
37 -> Text
"Left"
    Word
38 -> Text
"Up"
    Word
39 -> Text
"Right"
    Word
40 -> Text
"Down"
    Word
42 -> Text
"*"
    Word
43 -> Text
"+"
    Word
44 -> Text
"PrintScreen"
    Word
45 -> Text
"Insert"
    Word
46 -> Text
"Delete"
    Word
47 -> Text
"Help"
    Word
91 -> Text
"OS"
    Word
92 -> Text
"OS"
    Word
93 -> Text
"ContextMenu"
    Word
106 -> Text
"*"
    Word
107 -> Text
"+"
    Word
108 -> Text
","
    Word
109 -> Text
"-"
    Word
110 -> Text
"."
    Word
111 -> Text
"/"
    Word
144 -> Text
"NumLock"
    Word
145 -> Text
"ScrollLock"
    Word
173 -> Text
"-"
    Word
186 -> Text
";"
    Word
187 -> Text
"="
    Word
188 -> Text
","
    Word
189 -> Text
"-"
    Word
190 -> Text
"."
    Word
191 -> Text
"/"
    Word
192 -> Text
"`"
    Word
193 -> Text
"IntlRo"
    Word
194 -> Text
","
    Word
219 -> Text
"["
    Word
220 -> Text
"\\"
    Word
221 -> Text
"]"
    Word
222 -> Text
"'"
    Word
225 -> Text
"AltGraph"
    Word
255 -> Text
"IntlYen"
    Word
_ -> Text
"Unknown:" forall a. Semigroup a => a -> a -> a
<> forall {a}. Show a => a -> Text
fromNum Word
n
  where
    fromAscii :: a -> Text
fromAscii a
n = Char -> Text
T.singleton (Int -> Char
chr (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n))
    fromNum :: a -> Text
fromNum a
n = String -> Text
T.pack (forall a. Show a => a -> String
show a
n)

isUniversallyConstant :: (a -> s -> s) -> s -> Bool
isUniversallyConstant :: forall a s. (a -> s -> s) -> s -> Bool
isUniversallyConstant a -> s -> s
f s
old =
  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ IO Bool -> IO Bool
falseOr forall a b. (a -> b) -> a -> b
$ do
    StableName s
oldName <- forall a. a -> IO (StableName a)
makeStableName forall a b. (a -> b) -> a -> b
$! s
old
    StableName s
genName <- forall a. a -> IO (StableName a)
makeStableName forall a b. (a -> b) -> a -> b
$! a -> s -> s
f forall a. HasCallStack => a
undefined s
old
    forall (m :: * -> *) a. Monad m => a -> m a
return (StableName s
genName forall a. Eq a => a -> a -> Bool
== StableName s
oldName)
  where
    falseOr :: IO Bool -> IO Bool
falseOr IO Bool
x = IO Bool
x forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

ifDifferent :: (s -> s) -> s -> Maybe s
ifDifferent :: forall s. (s -> s) -> s -> Maybe s
ifDifferent s -> s
f s
s0 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  StableName s
oldName <- forall a. a -> IO (StableName a)
makeStableName forall a b. (a -> b) -> a -> b
$! s
s0
  StableName s
newName <- forall a. a -> IO (StableName a)
makeStableName forall a b. (a -> b) -> a -> b
$! s
s1
  if StableName s
newName forall a. Eq a => a -> a -> Bool
== StableName s
oldName then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just s
s1)
  where
    s1 :: s
s1 = s -> s
f s
s0

modifyMVarIfDifferent :: MVar s -> (s -> s) -> IO Bool
modifyMVarIfDifferent :: forall s. MVar s -> (s -> s) -> IO Bool
modifyMVarIfDifferent MVar s
var s -> s
f =
  forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar s
var forall a b. (a -> b) -> a -> b
$ \s
s0 ->
    case forall s. (s -> s) -> s -> Maybe s
ifDifferent s -> s
f s
s0 of
      Maybe s
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (s
s0, Bool
False)
      Just s
s1 -> forall (m :: * -> *) a. Monad m => a -> m a
return (s
s1, Bool
True)

data GameToken
  = FullToken
      { GameToken -> Text
tokenDeployHash :: Text,
        GameToken -> Int
tokenNumPlayers :: Int,
        GameToken -> Fingerprint
tokenInitial :: StaticKey,
        GameToken -> Fingerprint
tokenStep :: StaticKey,
        GameToken -> Fingerprint
tokenEvent :: StaticKey,
        GameToken -> Fingerprint
tokenDraw :: StaticKey
      }
  | SteplessToken
      { tokenDeployHash :: Text,
        tokenNumPlayers :: Int,
        tokenInitial :: StaticKey,
        tokenEvent :: StaticKey,
        tokenDraw :: StaticKey
      }
  | PartialToken {tokenDeployHash :: Text}
  deriving (forall x. Rep GameToken x -> GameToken
forall x. GameToken -> Rep GameToken x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GameToken x -> GameToken
$cfrom :: forall x. GameToken -> Rep GameToken x
Generic)

#if !MIN_VERSION_base(4,15,0)
deriving instance Generic Fingerprint
#endif

instance Serialize Fingerprint

instance Serialize GameToken

#ifdef ghcjs_HOST_OS

--------------------------------------------------------------------------------
-- GHCJS event handling and core interaction code

screenCoordsToPoint :: Element -> Double -> Double -> IO Point
screenCoordsToPoint canvas sx sy = do
    rect <- getBoundingClientRect canvas
    cx <- realToFrac <$> DOMRect.getX rect
    cy <- realToFrac <$> DOMRect.getY rect
    cw <- realToFrac <$> DOMRect.getWidth rect
    ch <- realToFrac <$> DOMRect.getHeight rect
    let unitLen = min cw ch / 20
    let midx = cx + cw / 2
    let midy = cy + ch / 2
    return ((sx - midx) / unitLen, (midy - sy) / unitLen)

getMousePos :: IsMouseEvent e => Element -> EventM w e Point
getMousePos canvas = do
    (ix, iy) <- mouseClientXY
    liftIO $ screenCoordsToPoint canvas (fromIntegral ix) (fromIntegral iy)

onEvents :: Element -> (Event -> IO ()) -> IO ()
onEvents canvas handler = do
    Just window <- currentWindow
    _ <- on window keyDown $ do
        code <- getKeyCode =<< event
        let keyName = keyCodeToText code
        when (keyName /= "") $ do
            liftIO $ handler (KeyPress keyName)
            preventDefault
            stopPropagation
        key <- getKey =<< event
        when (T.length key == 1) $ do
            liftIO $ handler (TextEntry key)
            preventDefault
            stopPropagation
    _ <- on window keyUp $ do
        code <- getKeyCode =<< event
        let keyName = keyCodeToText code
        when (keyName /= "") $ do
            liftIO $ handler (KeyRelease keyName)
            preventDefault
            stopPropagation
    _ <- on window mouseDown $ do
        pos <- getMousePos canvas
        liftIO $ handler (PointerPress pos)
    _ <- on window mouseUp $ do
        pos <- getMousePos canvas
        liftIO $ handler (PointerRelease pos)
    _ <- on window mouseMove $ do
        pos <- getMousePos canvas
        liftIO $ handler (PointerMovement pos)
    return ()

encodeEvent :: (Timestamp, Maybe Event) -> String
encodeEvent = show

decodeEvent :: String -> Maybe (Timestamp, Maybe Event)
decodeEvent = readMaybe

data GameState s
    = Main (UIState SMain)
    | Connecting WS.WebSocket
                 (UIState SConnect)
    | Waiting WS.WebSocket
              GameId
              PlayerId
              (UIState SWait)
    | Running WS.WebSocket
              GameId
              Timestamp
              PlayerId
              (Future s)

gameTime :: GameState s -> Timestamp -> Double
gameTime (Running _ _ tstart _ _) t = t - tstart
gameTime _ _ = 0

-- It's worth trying to keep the canonical animation rate exactly representable
-- as a float, to minimize the chance of divergence due to rounding error.
gameRate :: Double
gameRate = 1 / 16

gameStep :: (Double -> s -> s) -> Double -> GameState s -> GameState s
gameStep _ t (Main s) = Main (CUI.step t s)
gameStep _ t (Connecting ws s) = Connecting ws (CUI.step t s)
gameStep _ t (Waiting ws gid pid s) = Waiting ws gid pid (CUI.step t s)
gameStep step t (Running ws gid tstart pid s) =
    Running ws gid tstart pid (currentTimePasses step gameRate (t - tstart) s)

gameDraw ::
       (Double -> s -> s)
    -> (PlayerId -> s -> Picture)
    -> GameState s
    -> Timestamp
    -> Picture
gameDraw _ _ (Main s) _ = CUI.picture s
gameDraw _ _ (Connecting _ s) _ = CUI.picture s
gameDraw _ _ (Waiting _ _ _ s) _ = CUI.picture s
gameDraw step draw (Running _ _ tstart pid s) t =
    draw pid (currentState step gameRate (t - tstart) s)

handleServerMessage ::
       Int
    -> (StdGen -> s)
    -> (Double -> s -> s)
    -> (PlayerId -> Event -> s -> s)
    -> MVar (GameState s)
    -> ServerMessage
    -> IO ()
handleServerMessage numPlayers initial stepHandler eventHandler gsm sm = do
    modifyMVar_ gsm $ \gs -> do
        t <- getTime
        case (sm, gs) of
            (GameAborted, _) -> return initialGameState
            (JoinedAs pid gid, Connecting ws s) ->
                return (Waiting ws gid pid (CUI.startWaiting gid s))
            (PlayersWaiting m n, Waiting ws gid pid s) ->
                return (Waiting ws gid pid (CUI.updatePlayers n m s))
            (Started, Waiting ws gid pid _) -> do
                let s = initFuture (initial (mkStdGen (hash gid))) numPlayers
                return (Running ws gid t pid s)
            (OutEvent pid eo, Running ws gid tstart mypid s) ->
                case decodeEvent eo of
                    Just (t', event) ->
                        let ours = pid == mypid
                            func = eventHandler pid <$> event -- might be a ping (Nothing)
                            result
                                | ours = s -- we already took care of our events
                                | otherwise =
                                    addEvent stepHandler gameRate mypid t' func s
                        in return (Running ws gid tstart mypid result)
                    Nothing -> return (Running ws gid tstart mypid s)
            _ -> return gs
    return ()

gameHandle ::
       Int
    -> (StdGen -> s)
    -> (Double -> s -> s)
    -> (PlayerId -> Event -> s -> s)
    -> GameToken
    -> MVar (GameState s)
    -> Event
    -> IO ()
gameHandle numPlayers initial stepHandler eventHandler token gsm event = do
    gs <- takeMVar gsm
    case gs of
        Main s ->
            case CUI.event event s of
                ContinueMain s' -> do
                    putMVar gsm (Main s')
                Create s' -> do
                    ws <-
                        connectToGameServer
                            (handleServerMessage
                                 numPlayers
                                 initial
                                 stepHandler
                                 eventHandler
                                 gsm)
                    sendClientMessage ws (NewGame numPlayers (encode token))
                    putMVar gsm (Connecting ws s')
                Join gid s' -> do
                    ws <-
                        connectToGameServer
                            (handleServerMessage
                                 numPlayers
                                 initial
                                 stepHandler
                                 eventHandler
                                 gsm)
                    sendClientMessage ws (JoinGame gid (encode token))
                    putMVar gsm (Connecting ws s')
        Connecting ws s ->
            case CUI.event event s of
                ContinueConnect s' -> do
                    putMVar gsm (Connecting ws s')
                CancelConnect s' -> do
                    WS.close Nothing Nothing ws
                    putMVar gsm (Main s')
        Waiting ws gid pid s ->
            case CUI.event event s of
                ContinueWait s' -> do
                    putMVar gsm (Waiting ws gid pid s')
                CancelWait s' -> do
                    WS.close Nothing Nothing ws
                    putMVar gsm (Main s')
        Running ws gid tstart pid f -> do
            t <- getTime
            let gameState0 = currentState stepHandler gameRate (t - tstart) f
            let eventFun = eventHandler pid event
            case ifDifferent eventFun gameState0 of
                Nothing -> putMVar gsm gs
                Just _ -> do
                    sendClientMessage
                        ws
                        (InEvent (encodeEvent (gameTime gs t, Just event)))
                    let f1 =
                            addEvent
                                stepHandler
                                gameRate
                                pid
                                (t - tstart)
                                (Just eventFun)
                                f
                    putMVar gsm (Running ws gid tstart pid f1)

getWebSocketURL :: IO JSString
getWebSocketURL = do
    loc <- Loc.getWindowLocation
    proto <- Loc.getProtocol loc
    hostname <- Loc.getHostname loc
    let url =
            case proto of
                "http:" -> "ws://" <> hostname <> ":9160/gameserver"
                "https:" -> "wss://" <> hostname <> "/gameserver"
                _ -> error "Unrecognized protocol"
    return url

connectToGameServer :: (ServerMessage -> IO ()) -> IO WS.WebSocket
connectToGameServer handleServerMessage = do
    let handleWSRequest m = do
            maybeSM <- decodeServerMessage m
            case maybeSM of
                Nothing -> return ()
                Just sm -> handleServerMessage sm
    wsURL <- getWebSocketURL
    let req =
            WS.WebSocketRequest
            { url = wsURL
            , protocols = []
            , onClose = Just $ \_ -> handleServerMessage GameAborted
            , onMessage = Just handleWSRequest
            }
    WS.connect req
  where
    decodeServerMessage :: WS.MessageEvent -> IO (Maybe ServerMessage)
    decodeServerMessage m =
        case WS.getData m of
            WS.StringData str -> do
                return $ readMaybe (Data.JSString.unpack str)
            _ -> return Nothing

sendClientMessage :: WS.WebSocket -> ClientMessage -> IO ()
sendClientMessage ws msg = WS.send (encodeClientMessage msg) ws
  where
    encodeClientMessage :: ClientMessage -> JSString
    encodeClientMessage m = Data.JSString.pack (show m)

initialGameState :: GameState s
initialGameState = Main CUI.initial

foreign import javascript unsafe "cw$deterministic_math();"
    enableDeterministicMath :: IO ()

runGame ::
       GameToken
    -> Int
    -> (StdGen -> s)
    -> (Double -> s -> s)
    -> (Int -> Event -> s -> s)
    -> (Int -> s -> Picture)
    -> IO ()
runGame token numPlayers initial stepHandler eventHandler drawHandler = do
    enableDeterministicMath
    let fullStepHandler dt = stepHandler dt . eventHandler (-1) (TimePassing dt)

    canvas <- getCanvas
    setCanvasSize canvas canvas

    Just window <- currentWindow
    _ <- on window resize $ do
        liftIO $ setCanvasSize canvas canvas

    frameRenderer <- createFrameRenderer canvas

    currentGameState <- newMVar initialGameState
    onEvents canvas $
        gameHandle
            numPlayers
            initial
            fullStepHandler
            eventHandler
            token
            currentGameState

    let go t0 lastFrame = do
            gs <- readMVar currentGameState
            let pic = gameDraw fullStepHandler drawHandler gs t0
            picFrame <- makeStableName $! pic
            when (picFrame /= lastFrame) $ frameRenderer pic
            t1 <- nextFrame
            modifyMVar_ currentGameState $ return . gameStep fullStepHandler t1
            go t1 picFrame
    t0 <- nextFrame
    nullFrame <- makeStableName undefined
    go t0 nullFrame

getDeployHash :: IO Text
getDeployHash = pFromJSVal <$> js_getDeployHash

foreign import javascript "/[&?]dhash=(.{22})/.exec(window.location.search)[1]"
    js_getDeployHash :: IO JSVal

propagateErrors :: ThreadId -> IO () -> IO ()
propagateErrors tid action = action `catch` \ (e :: SomeException) -> throwTo tid e

run :: s
    -> (Double -> s -> s)
    -> (e -> s -> s)
    -> (s -> Picture)
    -> (Double -> e)
    -> IO (e -> IO (), IO s)
run initial stepHandler eventHandler drawHandler injectTime = do
    let fullStepHandler dt = stepHandler dt . eventHandler (injectTime dt)

    canvas <- getCanvas

    needsRedraw <- newMVar ()
    Just window <- currentWindow
    _ <- on window resize $ void $ liftIO $ do
        setCanvasSize canvas canvas
        tryPutMVar needsRedraw ()
    setCanvasSize canvas canvas

    frameRenderer <- createFrameRenderer canvas
    currentState <- newMVar initial
    eventHappened <- newMVar ()
    let go t0 lastFrame lastStateName needsTime = do
            pic <- drawHandler <$> readMVar currentState
            picFrame <- makeStableName $! pic
            when (picFrame /= lastFrame) $ frameRenderer pic
            t1 <-
                case needsTime of
                    True -> do
                        t1 <- nextFrame
                        let dt = min (t1 - t0) 0.25
                        when (dt > 0) $ void $
                            modifyMVarIfDifferent currentState (fullStepHandler dt)
                        return t1
                    False -> do
                        takeMVar eventHappened
                        nextFrame
            nextState <- readMVar currentState
            nextStateName <- makeStableName $! nextState
            let nextNeedsTime =
                    nextStateName /= lastStateName ||
                    needsTime && not (isUniversallyConstant fullStepHandler nextState)
            redrawResult <- tryTakeMVar needsRedraw
            nextFrame <- case redrawResult of
                Nothing -> return picFrame
                Just () -> makeStableName undefined
            go t1 nextFrame nextStateName nextNeedsTime
    t0 <- nextFrame
    nullFrame <- makeStableName undefined
    initialStateName <- makeStableName $! initial
    mainThread <- myThreadId
    drawThread <- forkIO $ propagateErrors mainThread $
        go t0 nullFrame initialStateName True
    let sendEvent event = propagateErrors drawThread $ do
            changed <-
                modifyMVarIfDifferent currentState (eventHandler event)
            when changed $ void $ tryPutMVar eventHappened ()
        getState = readMVar currentState
    return (sendEvent, getState)

getNodeAtCoords :: Element -> Double -> Double -> Picture -> IO (Maybe NodeId)
getNodeAtCoords canvas x y pic = do
    rect <- getBoundingClientRect canvas
    cx <- realToFrac <$> DOMRect.getX rect
    cy <- realToFrac <$> DOMRect.getY rect
    cw <- realToFrac <$> DOMRect.getWidth rect
    ch <- realToFrac <$> DOMRect.getHeight rect

    -- It's safe to pass undefined for the context because
    -- findTopShapeFromPoint only draws to an offscreen buffer.
    runCanvasM (cw, ch) undefined $
        findTopShapeFromPoint (x - cx, y - cy) pic

drawPartialPic :: Element -> NodeId -> Picture -> IO ()
drawPartialPic canvas nodeId pic = do
    setCanvasSize canvas canvas
    let node = fromMaybe blank (getNode nodeId pic)
    frameRenderer <- createFrameRenderer canvas
    frameRenderer (node <> coordinatePlane)

applySelectAndHighlights :: Maybe NodeId -> [NodeId] -> Picture -> Picture
applySelectAndHighlights sel hs p = applyHighlights hs' p'
    where (p', hs') = applySelect sel (p, hs)

applySelect :: Maybe NodeId -> (Picture, [NodeId]) -> (Picture, [NodeId])
applySelect Nothing (pic, highlights) = (pic, highlights)
applySelect (Just (NodeId n)) (pic, highlights) =
    case getNode (NodeId n) pic of
        Nothing -> (pic, highlights)
        Just pic' -> (pic', [ NodeId (h - n) | NodeId h <- highlights ])

applyHighlights :: [NodeId] -> Picture -> Picture
applyHighlights hs p = pictures [highlight h p | h <- hs] <> p

highlight :: NodeId -> Picture -> Picture
highlight n pic = case getTransformedNode n pic of
    Nothing -> blank
    Just shape -> colored (RGBA 0 0 0 0.25) shape

indexNode :: Bool -> Int -> NodeId -> Picture -> Either Int Picture
indexNode _ i (NodeId n) p
    | i == n = Right p
    | i > n = Left 0
indexNode True i n (Translate loc x y p)
    = Translate loc x y <$> indexNode True (i + 1) n p
indexNode True i n (Scale loc x y p)
    = Scale loc x y <$> indexNode True (i + 1) n p
indexNode True i n (Dilate loc k p)
    = Dilate loc k <$> indexNode True (i + 1) n p
indexNode True i n (Rotate loc r p)
    = Rotate loc r <$> indexNode True (i + 1) n p
indexNode True i n (Reflect loc r p)
    = Reflect loc r <$> indexNode True (i + 1) n p
indexNode True i n (Clip loc x y p)
    = Clip loc x y <$> indexNode True (i + 1) n p
indexNode keepTx i n p = go keepTx (i + 1) (getChildNodes p)
  where go _ i [] = Left i
        go keepTx i (pic:pics) =
            case indexNode keepTx i n pic of
                Left ii -> go keepTx ii pics
                Right p -> Right p

getTransformedNode :: NodeId -> Picture -> Maybe Picture
getTransformedNode n pic = either (const Nothing) Just (indexNode True 0 n pic)

getNode :: NodeId -> Picture -> Maybe Picture
getNode n pic = either (const Nothing) Just (indexNode False 0 n pic)

data DebugState = DebugState
    { debugStateActive :: Bool
    , shapeHighlighted :: Maybe NodeId
    , shapeSelected :: Maybe NodeId
    } deriving (Eq, Show)

debugStateInit :: DebugState
debugStateInit = DebugState False Nothing Nothing

startDebugState :: DebugState -> DebugState
startDebugState = const (DebugState True Nothing Nothing)

stopDebugState :: DebugState -> DebugState
stopDebugState = const (DebugState False Nothing Nothing)

highlightDebugState :: Maybe NodeId -> DebugState -> DebugState
highlightDebugState n prev =
    case debugStateActive prev of
        True -> prev {shapeHighlighted = n}
        False -> DebugState False Nothing Nothing

selectDebugState :: Maybe NodeId -> DebugState -> DebugState
selectDebugState n prev =
    case debugStateActive prev of
        True -> prev {shapeSelected = n}
        False -> DebugState False Nothing Nothing

drawDebugState :: DebugState -> Picture -> Picture -> Picture
drawDebugState state inspectPic displayPic =
    case debugStateActive state of
        True -> applySelectAndHighlights
            (shapeSelected state)
            (maybeToList (shapeHighlighted state))
            inspectPic
        False -> displayPic

connectInspect
    :: Element
    -> IO Picture
    -> ((DebugState -> DebugState) -> IO ())
    -> IO ()
connectInspect canvas samplePicture fireUpdate = do
    -- Sample the current user picture to search for a current node.
    getNodeCB <- syncCallback1' $ \pointJS -> do
        let obj = unsafeCoerce pointJS
        x <- pFromJSVal <$> getProp "x" obj
        y <- pFromJSVal <$> getProp "y" obj
        n <- getNodeAtCoords canvas x y =<< samplePicture
        return (pToJSVal (maybe (-1) getNodeId n))

    -- Sample the current user picture to return the scene tree.
    getPicCB <- syncCallback' $ samplePicture >>= toJSVal_aeson . pictureToNode

    -- Fire an event to change debug active state.
    setActiveCB <- syncCallback1 ContinueAsync $ \ active -> case pFromJSVal active of
        True  -> fireUpdate startDebugState
        False -> fireUpdate stopDebugState

    -- Fire an event to change the highlight or selection.
    highlightCB <- syncCallback2 ContinueAsync $ \t n -> do
        let isHighlight = pFromJSVal t
        let nodeNum = pFromJSVal n
        let nodeId = if nodeNum < 0 then Nothing else Just (NodeId nodeNum)
        if isHighlight then fireUpdate (highlightDebugState nodeId)
                       else fireUpdate (selectDebugState nodeId)

    js_initDebugMode getNodeCB setActiveCB getPicCB highlightCB

foreign import javascript unsafe "initDebugMode($1,$2,$3,$4)"
    js_initDebugMode :: Callback (JSVal -> IO JSVal)
                     -> Callback (JSVal -> IO ())
                     -> Callback (IO JSVal)
                     -> Callback (JSVal -> JSVal -> IO ())
                     -> IO ()

-- Utility functions that apply a function in either the left or right half of a
-- tuple.  Crucially, if the function preserves sharing on its side, then the
-- wrapper also preserves sharing.
inLeft :: (a -> a) -> (a, b) -> (a, b)
inLeft f ab = unsafePerformIO $ do
  let (a, b) = ab
  aName <- makeStableName $! a
  let a' = f a
  aName' <- makeStableName $! a'
  return $ if aName == aName' then ab else (a', b)

inRight :: (b -> b) -> (a, b) -> (a, b)
inRight f ab = unsafePerformIO $ do
  let (a, b) = ab
  bName <- makeStableName $! b
  let b' = f b
  bName' <- makeStableName $! b'
  return $ if bName == bName' then ab else (a, b')

foreign import javascript interruptible "window.dummyVar = 0;"
  waitForever :: IO ()

-- Wraps the event and state from run so they can be paused by pressing the Inspect
-- button.
runInspect
    :: s
    -> (Double -> s -> s)
    -> (Event -> s -> s)
    -> (s -> Picture)
    -> (s -> Picture)
    -> IO ()
runInspect initial step event draw rawDraw = do
    -- Ensure that the first frame picture doesn't expose any type errors,
    -- before showing the canvas.  This avoids showing a blank screen when
    -- there are deferred type errors that are effectively compile errors.
    evaluate $ rnf $ rawDraw initial

    let debugInitial = (debugStateInit, initial)
        debugStep dt s@(debugState, _) =
            case debugStateActive debugState of
                True -> s
                False -> inRight (step dt) s
        debugEvent evt s@(debugState, _) =
            case (debugStateActive debugState, evt) of
                (_, Left f) -> inLeft f s
                (True, _) -> s
                (_, Right e) -> inRight (event e) s
        debugDraw (debugState, s) =
            drawDebugState debugState (rawDraw s) (draw s)
        debugRawDraw (_debugState, s) = rawDraw s
    (sendEvent, getState) <-
        run debugInitial debugStep debugEvent debugDraw (Right . TimePassing)

    canvas <- getCanvas
    onEvents canvas (sendEvent . Right)
    connectInspect canvas (debugRawDraw <$> getState) (sendEvent . Left)

    waitForever

#else

--------------------------------------------------------------------------------
-- Stand-Alone event handling and core interaction code

getMousePos :: (Int, Int) -> (Double, Double) -> (Double, Double)
getMousePos :: (Int, Int) -> Point -> Point
getMousePos (Int
w, Int
h) (Double
x, Double
y) =
    ((Double
x forall a. Num a => a -> a -> a
- Double
mx) forall a. Fractional a => a -> a -> a
/ Double
unitLen, (Double
my forall a. Num a => a -> a -> a
- Double
y) forall a. Fractional a => a -> a -> a
/ Double
unitLen)
  where
    w' :: Double
w' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
    h' :: Double
h' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
    unitLen :: Double
unitLen = forall a. Ord a => a -> a -> a
min Double
w' Double
h' forall a. Fractional a => a -> a -> a
/ Double
20
    mx :: Double
mx = Double
w' forall a. Fractional a => a -> a -> a
/ Double
2
    my :: Double
my = Double
h' forall a. Fractional a => a -> a -> a
/ Double
2

toEvent :: (Int, Int) -> Canvas.Event -> Maybe Event
toEvent :: (Int, Int) -> Event -> Maybe Event
toEvent (Int, Int)
rect (Canvas.Event {Bool
Maybe Int
Maybe Point
Text
eMetaKey :: Event -> Bool
ePageXY :: Event -> Maybe Point
eType :: Event -> Text
eWhich :: Event -> Maybe Int
eWhich :: Maybe Int
eType :: Text
ePageXY :: Maybe Point
eMetaKey :: Bool
..})
    | Text
eType forall a. Eq a => a -> a -> Bool
== Text
"keydown"
    , Just Int
code <- Maybe Int
eWhich = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Event
KeyPress (Word -> Text
keyCodeToText (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
code))
    | Text
eType forall a. Eq a => a -> a -> Bool
== Text
"keyup"
    , Just Int
code <- Maybe Int
eWhich =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Event
KeyRelease (Word -> Text
keyCodeToText (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
code))
    | Text
eType forall a. Eq a => a -> a -> Bool
== Text
"mousedown"
    , Just Point
pos <- (Int, Int) -> Point -> Point
getMousePos (Int, Int)
rect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Point
ePageXY = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Point -> Event
PointerPress Point
pos
    | Text
eType forall a. Eq a => a -> a -> Bool
== Text
"mouseup"
    , Just Point
pos <- (Int, Int) -> Point -> Point
getMousePos (Int, Int)
rect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Point
ePageXY = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Point -> Event
PointerRelease Point
pos
    | Text
eType forall a. Eq a => a -> a -> Bool
== Text
"mousemove"
    , Just Point
pos <- (Int, Int) -> Point -> Point
getMousePos (Int, Int)
rect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Point
ePageXY = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Point -> Event
PointerMovement Point
pos
    | Bool
otherwise = forall a. Maybe a
Nothing

onEvents :: Canvas.DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO ()
onEvents :: DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO ()
onEvents DeviceContext
context (Int, Int)
rect Event -> IO ()
handler = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    Maybe Event
maybeEvent <- (Int, Int) -> Event -> Maybe Event
toEvent (Int, Int)
rect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DeviceContext -> IO Event
Canvas.wait DeviceContext
context
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Event
maybeEvent Event -> IO ()
handler

run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()
run :: forall s.
s
-> (Double -> s -> s)
-> (Event -> s -> s)
-> (s -> Picture)
-> IO ()
run s
initial Double -> s -> s
stepHandler Event -> s -> s
eventHandler s -> Picture
drawHandler =
    (DeviceContext -> IO ()) -> IO ()
runBlankCanvas forall a b. (a -> b) -> a -> b
$ \DeviceContext
context -> do
        let fullStepHandler :: Double -> s -> s
fullStepHandler Double
dt = Double -> s -> s
stepHandler Double
dt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> s -> s
eventHandler (Double -> Event
TimePassing Double
dt)
        let cw :: Int
cw = forall image a. (Image image, Num a) => image -> a
Canvas.width DeviceContext
context
        let ch :: Int
ch = forall image a. (Image image, Num a) => image -> a
Canvas.height DeviceContext
context
        CanvasContext
offscreenCanvas <- forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
context forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadCanvas m => Int -> Int -> m (Image m)
CM.newImage Int
cw Int
ch
        MVar s
currentState <- forall a. a -> IO (MVar a)
newMVar s
initial
        MVar ()
eventHappened <- forall a. a -> IO (MVar a)
newMVar ()
        DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO ()
onEvents DeviceContext
context (Int
cw, Int
ch) forall a b. (a -> b) -> a -> b
$ \Event
event -> do
            forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar s
currentState (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> s -> s
eventHandler Event
event)
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
eventHappened ()
        let go :: UTCTime -> StableName Picture -> StableName s -> Bool -> IO ()
go UTCTime
t0 StableName Picture
lastFrame StableName s
lastStateName Bool
needsTime = do
                Picture
pic <- s -> Picture
drawHandler forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar a -> IO a
readMVar MVar s
currentState
                StableName Picture
picFrame <- forall a. a -> IO (StableName a)
makeStableName forall a b. (a -> b) -> a -> b
$! Picture
pic
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StableName Picture
picFrame forall a. Eq a => a -> a -> Bool
/= StableName Picture
lastFrame) forall a b. (a -> b) -> a -> b
$
                    forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
context forall a b. (a -> b) -> a -> b
$ do
                        forall (m :: * -> *) a. MonadCanvas m => Image m -> m a -> m a
CM.withImage CanvasContext
offscreenCanvas forall a b. (a -> b) -> a -> b
$
                            forall (m :: * -> *) a. MonadCanvas m => m a -> m a
CM.saveRestore forall a b. (a -> b) -> a -> b
$ do
                                forall (m :: * -> *). MonadCanvas m => Int -> Int -> m ()
setupScreenContext Int
cw Int
ch
                                forall (m :: * -> *). MonadCanvas m => Picture -> m ()
drawFrame Picture
pic
                        forall (m :: * -> *).
MonadCanvas m =>
Image m -> Int -> Int -> Int -> Int -> m ()
CM.drawImage CanvasContext
offscreenCanvas Int
0 Int
0 Int
cw Int
ch
                UTCTime
t1 <- case Bool
needsTime of
                    Bool
True -> do
                        UTCTime
tn <- IO UTCTime
getCurrentTime
                        Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$
                            forall a. Ord a => a -> a -> a
max
                                Int
0
                                (Int
50000 forall a. Num a => a -> a -> a
-
                                 forall a b. (RealFrac a, Integral b) => a -> b
round ((UTCTime
tn UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t0) forall a. Num a => a -> a -> a
* NominalDiffTime
1000000))
                        UTCTime
t1 <- IO UTCTime
getCurrentTime
                        let dt :: Double
dt = forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime
t1 UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t0)
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
dt forall a. Ord a => a -> a -> Bool
> Double
0) forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar s
currentState (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> s -> s
fullStepHandler Double
dt)
                        forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
t1
                    Bool
False -> do
                        forall a. MVar a -> IO a
takeMVar MVar ()
eventHappened
                        IO UTCTime
getCurrentTime
                s
nextState <- forall a. MVar a -> IO a
readMVar MVar s
currentState
                StableName s
nextStateName <- forall a. a -> IO (StableName a)
makeStableName forall a b. (a -> b) -> a -> b
$! s
nextState
                let nextNeedsTime :: Bool
nextNeedsTime =
                        StableName s
nextStateName forall a. Eq a => a -> a -> Bool
/= StableName s
lastStateName Bool -> Bool -> Bool
||
                        Bool
needsTime Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a s. (a -> s -> s) -> s -> Bool
isUniversallyConstant Double -> s -> s
fullStepHandler s
nextState)
                UTCTime -> StableName Picture -> StableName s -> Bool -> IO ()
go UTCTime
t1 StableName Picture
picFrame StableName s
nextStateName Bool
nextNeedsTime
        UTCTime
t0 <- IO UTCTime
getCurrentTime
        StableName Picture
nullFrame <- forall a. a -> IO (StableName a)
makeStableName forall a. HasCallStack => a
undefined
        StableName s
initialStateName <- forall a. a -> IO (StableName a)
makeStableName forall a b. (a -> b) -> a -> b
$! s
initial
        UTCTime -> StableName Picture -> StableName s -> Bool -> IO ()
go UTCTime
t0 StableName Picture
nullFrame StableName s
initialStateName Bool
True

runInspect
    :: s
    -> (Double -> s -> s)
    -> (Event -> s -> s)
    -> (s -> Picture)
    -> (s -> Picture)
    -> IO ()
runInspect :: forall s.
s
-> (Double -> s -> s)
-> (Event -> s -> s)
-> (s -> Picture)
-> (s -> Picture)
-> IO ()
runInspect s
initial Double -> s -> s
step Event -> s -> s
event s -> Picture
draw s -> Picture
_rawDraw = forall s.
s
-> (Double -> s -> s)
-> (Event -> s -> s)
-> (s -> Picture)
-> IO ()
run s
initial Double -> s -> s
step Event -> s -> s
event s -> Picture
draw

getDeployHash :: IO Text
getDeployHash :: IO Text
getDeployHash = forall a. HasCallStack => String -> a
error String
"game API unimplemented in stand-alone interface mode"

runGame
    :: GameToken
    -> Int
    -> (StdGen -> s)
    -> (Double -> s -> s)
    -> (Int -> Event -> s -> s)
    -> (Int -> s -> Picture)
    -> IO ()
runGame :: forall s.
GameToken
-> Int
-> (StdGen -> s)
-> (Double -> s -> s)
-> (Int -> Event -> s -> s)
-> (Int -> s -> Picture)
-> IO ()
runGame = forall a. HasCallStack => String -> a
error String
"game API unimplemented in stand-alone interface mode"

#endif

--------------------------------------------------------------------------------
-- FRP implementation

data ReactiveInput t = ReactiveInput
  { forall t. ReactiveInput t -> Event t Text
keyPress :: R.Event t Text,
    forall t. ReactiveInput t -> Event t Text
keyRelease :: R.Event t Text,
    forall t. ReactiveInput t -> Event t Text
textEntry :: R.Event t Text,
    forall t. ReactiveInput t -> Event t Point
pointerPress :: R.Event t Point,
    forall t. ReactiveInput t -> Event t Point
pointerRelease :: R.Event t Point,
    forall t. ReactiveInput t -> Dynamic t Point
pointerPosition :: R.Dynamic t Point,
    forall t. ReactiveInput t -> Dynamic t Bool
pointerDown :: R.Dynamic t Bool,
    forall t. ReactiveInput t -> Event t Double
timePassing :: R.Event t Double
  }

data ReactiveOutput = ReactiveOutput
  { ReactiveOutput -> [Picture]
userPictures :: [Picture],
    ReactiveOutput -> Picture -> Picture
userTransform :: Picture -> Picture,
    ReactiveOutput -> Picture
systemPicture :: Picture
  }

instance Semigroup ReactiveOutput where
  ReactiveOutput
a <> :: ReactiveOutput -> ReactiveOutput -> ReactiveOutput
<> ReactiveOutput
b =
    ReactiveOutput
      { userPictures :: [Picture]
userPictures = ReactiveOutput -> [Picture]
userPictures ReactiveOutput
a forall a. [a] -> [a] -> [a]
++ ReactiveOutput -> [Picture]
userPictures ReactiveOutput
b,
        userTransform :: Picture -> Picture
userTransform = ReactiveOutput -> Picture -> Picture
userTransform ReactiveOutput
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReactiveOutput -> Picture -> Picture
userTransform ReactiveOutput
b,
        systemPicture :: Picture
systemPicture = ReactiveOutput -> Picture
systemPicture ReactiveOutput
a HasCallStack => Picture -> Picture -> Picture
& ReactiveOutput -> Picture
systemPicture ReactiveOutput
b
      }

instance Monoid ReactiveOutput where
  mempty :: ReactiveOutput
mempty = [Picture] -> (Picture -> Picture) -> Picture -> ReactiveOutput
ReactiveOutput [] forall a. a -> a
id HasCallStack => Picture
blank

newtype ReactiveProgram t m a = ReactiveProgram
  { forall t (m :: * -> *) a.
ReactiveProgram t m a
-> ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
unReactiveProgram :: ReaderT (ReactiveInput t) (R.DynamicWriterT t ReactiveOutput m) a
  }

deriving instance Functor m => Functor (ReactiveProgram t m)

deriving instance Monad m => Applicative (ReactiveProgram t m)

deriving instance Monad m => Monad (ReactiveProgram t m)

deriving instance MonadFix m => MonadFix (ReactiveProgram t m)

deriving instance MonadIO m => MonadIO (ReactiveProgram t m)

deriving instance R.MonadSample t m => R.MonadSample t (ReactiveProgram t m)

deriving instance R.MonadHold t m => R.MonadHold t (ReactiveProgram t m)

deriving instance R.NotReady t m => R.NotReady t (ReactiveProgram t m)

deriving instance R.PerformEvent t m => R.PerformEvent t (ReactiveProgram t m)

deriving instance R.TriggerEvent t m => R.TriggerEvent t (ReactiveProgram t m)

deriving instance R.PostBuild t m => R.PostBuild t (ReactiveProgram t m)

instance (MonadFix m, R.MonadHold t m, R.Adjustable t m) => R.Adjustable t (ReactiveProgram t m) where
  runWithReplace :: forall a b.
ReactiveProgram t m a
-> Event t (ReactiveProgram t m b)
-> ReactiveProgram t m (a, Event t b)
runWithReplace ReactiveProgram t m a
a0 Event t (ReactiveProgram t m b)
a' =
    forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall t (m :: * -> *) a b.
Adjustable t m =>
m a -> Event t (m b) -> m (a, Event t b)
R.runWithReplace (forall t (m :: * -> *) a.
ReactiveProgram t m a
-> ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
unReactiveProgram ReactiveProgram t m a
a0) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t (m :: * -> *) a.
ReactiveProgram t m a
-> ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
unReactiveProgram Event t (ReactiveProgram t m b)
a'
  traverseIntMapWithKeyWithAdjust :: forall v v'.
(Int -> v -> ReactiveProgram t m v')
-> IntMap v
-> Event t (PatchIntMap v)
-> ReactiveProgram t m (IntMap v', Event t (PatchIntMap v'))
traverseIntMapWithKeyWithAdjust Int -> v -> ReactiveProgram t m v'
f IntMap v
dm0 Event t (PatchIntMap v)
dm' =
    forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall t (m :: * -> *) v v'.
Adjustable t m =>
(Int -> v -> m v')
-> IntMap v
-> Event t (PatchIntMap v)
-> m (IntMap v', Event t (PatchIntMap v'))
R.traverseIntMapWithKeyWithAdjust (\Int
k v
v -> forall t (m :: * -> *) a.
ReactiveProgram t m a
-> ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
unReactiveProgram (Int -> v -> ReactiveProgram t m v'
f Int
k v
v)) IntMap v
dm0 Event t (PatchIntMap v)
dm'
  traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) (v :: * -> *) (v' :: * -> *).
GCompare k =>
(forall a. k a -> v a -> ReactiveProgram t m (v' a))
-> DMap k v
-> Event t (PatchDMap k v)
-> ReactiveProgram t m (DMap k v', Event t (PatchDMap k v'))
traverseDMapWithKeyWithAdjust forall a. k a -> v a -> ReactiveProgram t m (v' a)
f DMap k v
dm0 Event t (PatchDMap k v)
dm' =
    forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall t (m :: * -> *) (k :: * -> *) (v :: * -> *) (v' :: * -> *).
(Adjustable t m, GCompare k) =>
(forall a. k a -> v a -> m (v' a))
-> DMap k v
-> Event t (PatchDMap k v)
-> m (DMap k v', Event t (PatchDMap k v'))
R.traverseDMapWithKeyWithAdjust (\k a
k v a
v -> forall t (m :: * -> *) a.
ReactiveProgram t m a
-> ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
unReactiveProgram (forall a. k a -> v a -> ReactiveProgram t m (v' a)
f k a
k v a
v)) DMap k v
dm0 Event t (PatchDMap k v)
dm'
  traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) (v :: * -> *) (v' :: * -> *).
GCompare k =>
(forall a. k a -> v a -> ReactiveProgram t m (v' a))
-> DMap k v
-> Event t (PatchDMapWithMove k v)
-> ReactiveProgram
     t m (DMap k v', Event t (PatchDMapWithMove k v'))
traverseDMapWithKeyWithAdjustWithMove forall a. k a -> v a -> ReactiveProgram t m (v' a)
f DMap k v
dm0 Event t (PatchDMapWithMove k v)
dm' =
    forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall t (m :: * -> *) (k :: * -> *) (v :: * -> *) (v' :: * -> *).
(Adjustable t m, GCompare k) =>
(forall a. k a -> v a -> m (v' a))
-> DMap k v
-> Event t (PatchDMapWithMove k v)
-> m (DMap k v', Event t (PatchDMapWithMove k v'))
R.traverseDMapWithKeyWithAdjustWithMove (\k a
k v a
v -> forall t (m :: * -> *) a.
ReactiveProgram t m a
-> ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
unReactiveProgram (forall a. k a -> v a -> ReactiveProgram t m (v' a)
f k a
k v a
v)) DMap k v
dm0 Event t (PatchDMapWithMove k v)
dm'

runReactiveProgram ::
  (R.Reflex t, MonadFix m) =>
  ReactiveProgram t m () ->
  ReactiveInput t ->
  m (R.Dynamic t Picture, R.Dynamic t Picture)
runReactiveProgram :: forall t (m :: * -> *).
(Reflex t, MonadFix m) =>
ReactiveProgram t m ()
-> ReactiveInput t -> m (Dynamic t Picture, Dynamic t Picture)
runReactiveProgram (ReactiveProgram ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) ()
program) ReactiveInput t
input = do
  (()
_, Dynamic t ReactiveOutput
output) <- forall (m :: * -> *) t w a.
(MonadFix m, Reflex t, Monoid w) =>
DynamicWriterT t w m a -> m (a, Dynamic t w)
R.runDynamicWriterT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) ()
program ReactiveInput t
input)
  let pic :: Dynamic t Picture
pic = [Picture] -> Picture
coalescePics forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReactiveOutput -> [Picture]
userPictures forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t ReactiveOutput
output
  let sysPic :: Dynamic t Picture
sysPic =
        HasCallStack => Picture -> Picture -> Picture
(&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReactiveOutput -> Picture
systemPicture forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t ReactiveOutput
output)
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ReactiveOutput -> Picture -> Picture
userTransform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t ReactiveOutput
output forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Picture
pic)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic t Picture
pic, Dynamic t Picture
sysPic)
  where
    coalescePics :: [Picture] -> Picture
coalescePics [] = HasCallStack => Picture
blank
    coalescePics [Picture
p] = Picture
p
    coalescePics [Picture]
ps = HasCallStack => [Picture] -> Picture
pictures [Picture]
ps

withReactiveInput ::
  ReactiveInput t ->
  (ReactiveProgram t m a -> ReactiveProgram t m a)
withReactiveInput :: forall t (m :: * -> *) a.
ReactiveInput t -> ReactiveProgram t m a -> ReactiveProgram t m a
withReactiveInput ReactiveInput t
input (ReactiveProgram ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
program) =
  forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram (forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (forall a b. a -> b -> a
const ReactiveInput t
input) ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
program)

getReactiveInput :: Monad m => ReactiveProgram t m (ReactiveInput t)
getReactiveInput :: forall (m :: * -> *) t.
Monad m =>
ReactiveProgram t m (ReactiveInput t)
getReactiveInput = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall r (m :: * -> *). MonadReader r m => m r
ask

systemDraw :: (R.Reflex t, Monad m) => R.Dynamic t Picture -> ReactiveProgram t m ()
systemDraw :: forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t Picture -> ReactiveProgram t m ()
systemDraw = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t w (m :: * -> *).
DynamicWriter t w m =>
Dynamic t w -> m ()
R.tellDyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Picture
a -> forall a. Monoid a => a
mempty {systemPicture :: Picture
systemPicture = Picture
a})

transformUserPicture ::
  (R.Reflex t, Monad m) => R.Dynamic t (Picture -> Picture) -> ReactiveProgram t m ()
transformUserPicture :: forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t (Picture -> Picture) -> ReactiveProgram t m ()
transformUserPicture =
  forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t w (m :: * -> *).
DynamicWriter t w m =>
Dynamic t w -> m ()
R.tellDyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Picture -> Picture
a -> forall a. Monoid a => a
mempty {userTransform :: Picture -> Picture
userTransform = Picture -> Picture
a})

-- | Type class for the builder monad of a CodeWorld/Reflex app.
class
  ( R.Reflex t,
    R.Adjustable t m,
    R.MonadHold t m,
    R.NotReady t m,
    R.PostBuild t m,
    R.PerformEvent t m,
    R.TriggerEvent t m,
    MonadFix m,
    MonadIO m,
    MonadIO (R.Performable m)
  ) =>
  ReflexCodeWorld t m
    | m -> t
  where
  -- | Gets an Event of key presses.  The event value is a logical key name.
  getKeyPress :: m (R.Event t Text)

  -- | Gets an Event of key presses.  The event value is a logical key name.
  getKeyRelease :: m (R.Event t Text)

  -- | Gets an Event of text entered.  The event value is the typed text.
  getTextEntry :: m (R.Event t Text)

  -- | Gets an event of pointer clicks.  The event value is the location of
  -- the click.
  getPointerClick :: m (R.Event t Point)

  -- | Gets the Dynamic position of the pointer.
  getPointerPosition :: m (R.Dynamic t Point)

  -- | Gets a Dynamic indicator whether the pointer is held down.
  isPointerDown :: m (R.Dynamic t Bool)

  -- | Gets an Event indicating the passage of time.
  getTimePassing :: m (R.Event t Double)

  -- | Emits a given Dynamic picture to be drawn to the screen.
  draw :: R.Dynamic t Picture -> m ()

instance
  ( R.Reflex t,
    R.Adjustable t m,
    R.MonadHold t m,
    R.NotReady t m,
    R.PostBuild t m,
    R.PerformEvent t m,
    R.TriggerEvent t m,
    MonadFix m,
    MonadIO m,
    MonadIO (R.Performable m)
  ) =>
  ReflexCodeWorld t (ReactiveProgram t m)
  where
  getKeyPress :: ReactiveProgram t m (Event t Text)
getKeyPress = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall t. ReactiveInput t -> Event t Text
keyPress

  getKeyRelease :: ReactiveProgram t m (Event t Text)
getKeyRelease = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall t. ReactiveInput t -> Event t Text
keyRelease

  getTextEntry :: ReactiveProgram t m (Event t Text)
getTextEntry = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall t. ReactiveInput t -> Event t Text
textEntry

  getPointerClick :: ReactiveProgram t m (Event t Point)
getPointerClick = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall t. ReactiveInput t -> Event t Point
pointerPress

  getPointerPosition :: ReactiveProgram t m (Dynamic t Point)
getPointerPosition = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall t. ReactiveInput t -> Dynamic t Point
pointerPosition

  isPointerDown :: ReactiveProgram t m (Dynamic t Bool)
isPointerDown = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall t. ReactiveInput t -> Dynamic t Bool
pointerDown

  getTimePassing :: ReactiveProgram t m (Event t Double)
getTimePassing = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall t. ReactiveInput t -> Event t Double
timePassing

  draw :: Dynamic t Picture -> ReactiveProgram t m ()
draw = forall t (m :: * -> *) a.
ReaderT (ReactiveInput t) (DynamicWriterT t ReactiveOutput m) a
-> ReactiveProgram t m a
ReactiveProgram forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t w (m :: * -> *).
DynamicWriter t w m =>
Dynamic t w -> m ()
R.tellDyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Picture
a -> forall a. Monoid a => a
mempty {userPictures :: [Picture]
userPictures = [Picture
a]})

gateDyn :: forall t a. R.Reflex t => R.Dynamic t Bool -> R.Event t a -> R.Event t a
gateDyn :: forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
dyn Event t a
e = forall {k} (t :: k) a.
Reflex t =>
Dynamic t (Event t a) -> Event t a
R.switchDyn (forall a. a -> a -> Bool -> a
bool forall {k} (t :: k) a. Reflex t => Event t a
R.never Event t a
e forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Bool
dyn)

type EventChannel t = Chan [DSum (R.EventTriggerRef t) R.TriggerInvocation]

-- | Handle the event channel used with 'runTriggerEventT'.
asyncProcessEventTriggers ::
  EventChannel t ->
  R.FireCommand t (R.SpiderHost R.Global) ->
  IO ThreadId
asyncProcessEventTriggers :: forall t.
EventChannel t -> FireCommand t (SpiderHost Global) -> IO ThreadId
asyncProcessEventTriggers EventChannel t
events FireCommand t (SpiderHost Global)
fireCommand = IO () -> IO ThreadId
forkIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
  -- Collect event triggers, and fire callbacks after propagation
  [DSum (EventTriggerRef t) TriggerInvocation]
eventsAndTriggers <- forall a. Chan a -> IO a
readChan EventChannel t
events
  [DSum (EventTrigger t) Identity]
eventsToFire <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) (f :: * -> *) a b.
(Witherable t, Applicative f) =>
(a -> f (Maybe b)) -> t a -> f (t b)
wither [DSum (EventTriggerRef t) TriggerInvocation]
eventsAndTriggers forall a b. (a -> b) -> a -> b
$
    \(R.EventTriggerRef IORef (Maybe (EventTrigger t a))
ref :=> R.TriggerInvocation a
a IO ()
_) ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) (tag :: * -> *) a.
Applicative f =>
tag a -> a -> DSum tag f
==> a
a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef IORef (Maybe (EventTrigger t a))
ref
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall a b. (a -> b) -> a -> b
$
    forall t (m :: * -> *).
FireCommand t m
-> forall a.
   [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
R.runFireCommand FireCommand t (SpiderHost Global)
fireCommand [DSum (EventTrigger t) Identity]
eventsToFire (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  -- Run callbacks
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(EventTriggerRef t a
_ :=> R.TriggerInvocation a
_ IO ()
cb) -> IO ()
cb) [DSum (EventTriggerRef t) TriggerInvocation]
eventsAndTriggers

sendEvent ::
  R.FireCommand t (R.SpiderHost R.Global) ->
  IORef (Maybe (R.EventTrigger t a)) ->
  a ->
  IO ()
sendEvent :: forall t a.
FireCommand t (SpiderHost Global)
-> IORef (Maybe (EventTrigger t a)) -> a -> IO ()
sendEvent (R.FireCommand forall a.
[DSum (EventTrigger t) Identity]
-> ReadPhase (SpiderHost Global) a -> SpiderHost Global [a]
fire) IORef (Maybe (EventTrigger t a))
triggerRef a
a =
  forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef IORef (Maybe (EventTrigger t a))
triggerRef
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\EventTrigger t a
t -> forall a.
[DSum (EventTrigger t) Identity]
-> ReadPhase (SpiderHost Global) a -> SpiderHost Global [a]
fire [EventTrigger t a
t forall (f :: * -> *) (tag :: * -> *) a.
Applicative f =>
tag a -> a -> DSum tag f
==> a
a] (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

#ifdef ghcjs_HOST_OS

createPhysicalReactiveInput
    :: forall t m. (R.MonadReflexCreateTrigger t m, R.Reflex t, R.MonadHold t m)
    => Window
    -> Element
    -> ([DSum (R.EventTrigger t) Identity] -> IO ())
    -> m (ReactiveInput t)
createPhysicalReactiveInput window canvas fire = do
    keyPress <- R.newEventWithTrigger $ \trigger ->
        on window keyDown $ do
            keyName <- keyCodeToText <$> (getKeyCode =<< event)
            when (keyName /= "") $ do
                liftIO $ fire [ trigger ==> keyName ]
                preventDefault
                stopPropagation
    textEntry <- R.newEventWithTrigger $ \trigger ->
        on window keyDown $ do
            key <- getKey =<< event
            when (T.length key == 1) $ do
                liftIO $ fire [trigger ==> key]
                preventDefault
                stopPropagation
    keyRelease <- R.newEventWithTrigger $ \trigger ->
        on window keyUp $ do
            keyName <- keyCodeToText <$> (getKeyCode =<< event)
            when (keyName /= "") $ do
                liftIO $ fire [trigger ==> keyName]
                preventDefault
                stopPropagation
    pointerPress <- R.newEventWithTrigger $ \trigger ->
        on window mouseDown $ do
            pos <- getMousePos canvas
            liftIO $ fire [trigger ==> pos]
    pointerRelease <- R.newEventWithTrigger $ \trigger ->
        on window mouseUp $ do
            pos <- getMousePos canvas
            liftIO $ fire [trigger ==> pos]
    pointerMovement <- R.newEventWithTrigger $ \trigger ->
        on window mouseMove $ do
            pos <- getMousePos canvas
            liftIO $ fire [trigger ==> pos]

    timePassing <- R.newEventWithTrigger $ \trigger -> do
        active <- newIORef True
        let timeStep t1 t2 = do
                stillActive <- readIORef active
                when stillActive $ do
                    when (t2 > t1) $ fire [
                        trigger ==> min 0.25 ((t2 - t1) / 1000)]
                    void $ inAnimationFrame ContinueAsync (timeStep t2)
        t0 <- nextFrame
        void $ inAnimationFrame ContinueAsync (timeStep t0)
        return (writeIORef active False)

    pointerPosition <- R.holdDyn (0, 0) pointerMovement
    pointerDown <- R.holdDyn False $
        R.leftmost [True <$ pointerPress, False <$ pointerRelease]

    return (ReactiveInput {..})

inspectLogicalInput
    :: forall t m. (R.Reflex t, R.MonadHold t m)
    => R.Dynamic t DebugState
    -> ReactiveInput t
    -> m (ReactiveInput t)
inspectLogicalInput debugState physicalInput = do
    -- Physical inputs should either be frozen or dropped during debugging.
    let filterInDebugMode :: forall a. R.Event t a -> R.Event t a
        filterInDebugMode = gateDyn (not . debugStateActive <$> debugState)
    let freezeInDebugMode :: forall a. R.Dynamic t a -> a -> m (R.Dynamic t a)
        freezeInDebugMode dyn initial =
            R.holdDyn initial (filterInDebugMode (R.updated dyn))

    logicalPointerPosition <- freezeInDebugMode (pointerPosition physicalInput) (0, 0)
    logicalPointerDown     <- freezeInDebugMode (pointerDown physicalInput) False

    return $ ReactiveInput {
            keyPress        = filterInDebugMode (keyPress physicalInput),
            keyRelease      = filterInDebugMode (keyRelease physicalInput),
            textEntry       = filterInDebugMode (textEntry physicalInput),
            pointerPress    = filterInDebugMode (pointerPress physicalInput),
            pointerRelease  = filterInDebugMode (pointerRelease physicalInput),
            pointerPosition = logicalPointerPosition,
            pointerDown     = logicalPointerDown,
            timePassing     = filterInDebugMode (timePassing physicalInput)
            }

runReactive
    :: (forall t m.
        ( R.Reflex t,
          R.Adjustable t m,
          R.MonadHold t m,
          R.NotReady t m,
          R.PostBuild t m,
          R.PerformEvent t m,
          R.TriggerEvent t m,
          MonadFix m,
          MonadIO m,
          MonadIO (R.Performable m)
        ) => (ReactiveInput t -> m (R.Dynamic t Picture, R.Dynamic t Picture)))
    -> IO ()
runReactive program = do
    canvas <- getCanvas
    setCanvasSize canvas canvas

    frameRenderer <- createFrameRenderer canvas
    pendingFrame <- liftIO $ newMVar Nothing
    let asyncRender pic = do
            old <- swapMVar pendingFrame (Just pic)
            when (isNothing old) $ void $ inAnimationFrame ContinueAsync $ \ _t -> do
                pic <- swapMVar pendingFrame Nothing
                maybe (return ()) frameRenderer pic

    (postBuild, postBuildTriggerRef) <- R.runSpiderHost R.newEventWithTriggerRef

    (debugUpdate, debugUpdateTriggerRef) <- R.runSpiderHost R.newEventWithTriggerRef
    debugState <- R.runSpiderHost $ R.holdUniqDyn =<< R.foldDyn ($) debugStateInit debugUpdate

    Just window <- currentWindow

    rec
        physicalInput <- R.runSpiderHost $
            createPhysicalReactiveInput window canvas fireAndRedraw
        resizeEvent <- R.runSpiderHost $ R.newEventWithTrigger $ \trigger -> do
            on window resize $ liftIO $ fireAndRedraw [trigger ==> ()]
        logicalInput <- R.runSpiderHost $ inspectLogicalInput debugState physicalInput
        eventTriggers <- newChan
        (inspectPicture, fireCommand) <- R.runSpiderHost $ R.hostPerformEventT $ do
            (inspectPicture, displayPicture) <-
                flip R.runTriggerEventT eventTriggers .
                flip R.runPostBuildT postBuild $
                program logicalInput
            let logicalPicture = drawDebugState <$> debugState
                                                <*> inspectPicture
                                                <*> displayPicture
            R.performEvent_ $ liftIO <$> R.leftmost [
                (setCanvasSize canvas canvas >>) . asyncRender <$>
                    R.tagPromptlyDyn logicalPicture resizeEvent,
                asyncRender <$> R.updated logicalPicture,
                asyncRender <$> R.tagPromptlyDyn logicalPicture postBuild
                ]
            return inspectPicture

        let fireAndRedraw events = R.runSpiderHost $ void $
                R.runFireCommand fireCommand events (return ())

    let
        fireDebugUpdateAndRedraw = sendEvent fireCommand debugUpdateTriggerRef
        samplePicture = R.runSpiderHost $ R.runHostFrame $ R.sample $ R.current inspectPicture
    connectInspect canvas samplePicture fireDebugUpdateAndRedraw

    sendEvent fireCommand postBuildTriggerRef ()

    void $ asyncProcessEventTriggers eventTriggers fireCommand
    waitForever

#else

runReactive
    :: (forall t m.
        ( R.Reflex t,
          R.Adjustable t m,
          R.MonadHold t m,
          R.NotReady t m,
          R.PostBuild t m,
          R.PerformEvent t m,
          R.TriggerEvent t m,
          MonadFix m,
          MonadIO m,
          MonadIO (R.Performable m)
        ) => (ReactiveInput t -> m (R.Dynamic t Picture, R.Dynamic t Picture)))
    -> IO ()
runReactive :: (forall t (m :: * -> *).
 (Reflex t, Adjustable t m, MonadHold t m, NotReady t m,
  PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadFix m,
  MonadIO m, MonadIO (Performable m)) =>
 ReactiveInput t -> m (Dynamic t Picture, Dynamic t Picture))
-> IO ()
runReactive forall t (m :: * -> *).
(Reflex t, Adjustable t m, MonadHold t m, NotReady t m,
 PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadFix m,
 MonadIO m, MonadIO (Performable m)) =>
ReactiveInput t -> m (Dynamic t Picture, Dynamic t Picture)
program = (DeviceContext -> IO ()) -> IO ()
runBlankCanvas forall a b. (a -> b) -> a -> b
$ \DeviceContext
context -> do
    let cw :: Int
cw = forall image a. (Image image, Num a) => image -> a
Canvas.width DeviceContext
context
    let ch :: Int
ch = forall image a. (Image image, Num a) => image -> a
Canvas.height DeviceContext
context
    CanvasContext
offscreenCanvas <- forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
context forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadCanvas m => Int -> Int -> m (Image m)
CM.newImage Int
cw Int
ch

    let frame :: Picture -> IO ()
frame Picture
pic = forall a. DeviceContext -> CanvasM a -> IO a
runCanvasM DeviceContext
context forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) a. MonadCanvas m => Image m -> m a -> m a
CM.withImage CanvasContext
offscreenCanvas forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) a. MonadCanvas m => m a -> m a
CM.saveRestore forall a b. (a -> b) -> a -> b
$ do
                    forall (m :: * -> *). MonadCanvas m => Int -> Int -> m ()
setupScreenContext Int
cw Int
ch
                    forall (m :: * -> *). MonadCanvas m => Picture -> m ()
drawFrame Picture
pic
            forall (m :: * -> *).
MonadCanvas m =>
Image m -> Int -> Int -> Int -> Int -> m ()
CM.drawImage CanvasContext
offscreenCanvas Int
0 Int
0 Int
cw Int
ch

    (Event (SpiderTimeline Global) ()
postBuild, IORef (Maybe (EventTrigger (SpiderTimeline Global) ()))
postBuildTriggerRef) <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
R.newEventWithTriggerRef

    (Event (SpiderTimeline Global) Text
keyPress, IORef (Maybe (EventTrigger (SpiderTimeline Global) Text))
keyPressTrigger) <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
R.newEventWithTriggerRef
    (Event (SpiderTimeline Global) Text
textEntry, IORef (Maybe (EventTrigger (SpiderTimeline Global) Text))
textEntryTrigger) <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
R.newEventWithTriggerRef
    (Event (SpiderTimeline Global) Text
keyRelease, IORef (Maybe (EventTrigger (SpiderTimeline Global) Text))
keyReleaseTrigger) <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
R.newEventWithTriggerRef
    (Event (SpiderTimeline Global) Point
pointerPress, IORef (Maybe (EventTrigger (SpiderTimeline Global) Point))
pointerPressTrigger) <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
R.newEventWithTriggerRef
    (Event (SpiderTimeline Global) Point
pointerRelease, IORef (Maybe (EventTrigger (SpiderTimeline Global) Point))
pointerReleaseTrigger) <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
R.newEventWithTriggerRef
    (Event (SpiderTimeline Global) Point
pointerMovement, IORef (Maybe (EventTrigger (SpiderTimeline Global) Point))
pointerMovementTrigger) <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
R.newEventWithTriggerRef
    (Event (SpiderTimeline Global) Double
timePassing, IORef (Maybe (EventTrigger (SpiderTimeline Global) Double))
timePassingTrigger) <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
R.newEventWithTriggerRef

    Dynamic (SpiderTimeline Global) Point
pointerPosition <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
R.holdDyn (Double
0, Double
0) Event (SpiderTimeline Global) Point
pointerMovement
    Dynamic (SpiderTimeline Global) Bool
pointerDown <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
R.holdDyn Bool
False forall a b. (a -> b) -> a -> b
$
        forall {k} (t :: k) a. Reflex t => [Event t a] -> Event t a
R.leftmost [Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event (SpiderTimeline Global) Point
pointerPress, Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event (SpiderTimeline Global) Point
pointerRelease]

    let input :: ReactiveInput (SpiderTimeline Global)
input = ReactiveInput {Dynamic (SpiderTimeline Global) Bool
Dynamic (SpiderTimeline Global) Point
Event (SpiderTimeline Global) Double
Event (SpiderTimeline Global) Point
Event (SpiderTimeline Global) Text
pointerDown :: Dynamic (SpiderTimeline Global) Bool
pointerPosition :: Dynamic (SpiderTimeline Global) Point
timePassing :: Event (SpiderTimeline Global) Double
pointerRelease :: Event (SpiderTimeline Global) Point
pointerPress :: Event (SpiderTimeline Global) Point
keyRelease :: Event (SpiderTimeline Global) Text
textEntry :: Event (SpiderTimeline Global) Text
keyPress :: Event (SpiderTimeline Global) Text
timePassing :: Event (SpiderTimeline Global) Double
pointerDown :: Dynamic (SpiderTimeline Global) Bool
pointerPosition :: Dynamic (SpiderTimeline Global) Point
pointerRelease :: Event (SpiderTimeline Global) Point
pointerPress :: Event (SpiderTimeline Global) Point
textEntry :: Event (SpiderTimeline Global) Text
keyRelease :: Event (SpiderTimeline Global) Text
keyPress :: Event (SpiderTimeline Global) Text
..}

    Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
triggeredEvents <- forall a. IO (Chan a)
newChan
    (()
_, FireCommand (SpiderTimeline Global) (SpiderHost Global)
fireCommand) <- forall a. SpiderHost Global a -> IO a
R.runSpiderHost forall a b. (a -> b) -> a -> b
$ forall t (m :: * -> *) a.
(Monad m, MonadSubscribeEvent t m, MonadReflexHost t m, MonadRef m,
 Ref m ~ Ref IO) =>
PerformEventT t m a -> m (a, FireCommand t m)
R.hostPerformEventT forall a b. (a -> b) -> a -> b
$ do
        (Dynamic (SpiderTimeline Global) Picture
_inspectPicture, Dynamic (SpiderTimeline Global) Picture
displayPicture) <-
            forall a b c. (a -> b -> c) -> b -> a -> c
flip forall t (m :: * -> *) a.
TriggerEventT t m a
-> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
R.runTriggerEventT Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
triggeredEvents forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            forall a b c. (a -> b -> c) -> b -> a -> c
flip forall t (m :: * -> *) a. PostBuildT t m a -> Event t () -> m a
R.runPostBuildT Event (SpiderTimeline Global) ()
postBuild forall a b. (a -> b) -> a -> b
$
            forall t (m :: * -> *).
(Reflex t, Adjustable t m, MonadHold t m, NotReady t m,
 PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadFix m,
 MonadIO m, MonadIO (Performable m)) =>
ReactiveInput t -> m (Dynamic t Picture, Dynamic t Picture)
program ReactiveInput (SpiderTimeline Global)
input
        forall t (m :: * -> *).
PerformEvent t m =>
Event t (Performable m ()) -> m ()
R.performEvent_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a. Reflex t => [Event t a] -> Event t a
R.leftmost [
            Picture -> IO ()
frame forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
R.updated Dynamic (SpiderTimeline Global) Picture
displayPicture,
            Picture -> IO ()
frame forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a b.
Reflex t =>
Dynamic t a -> Event t b -> Event t a
R.tagPromptlyDyn Dynamic (SpiderTimeline Global) Picture
displayPicture Event (SpiderTimeline Global) ()
postBuild
            ]
        forall (m :: * -> *) a. Monad m => a -> m a
return ()

    let sendEvent'
            :: IORef (Maybe (R.EventTrigger (R.SpiderTimeline R.Global) a))
            -> a
            -> IO ()
        sendEvent' :: forall a.
IORef (Maybe (EventTrigger (SpiderTimeline Global) a))
-> a -> IO ()
sendEvent' = forall t a.
FireCommand t (SpiderHost Global)
-> IORef (Maybe (EventTrigger t a)) -> a -> IO ()
sendEvent FireCommand (SpiderTimeline Global) (SpiderHost Global)
fireCommand

    forall a.
IORef (Maybe (EventTrigger (SpiderTimeline Global) a))
-> a -> IO ()
sendEvent' IORef (Maybe (EventTrigger (SpiderTimeline Global) ()))
postBuildTriggerRef ()

    UTCTime
t0 <- IO UTCTime
getCurrentTime
    let go :: UTCTime -> IO ()
go UTCTime
t1 = do
            [Event]
events <- DeviceContext -> IO [Event]
Canvas.flush DeviceContext
context
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Event]
events forall a b. (a -> b) -> a -> b
$ \Event
event -> case Event -> Text
Canvas.eType Event
event of
                Text
"keydown" | Just Int
code <- Event -> Maybe Int
Canvas.eWhich Event
event -> do
                    let keyName :: Text
keyName = Word -> Text
keyCodeToText (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
code)
                    forall a.
IORef (Maybe (EventTrigger (SpiderTimeline Global) a))
-> a -> IO ()
sendEvent' IORef (Maybe (EventTrigger (SpiderTimeline Global) Text))
keyPressTrigger Text
keyName
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Int
T.length Text
keyName forall a. Eq a => a -> a -> Bool
== Int
1) forall a b. (a -> b) -> a -> b
$ forall a.
IORef (Maybe (EventTrigger (SpiderTimeline Global) a))
-> a -> IO ()
sendEvent' IORef (Maybe (EventTrigger (SpiderTimeline Global) Text))
textEntryTrigger Text
keyName
                Text
"keyup" | Just Int
code <- Event -> Maybe Int
Canvas.eWhich Event
event -> do
                    let keyName :: Text
keyName = Word -> Text
keyCodeToText (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
code)
                    forall a.
IORef (Maybe (EventTrigger (SpiderTimeline Global) a))
-> a -> IO ()
sendEvent' IORef (Maybe (EventTrigger (SpiderTimeline Global) Text))
keyReleaseTrigger Text
keyName
                Text
"mousedown" | Just Point
pos <- (Int, Int) -> Point -> Point
getMousePos (Int
cw, Int
ch) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe Point
Canvas.ePageXY Event
event -> do
                    forall a.
IORef (Maybe (EventTrigger (SpiderTimeline Global) a))
-> a -> IO ()
sendEvent' IORef (Maybe (EventTrigger (SpiderTimeline Global) Point))
pointerPressTrigger Point
pos
                Text
"mouseup" | Just Point
pos <- (Int, Int) -> Point -> Point
getMousePos (Int
cw, Int
ch) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe Point
Canvas.ePageXY Event
event -> do
                    forall a.
IORef (Maybe (EventTrigger (SpiderTimeline Global) a))
-> a -> IO ()
sendEvent' IORef (Maybe (EventTrigger (SpiderTimeline Global) Point))
pointerReleaseTrigger Point
pos
                Text
"mousemove" | Just Point
pos <- (Int, Int) -> Point -> Point
getMousePos (Int
cw, Int
ch) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe Point
Canvas.ePageXY Event
event -> do
                    forall a.
IORef (Maybe (EventTrigger (SpiderTimeline Global) a))
-> a -> IO ()
sendEvent' IORef (Maybe (EventTrigger (SpiderTimeline Global) Point))
pointerMovementTrigger Point
pos
                Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

            UTCTime
tn <- IO UTCTime
getCurrentTime
            Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Int
0 (Int
50000 forall a. Num a => a -> a -> a
- (forall a b. (RealFrac a, Integral b) => a -> b
round ((UTCTime
tn UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t0) forall a. Num a => a -> a -> a
* NominalDiffTime
1000000)))
            UTCTime
t2 <- IO UTCTime
getCurrentTime
            let dt :: Double
dt = forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime
t2 UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
t1)
            forall a.
IORef (Maybe (EventTrigger (SpiderTimeline Global) a))
-> a -> IO ()
sendEvent' IORef (Maybe (EventTrigger (SpiderTimeline Global) Double))
timePassingTrigger Double
dt
            UTCTime -> IO ()
go UTCTime
t2
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (forall t.
EventChannel t -> FireCommand t (SpiderHost Global) -> IO ThreadId
asyncProcessEventTriggers Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
triggeredEvents FireCommand (SpiderTimeline Global) (SpiderHost Global)
fireCommand)
        ThreadId -> IO ()
killThread
        (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ UTCTime -> IO ()
go UTCTime
t0)

#endif