codeworld-api 0.2.4 → 0.2.5
raw patch · 4 files changed
+387/−141 lines, 4 filesdep +ghc-primPVP ok
version bump matches the API change (PVP)
Dependencies added: ghc-prim
API changes (from Hackage documentation)
+ CodeWorld: debugActivityOf :: world -> (Event -> world -> world) -> (world -> Picture) -> IO ()
+ CodeWorld: debugInteractionOf :: world -> (Double -> world -> world) -> (Event -> world -> world) -> (world -> Picture) -> IO ()
+ CodeWorld: debugSimulationOf :: world -> (Double -> world -> world) -> (world -> Picture) -> IO ()
Files
- codeworld-api.cabal +6/−6
- src/CodeWorld.hs +3/−0
- src/CodeWorld/CanvasM.hs +5/−0
- src/CodeWorld/Driver.hs +373/−135
codeworld-api.cabal view
@@ -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
src/CodeWorld.hs view
@@ -20,10 +20,13 @@ drawingOf , animationOf , activityOf+ , debugActivityOf , groupActivityOf , unsafeGroupActivityOf , simulationOf+ , debugSimulationOf , interactionOf+ , debugInteractionOf , collaborationOf , unsafeCollaborationOf -- * Pictures
src/CodeWorld/CanvasM.hs view
@@ -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 ()
src/CodeWorld/Driver.hs view
@@ -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)