diff --git a/codeworld-api.cabal b/codeworld-api.cabal --- a/codeworld-api.cabal +++ b/codeworld-api.cabal @@ -1,5 +1,5 @@ Name: codeworld-api -Version: 0.2.4 +Version: 0.2.5 Synopsis: Graphics library for CodeWorld License: Apache License-file: LICENSE @@ -30,15 +30,16 @@ CodeWorld.Event, CodeWorld.Driver CodeWorld.CollaborationUI - Build-depends: base >= 4.9 && < 5, + Build-depends: base >= 4.9 && < 5, containers >= 0.5.7 && < 0.6, hashable >= 1.2.4 && < 1.3, text >= 1.2.2 && < 1.3, mtl >= 2.2.1 && < 2.3, - random >= 1.1 && < 1.2, + random >= 1.1 && < 1.2, random-shuffle >= 0.0.4 && < 0.1, cereal >= 0.5.4 && < 0.6, - cereal-text >= 0.1.0 && < 0.2 + cereal-text >= 0.1.0 && < 0.2, + ghc-prim >= 0.3.1 && < 0.6 if impl(ghcjs) Build-depends: @@ -53,5 +54,4 @@ time >= 1.6.0 && < 1.9 Exposed: True - Ghc-options: -O2 - -Wincomplete-patterns + Ghc-options: -Wincomplete-patterns diff --git a/src/CodeWorld.hs b/src/CodeWorld.hs --- a/src/CodeWorld.hs +++ b/src/CodeWorld.hs @@ -20,10 +20,13 @@ drawingOf , animationOf , activityOf + , debugActivityOf , groupActivityOf , unsafeGroupActivityOf , simulationOf + , debugSimulationOf , interactionOf + , debugInteractionOf , collaborationOf , unsafeCollaborationOf -- * Pictures diff --git a/src/CodeWorld/CanvasM.hs b/src/CodeWorld/CanvasM.hs --- a/src/CodeWorld/CanvasM.hs +++ b/src/CodeWorld/CanvasM.hs @@ -156,6 +156,11 @@ #else +type CanvasM = Canvas + +runCanvasM :: Canvas.DeviceContext -> CanvasM a -> IO a +runCanvasM = Canvas.send + instance MonadCanvas Canvas where type Image Canvas = Canvas.CanvasContext save = Canvas.save () diff --git a/src/CodeWorld/Driver.hs b/src/CodeWorld/Driver.hs --- a/src/CodeWorld/Driver.hs +++ b/src/CodeWorld/Driver.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE JavaScriptFFI #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -32,10 +35,13 @@ ( drawingOf , animationOf , activityOf + , debugActivityOf , groupActivityOf , unsafeGroupActivityOf , simulationOf + , debugSimulationOf , interactionOf + , debugInteractionOf , collaborationOf , unsafeCollaborationOf , trace @@ -44,6 +50,7 @@ import CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState) import qualified CodeWorld.CollaborationUI as CUI import qualified CodeWorld.CanvasM as CM +import CodeWorld.CanvasM (CanvasM, runCanvasM) import CodeWorld.Color import CodeWorld.Event import CodeWorld.Picture @@ -64,6 +71,7 @@ import qualified Debug.Trace import GHC.Fingerprint.Type import GHC.Generics +import GHC.Prim import GHC.Stack import GHC.StaticPtr import Numeric @@ -75,7 +83,6 @@ import Text.Printf import Text.Read #ifdef ghcjs_HOST_OS -import CodeWorld.CanvasM (CanvasM, runCanvasM) import CodeWorld.Message import CodeWorld.Prediction import qualified Control.Monad.Trans.State as State @@ -138,6 +145,17 @@ -- the state into a picture to display. -> IO () +-- | Runs an interactive CodeWorld program in debugging mode. In this mode, +-- the program gets controls to pause and manipulate time, and even go back in +-- time to look at past states. +debugActivityOf + :: world -- ^ The initial state of the interaction. + -> (Event -> world -> world) -- ^ The event handling function, which updates + -- the state given an event. + -> (world -> Picture) -- ^ The visualization function, which converts + -- the state into a picture to display. + -> IO () + -- | Runs an interactive multi-user CodeWorld program that is joined by several -- participants over the internet. groupActivityOf @@ -178,6 +196,14 @@ -- the state into a picture to display. -> IO () +debugSimulationOf + :: world -- ^ The initial state of the simulation. + -> (Double -> world -> world) -- ^ The time step function, which advances + -- the state given the time difference. + -> (world -> Picture) -- ^ The visualization function, which converts + -- the state into a picture to display. + -> IO () + -- | Runs an interactive event-driven CodeWorld program. This is a -- generalization of simulations that can respond to events like key presses -- and mouse movement. @@ -191,6 +217,16 @@ -- the state into a picture to display. -> IO () +debugInteractionOf + :: world -- ^ The initial state of the interaction. + -> (Double -> world -> world) -- ^ The time step function, which advances + -- the state given the time difference. + -> (Event -> world -> world) -- ^ The event handling function, which updates + -- the state given a user interface event. + -> (world -> Picture) -- ^ The visualization function, which converts + -- the state into a picture to display. + -> IO () + -- | Runs an interactive multi-user CodeWorld program, involving multiple -- participants over the internet. collaborationOf @@ -793,33 +829,177 @@ where stripZeros = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse describePicture :: Picture -> String -describePicture (Rectangle _ w h) = "rectangle { width = " ++ showShortFloat w ++ ", height = " ++ showShortFloat h ++ " }" -describePicture (SolidPolygon _ pts) = "solidPolygon { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }" -describePicture (SolidClosedCurve _ pts) = "solidClosedCurve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }" -describePicture (Polygon _ pts) = "polygon { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }" -describePicture (ThickPolygon _ pts w) = "thickPolygon { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ ", width = " ++ showShortFloat w ++ " }" -describePicture (SolidRectangle _ w h) = "solidRectangle { width = " ++ showShortFloat w ++ ", height = " ++ showShortFloat h ++ " }" -describePicture (ThickRectangle _ lw w h) = "thickRectangle { linewidth = " ++ showShortFloat lw ++ ", width = " ++ showShortFloat w ++ ", height = " ++ showShortFloat h ++ " }" -describePicture (ClosedCurve _ pts) = "closedCurve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }" -describePicture (ThickClosedCurve _ pts w) = "thickClosedCurve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ ", width = " ++ showShortFloat w ++ " }" +describePicture (Rectangle _ w h) = + "rectangle {" ++ + " width = " ++ showShortFloat w ++ + ", height = " ++ showShortFloat h ++ + " }" +describePicture (SolidPolygon _ pts) = + "solidPolygon {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts + ] ++ + "]" ++ + " }" +describePicture (SolidClosedCurve _ pts) = + "solidClosedCurve {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts + ] ++ + "]" ++ + " }" +describePicture (Polygon _ pts) = + "polygon {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts + ] ++ + "]" ++ + " }" +describePicture (ThickPolygon _ pts w) = + "thickPolygon {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts + ] ++ + "], thickness = " ++ showShortFloat w ++ + " }" +describePicture (ClosedCurve _ pts) = + "closedCurve {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts + ] ++ + "]" ++ + " }" +describePicture (ThickClosedCurve _ pts w) = + "thickClosedCurve {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts + ] ++ + "]" ++ + ", thickness = " ++ showShortFloat w ++ + " }" +describePicture (Polyline _ pts) = + "polyline {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts + ] ++ + "]" ++ + " }" +describePicture (ThickPolyline _ pts w) = + "thickPolyline {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts ] ++ + "]" ++ + ", thickness = " ++ showShortFloat w ++ + " }" +describePicture (Curve _ pts) = + "curve {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts + ] ++ + "]" ++ + " }" +describePicture (ThickCurve _ pts w) = + "thickCurve {" ++ + " points = [" ++ + intercalate ", " [ + "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" + | (x, y) <- pts + ] ++ + "]" ++ + ", thickness = " ++ showShortFloat w ++ + " }" +describePicture (SolidRectangle _ w h) = + "solidRectangle {" ++ + " width = " ++ showShortFloat w ++ + ", height = " ++ showShortFloat h ++ + " }" +describePicture (ThickRectangle _ lw w h) = + "thickRectangle {" ++ + " thickness = " ++ showShortFloat lw ++ + ", width = " ++ showShortFloat w ++ + ", height = " ++ showShortFloat h ++ + " }" describePicture (Circle _ r) = "circle { radius = " ++ showShortFloat r ++ " }" -describePicture (SolidCircle _ r) = "solidCircle { radius = " ++ showShortFloat r ++ " }" -describePicture (ThickCircle _ lw r) = "thickCircle { linewidth = " ++ showShortFloat lw ++ ", radius = " ++ showShortFloat r ++ " }" -describePicture (Polyline _ pts) = "polyline { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }" -describePicture (ThickPolyline _ pts w) = "thickPolyline { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ ", width = " ++ showShortFloat w ++ " }" -describePicture (Curve _ pts) = "curve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }" -describePicture (ThickCurve _ pts w) = "thickCurve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ ", width = " ++ showShortFloat w ++ " }" -describePicture (Sector _ b e r) = "sector { startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++ showShortFloat b ++ " radians)" ++ ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++ showShortFloat e ++ " radias )," ++ " radius = " ++ showShortFloat r ++ " }" -describePicture (Arc _ b e r) = "arc { startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++ showShortFloat b ++ " radians)" ++ ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++ showShortFloat e ++ " radias )," ++ " radius = " ++ showShortFloat r ++ " }" -describePicture (ThickArc _ b e r w) = "thickArc { startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++ showShortFloat b ++ " radians)" ++ ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++ showShortFloat e ++ " radias )," ++ " radius = " ++ showShortFloat r ++ ", width = " ++ showShortFloat w ++ " }" +describePicture (SolidCircle _ r) = + "solidCircle { radius = " ++ showShortFloat r ++ " }" +describePicture (ThickCircle _ lw r) = + "thickCircle {" ++ + " thickness = " ++ showShortFloat lw ++ + ", radius = " ++ showShortFloat r ++ + " }" +describePicture (Sector _ b e r) = + "sector {" ++ + " startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++ + showShortFloat b ++ " radians)" ++ + ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++ + showShortFloat e ++ " radians)" ++ + ", radius = " ++ showShortFloat r ++ + " }" +describePicture (Arc _ b e r) = + "arc {" ++ + " startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++ + showShortFloat b ++ " radians)" ++ + ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "° (" ++ + showShortFloat e ++ " radians)" ++ + ", radius = " ++ showShortFloat r ++ + " }" +describePicture (ThickArc _ b e r w) = + "thickArc {" ++ + " startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++ + showShortFloat b ++ " radians)" ++ + ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++ + showShortFloat e ++ " radians)" ++ + ", radius = " ++ showShortFloat r ++ + ", thickness = " ++ showShortFloat w ++ + " }" describePicture (Lettering _ txt) = printf "lettering { text = '%s' }" txt describePicture (Blank _) = "blank" -describePicture (StyledLettering _ style font txt) = printf " styledLettering { style = %s , font = %s, text = '%s' }" (show style) (show font) txt -describePicture (Color _ (RGBA r g b a) _) = "colored { color = RGBA(" ++ showShortFloat r ++ ", " ++ showShortFloat g ++ ", " ++ showShortFloat b ++ ", " ++ showShortFloat a ++ ") }" -describePicture (Translate _ x y _) = "translated { x = " ++ showShortFloat x ++ ", y = " ++ showShortFloat y ++ " }" -describePicture (Scale _ x y _) = "scaled { x = " ++ showShortFloat x ++ ", y = " ++ showShortFloat y ++ " }" -describePicture (Rotate _ angle _) = "rotated { angle = " ++ showShortFloat angle ++ "° }" -describePicture (Dilate _ k _) = "dilated { factor = " ++ showShortFloat k ++ " }" +describePicture (StyledLettering _ style font txt) = + printf " styledLettering { style = %s , font = %s, text = '%s' }" + (show style) + (show font) + txt +describePicture (Color _ (RGBA r g b a) _) = + "colored {" ++ + " color = RGBA(" ++ + showShortFloat r ++ + ", " ++ showShortFloat g ++ + ", " ++ showShortFloat b ++ + ", " ++ showShortFloat a ++ + ")" ++ + " }" +describePicture (Translate _ x y _) = + "translated {" ++ + " x = " ++ showShortFloat x ++ + ", y = " ++ showShortFloat y ++ + " }" +describePicture (Scale _ x y _) = + "scaled {" ++ + " x = " ++ showShortFloat x ++ + ", y = " ++ showShortFloat y ++ + " }" +describePicture (Rotate _ angle _) = + "rotated { angle = " ++ showShortFloat angle ++ "° }" +describePicture (Dilate _ k _) = + "dilated { factor = " ++ showShortFloat k ++ " }" describePicture (Logo _) = "codeWorldLogo" describePicture (CoordinatePlane _) = "coordinatePlane" describePicture (Pictures _) = "pictures" @@ -1129,6 +1309,7 @@ -------------------------------------------------------------------------------- -- Stand-alone implementation of drawing #else + withDS :: DrawState -> Canvas () -> Canvas () withDS (ta, tb, tc, td, te, tf, col) action = Canvas.saveRestore $ do @@ -1783,9 +1964,11 @@ offscreenCanvas <- Canvas.create 500 500 setCanvasSize canvas canvas setCanvasSize (elementFromCanvas offscreenCanvas) canvas - on window resize $ do - liftIO $ setCanvasSize canvas canvas - liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas + needsRedraw <- newMVar () + on window resize $ void $ liftIO $ do + setCanvasSize canvas canvas + setCanvasSize (elementFromCanvas offscreenCanvas) canvas + tryPutMVar needsRedraw () currentState <- newMVar initial eventHappened <- newMVar () let sendEvent event = do @@ -1827,7 +2010,10 @@ | not needsTime -> return False | otherwise -> not <$> isUniversallyConstant fullStepHandler nextState - go t1 picFrame nextStateName nextNeedsTime + nextFrame <- tryTakeMVar needsRedraw >>= \case + Nothing -> return picFrame + Just () -> makeStableName undefined + go t1 nextFrame nextStateName nextNeedsTime t0 <- getTime nullFrame <- makeStableName undefined initialStateName <- makeStableName $! initial @@ -1914,72 +2100,54 @@ inspect (return pic) handlePause handleHighlight drawToScreen +-- 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') + -- 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) -> IO () -runInspect initial stepHandler eventHandler drawHandler = do - Just window <- currentWindow - Just doc <- currentDocument - Just canvas <- getElementById doc ("screen" :: JSString) - let initialWrapper = (debugStateInit, initial) - stepHandlerWrapper dt (debugState, state) = - case debugStateActive debugState of - True -> (debugState, state) - False -> (debugState, stepHandler dt state) - eventHandlerWrapper evt (debugState, state) = - case evt of - Left debugEvent -> - (updateDebugState debugEvent debugState, state) - Right normalEvent -> - (debugState, eventHandler normalEvent state) - drawHandlerWrapper (debugState, state) = - drawDebugState debugState (pictureToDrawing $ drawHandler state) - drawPicHandler (debugState, state) = drawHandler state - (sendEvent, getState) <- - run - initialWrapper - stepHandlerWrapper - eventHandlerWrapper - drawHandlerWrapper - (Right . TimePassing) - let pauseEvent True = sendEvent $ Left DebugStart - pauseEvent False = sendEvent $ Left DebugStop - highlightSelectEvent True n = sendEvent $ Left (HighlightEvent n) - highlightSelectEvent False n = sendEvent $ Left (SelectEvent n) - onEvents canvas (sendEvent . Right) - inspect (drawPicHandler <$> getState) pauseEvent highlightSelectEvent - -runPauseable :: - Wrapped s +runInspect :: + (Wrapped s -> [Control s]) + -> s -> (Double -> s -> s) - -> (Wrapped s -> [Control s]) - -> (s -> Picture) + -> (Event -> s -> s) + -> (s -> Picture) -> IO () -runPauseable initial stepHandler controls drawHandler = do +runInspect controls initial stepHandler eventHandler drawHandler = do Just window <- currentWindow Just doc <- currentDocument Just canvas <- getElementById doc ("screen" :: JSString) - let initialWrapper = (debugStateInit, initial) - stepHandlerWrapper dt (debugState, wrappedState) = + let initialWrapper = (debugStateInit, wrappedInitial initial) + stepHandlerWrapper dt wrapper@(debugState, _) = case debugStateActive debugState of - True -> (debugState, wrappedState) - False -> (debugState, wrappedStep stepHandler dt wrappedState) - eventHandlerWrapper evt (debugState, wrappedState) = - case evt of - Left debugEvent -> - (updateDebugState debugEvent debugState, wrappedState) - Right normalEvent -> - ( debugState - , wrappedEvent controls stepHandler normalEvent wrappedState) + True -> wrapper + False -> inRight (wrappedStep stepHandler dt) wrapper + eventHandlerWrapper evt wrapper@(debugState, _) = + case (debugStateActive debugState, evt) of + (_, Left debugEvent) -> + inLeft (updateDebugState debugEvent) wrapper + (True, _) -> wrapper + (_, Right normalEvent) -> + inRight (wrappedEvent controls stepHandler eventHandler normalEvent) wrapper drawHandlerWrapper (debugState, wrappedState) = case debugStateActive debugState of - True -> drawDebugState debugState plainDrawing - False -> - pictureToDrawing $ - wrappedDraw controls drawHandler wrappedState - where - plainDrawing = pictureToDrawing $ drawHandler (state wrappedState) + True -> drawDebugState debugState $ pictureToDrawing $ drawHandler (state wrappedState) + False -> pictureToDrawing (wrappedDraw controls drawHandler wrappedState) drawPicHandler (debugState, wrappedState) = drawHandler $ state wrappedState (sendEvent, getState) <- @@ -2149,20 +2317,17 @@ initialStateName <- makeStableName $! initial go t0 nullFrame initialStateName True -runInspect :: - s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO () -runInspect = run - -runPauseable :: - Wrapped s +runInspect :: + (Wrapped s -> [Control s]) + -> s -> (Double -> s -> s) - -> (Wrapped s -> [Control s]) - -> (s -> Picture) + -> (Event -> s -> s) + -> (s -> Picture) -> IO () -runPauseable initial stepHandler controls drawHandler = - run initial +runInspect controls initial stepHandler eventHandler drawHandler = + run (wrappedInitial initial) (wrappedStep stepHandler) - (wrappedEvent controls stepHandler) + (wrappedEvent controls stepHandler eventHandler) (wrappedDraw controls drawHandler) getDeployHash :: IO Text @@ -2231,15 +2396,18 @@ -------------------------------------------------------------------------------- -- Common code for activity, interaction, animation and simulation interfaces -activityOf initial event draw = interactionOf initial (const id) event draw -interactionOf initial step event draw = runInspect initial step event draw +activityOf initial change picture = + interactionOf initial (const id) change picture +interactionOf = runInspect (const []) + data Wrapped a = Wrapped { state :: a , playbackSpeed :: Double - , mouseMovedTime :: Double - } deriving (Show) + , lastInteractionTime :: Double + , isDragging :: Bool + } deriving (Show, Functor) data Control :: * -> * where PlayButton :: Control a @@ -2249,7 +2417,16 @@ BackButton :: Control Double TimeLabel :: Control Double SpeedSlider :: Control a + UndoButton :: Control [a] +wrappedInitial :: a -> Wrapped a +wrappedInitial w = Wrapped { + state = w, + playbackSpeed = 1, + lastInteractionTime = 1000, + isDragging = False + } + wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a wrappedStep f dt w = w @@ -2257,36 +2434,62 @@ if playbackSpeed w == 0 then state w else f (dt * playbackSpeed w) (state w) - , mouseMovedTime = mouseMovedTime w + dt + , lastInteractionTime = lastInteractionTime w + dt } -wrappedEvent :: +wrappedEvent :: forall a . (Wrapped a -> [Control a]) -> (Double -> a -> a) + -> (Event -> a -> a) -> Event -> Wrapped a -> Wrapped a -wrappedEvent _ _ (MouseMovement _) w = w {mouseMovedTime = 0} -wrappedEvent ctrls f (MousePress LeftButton p) w = - (foldr (handleControl f p) w (ctrls w)) {mouseMovedTime = 0} -wrappedEvent _ _ _ w = w +wrappedEvent _ _ eventHandler (TimePassing dt) w + | playbackSpeed w == 0 = w + | otherwise = fmap (eventHandler (TimePassing dt)) w +wrappedEvent ctrls f eventHandler event w + | playbackSpeed w == 0 || handled = afterControls {lastInteractionTime = 0} + | otherwise = fmap (eventHandler event) afterControls {lastInteractionTime = 0} + where + afterControls :: Wrapped a + handled :: Bool + (afterControls, handled) = foldr stepFunction (w, False) (ctrls w) + stepFunction :: Control a -> (Wrapped a, Bool) -> (Wrapped a, Bool) + stepFunction control (world, handled) + | handled == True = (world, True) + | otherwise = handleControl f event control world +xToPlaybackSpeed :: Double -> Double +xToPlaybackSpeed x = foldr (snapSlider) (min 5 $ max 0 $ 5 * (x + 4.4) / 2.8) [1..4] + +snapSlider :: Double -> Double -> Double +snapSlider target val | abs (val - target) < 0.2 = target + | otherwise = val + handleControl :: - (Double -> a -> a) -> Point -> Control a -> Wrapped a -> Wrapped a -handleControl _ (x, y) RestartButton w - | -9.4 < x && x < -8.6 && -9.4 < y && y < -8.6 = w {state = 0} -handleControl _ (x, y) PlayButton w - | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = w {playbackSpeed = 1} -handleControl _ (x, y) PauseButton w - | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = w {playbackSpeed = 0} -handleControl _ (x, y) BackButton w + (Double -> a -> a) -> Event -> Control a -> Wrapped a -> (Wrapped a, Bool) +handleControl _ (PointerPress (x, y)) RestartButton w + | -9.4 < x && x < -8.6 && -9.4 < y && y < -8.6 = (w {state = 0}, True) +handleControl _ (PointerPress (x, y)) PlayButton w + | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = (w {playbackSpeed = 1}, True) +handleControl _ (PointerPress (x, y)) PauseButton w + | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = (w {playbackSpeed = 0}, True) +handleControl _ (PointerPress (x,y)) BackButton w | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6 = - w {state = max 0 (state w - 0.1)} -handleControl f (x, y) StepButton w - | -6.4 < x && x < -5.6 && -9.4 < y && y < -8.6 = w {state = f 0.1 (state w)} -handleControl f (x, y) SpeedSlider w - | -5.4 < x && x < -2.6 && -9.4 < y && y < -8.6 = w {playbackSpeed = 5 * (x + 5.4) / 2.8} -handleControl _ _ _ w = w + (w {state = max 0 (state w - 0.1)}, True) +handleControl _ (PointerPress (x,y)) UndoButton w + | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6 = + (w {state = tail (state w)}, True) +handleControl f (PointerPress (x, y)) StepButton w + | -6.4 < x && x < -5.6 && -9.4 < y && y < -8.6 = (w {state = f 0.1 (state w)}, True) +handleControl _ (PointerPress (x, y)) SpeedSlider w + | -4.5 < x && x < -1.5 && -9.4 < y && y < -8.6 = + (w {playbackSpeed = xToPlaybackSpeed x, isDragging = True}, True) +handleControl _ (PointerMovement (x, y)) SpeedSlider w + | isDragging w = (w {playbackSpeed = xToPlaybackSpeed x}, True) +handleControl _ (PointerRelease (x, y)) SpeedSlider w + | isDragging w = (w {playbackSpeed = xToPlaybackSpeed x, isDragging = False}, True) +handleControl _ _ _ w = (w, False) wrappedDraw :: (Wrapped a -> [Control a]) -> (a -> Picture) -> Wrapped a -> Picture @@ -2298,8 +2501,8 @@ | otherwise = blank where alpha - | mouseMovedTime w < 4.5 = 1 - | mouseMovedTime w < 5.0 = 10 - 2 * mouseMovedTime w + | lastInteractionTime w < 4.5 = 1 + | lastInteractionTime w < 5.0 = 10 - 2 * lastInteractionTime w | otherwise = 0 drawControl :: Wrapped a -> Double -> Control a -> Picture @@ -2338,6 +2541,15 @@ solidPolygon [(-0.05, 0.25), (-0.05, -0.25), (-0.3, 0)]) <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8) +drawControl _ alpha UndoButton = translated (-7) (-9) p + where + p = + colored + (RGBA 0 0 0 alpha) + (translated 0.15 0 (solidRectangle 0.2 0.5) <> + solidPolygon [(-0.05, 0.25), (-0.05, -0.25), (-0.3, 0)]) <> + colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <> + colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8) drawControl _ alpha StepButton = translated (-6) (-9) p where p = @@ -2355,38 +2567,64 @@ (scaled 0.5 0.5 $ text (pack (showFFloatAlt (Just 4) (state w) "s"))) <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 3.0 0.8) <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 3.0 0.8) -drawControl w alpha SpeedSlider = translated (-4) (-9) p +drawControl w alpha SpeedSlider = translated (-3) (-9) p where p = - + colored + (RGBA 0 0 0 alpha) + (translated x 0.75 $ scaled 0.5 0.5 $ lettering (pack (showFFloatAlt (Just 2) (playbackSpeed w) ""))) <> translated x 0 (solidRectangle 0.2 0.8) <> - colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 2.8 0.6) <> - colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 2.8 0.6) + colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 2.8 0.25) <> + colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 2.8 0.25) x = playbackSpeed w / 5 * 2.8 - 1.4 animationControls :: Wrapped Double -> [Control Double] animationControls w - | mouseMovedTime w > 5 = [] + | lastInteractionTime w > 5 = [] | playbackSpeed w == 0 && state w > 0 = [RestartButton, PlayButton, StepButton, BackButton, TimeLabel, SpeedSlider] | playbackSpeed w == 0 = [RestartButton, PlayButton, StepButton, TimeLabel, SpeedSlider] | otherwise = [RestartButton, PauseButton, TimeLabel, SpeedSlider] -animationOf f = runPauseable initial (+) animationControls f - where - initial = Wrapped {state = 0, playbackSpeed = 1, mouseMovedTime = 1000} +animationOf f = runInspect animationControls 0 (+) (\_ r -> r) f simulationControls :: Wrapped w -> [Control w] simulationControls w - | mouseMovedTime w > 5 = [] + | lastInteractionTime w > 5 = [] | playbackSpeed w == 0 = [PlayButton, StepButton, SpeedSlider] | otherwise = [PauseButton, SpeedSlider] -simulationOf simInitial simStep simDraw = - runPauseable initial simStep simulationControls simDraw +statefulDebugControls :: Wrapped [w] -> [Control [w]] +statefulDebugControls w + | lastInteractionTime w > 5 = [] + | playbackSpeed w == 0 && not (null (tail (state w))) = [PlayButton, StepButton, SpeedSlider, UndoButton] + | playbackSpeed w == 0 = [PlayButton, StepButton, SpeedSlider] + | otherwise = [PauseButton, SpeedSlider] + +simulationOf initial step draw = + runInspect simulationControls initial step (\_ r -> r) draw + +prependIfChanged :: (a -> a) -> [a] -> [a] +prependIfChanged f (x:xs) = case x `seq` x' `seq` (reallyUnsafePtrEquality# x x') of + 0# -> x' : x : xs + _ -> x : xs + where x' = f x + +debugSimulationOf initial simStep simDraw = + runInspect statefulDebugControls [initial] step (\_ r -> r) draw where - initial = - Wrapped {state = simInitial, playbackSpeed = 1, mouseMovedTime = 1000} + step dt = prependIfChanged (simStep dt) + draw (x:xs) = simDraw x + +debugInteractionOf initial baseStep baseEvent baseDraw = + runInspect statefulDebugControls [initial] step event draw + where + step dt = prependIfChanged (baseStep dt) + event e = prependIfChanged (baseEvent e) + draw (x:xs) = baseDraw x + +debugActivityOf initial change picture = + debugInteractionOf initial (const id) change picture trace msg x = unsafePerformIO $ do hPutStrLn stderr (T.unpack msg)