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.3.1 +Version: 0.4.0 Synopsis: Graphics library for CodeWorld License: Apache License-file: LICENSE @@ -19,32 +19,110 @@ package to provide a webpage consisting of just a panel locally. This way, the same program that runs on the CodeWorld server can also be run locally. +Extra-source-files: data/README.md, + data/*.svg + +Flag strictbuild + Description: Fail on warnings + Default: False + Manual: True + Library + Exposed: True Hs-source-dirs: src Exposed-modules: CodeWorld, CodeWorld.App, - CodeWorld.App2 + CodeWorld.App2, + CodeWorld.Reflex, + CodeWorld.Sketches Other-modules: CodeWorld.CanvasM, + CodeWorld.CollaborationUI, CodeWorld.Color, - CodeWorld.Picture, + CodeWorld.DrawState, + CodeWorld.Driver, + CodeWorld.EntryPoints, CodeWorld.Event, - CodeWorld.Driver - CodeWorld.CollaborationUI - Build-depends: base >= 4.9 && < 5, + CodeWorld.Picture, + Util.EmbedAsUrl + Build-depends: aeson >= 1.4.3 && < 1.5, + base >= 4.11 && < 5, + base64-bytestring >= 1.0 && < 1.1, + bytestring >= 0.9 && < 0.11, + cereal >= 0.5.4 && < 0.6, + cereal-text >= 0.1.0 && < 0.2, containers >= 0.5.7 && < 0.7, + deepseq >= 1.4 && < 1.5, + dependent-sum >= 0.4 && < 0.6.2, + ghc-prim >= 0.3.1 && < 0.6, hashable >= 1.2.4 && < 1.3, - text >= 1.2.2 && < 1.3, + monad-loops >= 0.3 && < 0.5, mtl >= 2.2.1 && < 2.3, random >= 1.1 && < 1.2, - random-shuffle >= 0.0.4 && < 0.1, + ref-tf >= 0.4 && < 0.5, + reflex >= 0.6.2.3 && < 0.7, + template-haskell >= 2.8 && < 2.15, + text >= 1.2.2 && < 1.3 + + if impl(ghcjs) + Js-sources: jsbits/sim_fp.js + Build-depends: ghcjs-base, + ghcjs-prim, + codeworld-game-api, + codeworld-prediction, + ghcjs-dom >= 0.8 && < 0.9, + transformers + else + Build-depends: blank-canvas >= 0.6 && < 0.8, + time >= 1.6.0 && < 1.9 + + Ghc-options: -O2 -Wall + if flag(strictbuild) + Ghc-options: -Werror + +Test-suite unit-tests + Type: exitcode-stdio-1.0 + Main-is: Main.hs + Hs-source-dirs: test, + src + Other-modules: CodeWorld, + CodeWorld.CanvasM, + CodeWorld.CollaborationUI, + CodeWorld.Color, + CodeWorld.DrawState, + CodeWorld.Driver, + CodeWorld.EntryPoints, + CodeWorld.Event, + CodeWorld.Picture, + Util.EmbedAsUrl + + -- Test libraries + Build-depends: HUnit, + test-framework, + test-framework-hunit + + -- Copy of the build dependencies above + Build-depends: aeson >= 1.4.3 && < 1.5, + base >= 4.11 && < 5, + base64-bytestring >= 1.0 && < 1.1, + bytestring >= 0.9 && < 0.11, cereal >= 0.5.4 && < 0.6, cereal-text >= 0.1.0 && < 0.2, - ghc-prim >= 0.3.1 && < 0.6 + containers >= 0.5.7 && < 0.7, + deepseq >= 1.4 && < 1.5, + dependent-sum >= 0.4 && < 0.6.2, + ghc-prim >= 0.3.1 && < 0.6, + hashable >= 1.2.4 && < 1.3, + monad-loops >= 0.3 && < 0.5, + mtl >= 2.2.1 && < 2.3, + random >= 1.1 && < 1.2, + ref-tf >= 0.4 && < 0.5, + reflex >= 0.6 && < 0.7, + template-haskell >= 2.8 && < 2.15, + text >= 1.2.2 && < 1.3 if impl(ghcjs) Js-sources: jsbits/sim_fp.js - Build-depends: - ghcjs-base, + Build-depends: ghcjs-base, ghcjs-prim, codeworld-game-api, codeworld-prediction, @@ -54,5 +132,5 @@ Build-depends: blank-canvas >= 0.6 && < 0.7, time >= 1.6.0 && < 1.9 - Exposed: True - Ghc-options: -Wincomplete-patterns + Ghc-options: -O2 + Cpp-options: -DCODEWORLD_UNIT_TEST diff --git a/data/AirplaneTransparency70.svg b/data/AirplaneTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/AirplaneTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/AlarmTransparency70.svg b/data/AlarmTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/AlarmTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/AlienTransparency70.svg b/data/AlienTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/AlienTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/AppleTransparency70.svg b/data/AppleTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/AppleTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/AustronautTransparency70.svg b/data/AustronautTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/AustronautTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BabyTransparency70.svg b/data/BabyTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BabyTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BallTransparency70.svg b/data/BallTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BallTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BalloonTransparency70.svg b/data/BalloonTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BalloonTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BellTransparency70.svg b/data/BellTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BellTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BirdTransparency70.svg b/data/BirdTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BirdTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BoatTransparency70.svg b/data/BoatTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BoatTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BookTransparency70.svg b/data/BookTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BookTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BoyTransparency70.svg b/data/BoyTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BoyTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BubbleTransparency70.svg b/data/BubbleTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BubbleTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/BugTransparency70.svg b/data/BugTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/BugTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/CarTransparency70.svg b/data/CarTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/CarTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/ChatBubbleTransparency70.svg b/data/ChatBubbleTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/ChatBubbleTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/ChestTransparency70.svg b/data/ChestTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/ChestTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/CloudTransparency70.svg b/data/CloudTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/CloudTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/CoinTransparency70.svg b/data/CoinTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/CoinTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/DogTransparency70.svg b/data/DogTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/DogTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/DragonTransparency70.svg b/data/DragonTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/DragonTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/ExplosionTransparency70.svg b/data/ExplosionTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/ExplosionTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/FishTransparency70.svg b/data/FishTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/FishTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/FlagTransparency70.svg b/data/FlagTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/FlagTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/FlameTransparency70.svg b/data/FlameTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/FlameTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/FlowerTransparency70.svg b/data/FlowerTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/FlowerTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/GearTransparency70.svg b/data/GearTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/GearTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/GhostTransparency70.svg b/data/GhostTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/GhostTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/GirlTransparency70.svg b/data/GirlTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/GirlTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/GrassTransparency70.svg b/data/GrassTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/GrassTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/HeartTransparency70.svg b/data/HeartTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/HeartTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/HotAirBalloonTransparency70.svg b/data/HotAirBalloonTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/HotAirBalloonTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/HouseTransparency70.svg b/data/HouseTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/HouseTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/JewelTransparency70.svg b/data/JewelTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/JewelTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/KeyTransparency70.svg b/data/KeyTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/KeyTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/KittenTransparency70.svg b/data/KittenTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/KittenTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/LightbulbTransparency70.svg b/data/LightbulbTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/LightbulbTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/LightningTransparency70.svg b/data/LightningTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/LightningTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/MonsterTransparency70.svg b/data/MonsterTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/MonsterTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/MoonTransparency70.svg b/data/MoonTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/MoonTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/NoteTransparency70.svg b/data/NoteTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/NoteTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/PawnBlackTransparency70.svg b/data/PawnBlackTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/PawnBlackTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/PawnBlueTransparency70.svg b/data/PawnBlueTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/PawnBlueTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/PawnGreenTransparency70.svg b/data/PawnGreenTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/PawnGreenTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/PawnRedTransparency70.svg b/data/PawnRedTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/PawnRedTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/PawnWhiteTransparency70.svg b/data/PawnWhiteTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/PawnWhiteTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/README.md b/data/README.md new file mode 100644 --- /dev/null +++ b/data/README.md @@ -0,0 +1,2 @@ +This directory contains built-in sketches that are available for students +to use in their programs. diff --git a/data/RaindropTransparency70.svg b/data/RaindropTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/RaindropTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/RobotTransparency70.svg b/data/RobotTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/RobotTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/RocketShipTransparency70.svg b/data/RocketShipTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/RocketShipTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/ScrollTransparency70.svg b/data/ScrollTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/ScrollTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/SignTransparency70.svg b/data/SignTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/SignTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/SparklesTransparency70.svg b/data/SparklesTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/SparklesTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/StarTransparency70.svg b/data/StarTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/StarTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/SunTransparency70.svg b/data/SunTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/SunTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/ThoughtBubbleTransparency70.svg b/data/ThoughtBubbleTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/ThoughtBubbleTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/ToyCubeTransparency70.svg b/data/ToyCubeTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/ToyCubeTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/TreeTransparency70.svg b/data/TreeTransparency70.svg new file mode 100644 --- /dev/null +++ b/data/TreeTransparency70.svg @@ -0,0 +1,1 @@ + diff --git a/data/codeworld.svg b/data/codeworld.svg new file mode 100644 --- /dev/null +++ b/data/codeworld.svg @@ -0,0 +1,1 @@ + diff --git a/src/CodeWorld.hs b/src/CodeWorld.hs --- a/src/CodeWorld.hs +++ b/src/CodeWorld.hs @@ -15,133 +15,125 @@ See the License for the specific language governing permissions and limitations under the License. -} -module CodeWorld ( - -- * Entry points - drawingOf - , animationOf - , activityOf - , debugActivityOf - , groupActivityOf - , unsafeGroupActivityOf - , simulationOf - , debugSimulationOf - , interactionOf - , debugInteractionOf - , collaborationOf - , unsafeCollaborationOf +module CodeWorld + ( -- * Entry points + drawingOf, + animationOf, + activityOf, + debugActivityOf, + groupActivityOf, + unsafeGroupActivityOf, + simulationOf, + debugSimulationOf, + interactionOf, + debugInteractionOf, + collaborationOf, + unsafeCollaborationOf, + -- * Pictures - , Picture - , TextStyle(..) - , Font(..) - , blank - , polyline - , path - , thickPolyline - , thickPath - , polygon - , thickPolygon - , solidPolygon - , curve - , thickCurve - , closedCurve - , thickClosedCurve - , solidClosedCurve - , rectangle - , solidRectangle - , thickRectangle - , circle - , solidCircle - , thickCircle - , arc - , sector - , thickArc - , text - , lettering - , styledText - , styledLettering - , colored - , coloured - , translated - , scaled - , dilated - , rotated - , pictures - , (<>) - , (&) - , coordinatePlane - , codeWorldLogo - , Point - , translatedPoint - , rotatedPoint - , scaledPoint - , dilatedPoint - , Vector - , vectorLength - , vectorDirection - , vectorSum - , vectorDifference - , scaledVector - , rotatedVector - , dotProduct + Picture, + TextStyle (..), + Font (..), + blank, + polyline, + path, + thickPolyline, + thickPath, + polygon, + thickPolygon, + solidPolygon, + curve, + thickCurve, + closedCurve, + thickClosedCurve, + solidClosedCurve, + rectangle, + solidRectangle, + thickRectangle, + circle, + solidCircle, + thickCircle, + arc, + sector, + thickArc, + text, + lettering, + styledText, + styledLettering, + colored, + coloured, + translated, + scaled, + dilated, + rotated, + pictures, + (<>), + (&), + coordinatePlane, + codeWorldLogo, + Point, + translatedPoint, + rotatedPoint, + scaledPoint, + dilatedPoint, + Vector, + vectorLength, + vectorDirection, + vectorSum, + vectorDifference, + scaledVector, + rotatedVector, + dotProduct, + -- * Colors - , Color(..) - , Colour - , pattern RGB - , pattern HSL - , black - , white - , red - , green - , blue - , cyan - , magenta - , yellow - , aquamarine - , orange - , azure - , violet - , chartreuse - , rose - , brown - , pink - , purple - , gray - , grey - , mixed - , lighter - , light - , darker - , dark - , brighter - , bright - , duller - , dull - , translucent - , assortedColors - , hue - , saturation - , luminosity - , alpha - , pattern White - , pattern Black - , pattern Gray - , pattern Grey - , pattern Red - , pattern Orange - , pattern Yellow - , pattern Green - , pattern Blue - , pattern Purple - , pattern Pink - , pattern Brown + Color (..), + Colour, + pattern RGB, + pattern HSL, + black, + white, + red, + green, + blue, + cyan, + magenta, + yellow, + aquamarine, + orange, + azure, + violet, + chartreuse, + rose, + brown, + pink, + purple, + gray, + grey, + mixed, + lighter, + light, + darker, + dark, + brighter, + bright, + duller, + dull, + translucent, + assortedColors, + hue, + saturation, + luminosity, + alpha, + -- * Events - , Event(..) + Event (..), + -- * Debugging - , trace - ) where + trace, + ) +where import CodeWorld.Color -import CodeWorld.Driver +import CodeWorld.EntryPoints import CodeWorld.Event import CodeWorld.Picture -import Data.Monoid diff --git a/src/CodeWorld/App.hs b/src/CodeWorld/App.hs --- a/src/CodeWorld/App.hs +++ b/src/CodeWorld/App.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTSyntax #-} {-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wno-deprecations -Wno-name-shadowing #-} {- Copyright 2019 The CodeWorld Authors. All rights reserved. @@ -18,9 +19,8 @@ -} module CodeWorld.App - {-# WARNING "This is an experimental API. It can change at any time." #-} - ( - Rule, + {-# WARNING "This is an experimental API. It can change at any time." #-} + ( Rule, timeRule, eventRule, pictureRule, @@ -29,18 +29,19 @@ subrule, rules, applicationOf, - unsafeMultiApplicationOf - ) where + unsafeMultiApplicationOf, + ) +where import CodeWorld import Data.List (foldl') import System.Random (StdGen) data Rule :: * -> * where - TimeRule :: (Double -> state -> state) -> Rule state - EventRule :: (Int -> Event -> state -> state) -> Rule state - PictureRule :: (Int -> state -> Picture) -> Rule state - Rules :: [Rule state] -> Rule state + TimeRule :: (Double -> state -> state) -> Rule state + EventRule :: (Int -> Event -> state -> state) -> Rule state + PictureRule :: (Int -> state -> Picture) -> Rule state + Rules :: [Rule state] -> Rule state timeRule :: (Double -> state -> state) -> Rule state timeRule = TimeRule @@ -59,11 +60,14 @@ subrule :: (a -> b) -> (b -> a -> a) -> Rule b -> Rule a subrule getter setter (TimeRule step_b) = TimeRule step_a - where step_a dt a = setter (step_b dt (getter a)) a + where + step_a dt a = setter (step_b dt (getter a)) a subrule getter setter (EventRule event_b) = EventRule event_a - where event_a k ev a = setter (event_b k ev (getter a)) a -subrule getter setter (PictureRule pic_b) = PictureRule pic_a - where pic_a n = pic_b n . getter + where + event_a k ev a = setter (event_b k ev (getter a)) a +subrule getter _setter (PictureRule pic_b) = PictureRule pic_a + where + pic_a n = pic_b n . getter subrule getter setter (Rules rules) = Rules (map (subrule getter setter) rules) rules :: [Rule state] -> Rule state @@ -71,37 +75,33 @@ applicationOf :: world -> [Rule world] -> IO () applicationOf w rules = interactionOf w step event picture - where step dt = foldl' (.) id [ f dt | f <- concatMap stepHandlers rules ] - event ev = foldl' (.) id [ f ev | f <- concatMap eventHandlers rules ] - picture w = pictures [ pic w | pic <- concatMap pictureHandlers rules ] - - stepHandlers (TimeRule f) = [f] - stepHandlers (Rules rs) = concatMap stepHandlers rs - stepHandlers _ = [] - - eventHandlers (EventRule f) = [f 0] - eventHandlers (Rules rs) = concatMap eventHandlers rs - eventHandlers _ = [] - - pictureHandlers (PictureRule f) = [f 0] - pictureHandlers (Rules rs) = concatMap pictureHandlers rs - pictureHandlers _ = [] + where + step dt = foldl' (.) id [f dt | f <- concatMap stepHandlers rules] + event ev = foldl' (.) id [f ev | f <- concatMap eventHandlers rules] + picture w = pictures [pic w | pic <- concatMap pictureHandlers rules] + stepHandlers (TimeRule f) = [f] + stepHandlers (Rules rs) = concatMap stepHandlers rs + stepHandlers _ = [] + eventHandlers (EventRule f) = [f 0] + eventHandlers (Rules rs) = concatMap eventHandlers rs + eventHandlers _ = [] + pictureHandlers (PictureRule f) = [f 0] + pictureHandlers (Rules rs) = concatMap pictureHandlers rs + pictureHandlers _ = [] unsafeMultiApplicationOf :: Int -> (StdGen -> state) -> [Rule state] -> IO () unsafeMultiApplicationOf n initial rules = - unsafeCollaborationOf n initial step event picture - where step dt = foldl' (.) id [ f dt | f <- concatMap stepHandlers rules ] - event k ev = foldl' (.) id [ f k ev | f <- concatMap eventHandlers rules ] - picture k w = pictures [ pic k w | pic <- concatMap pictureHandlers rules ] - - stepHandlers (TimeRule f) = [f] - stepHandlers (Rules rs) = concatMap stepHandlers rs - stepHandlers _ = [] - - eventHandlers (EventRule f) = [f] - eventHandlers (Rules rs) = concatMap eventHandlers rs - eventHandlers _ = [] - - pictureHandlers (PictureRule f) = [f] - pictureHandlers (Rules rs) = concatMap pictureHandlers rs - pictureHandlers _ = [] + unsafeCollaborationOf n initial step event picture + where + step dt = foldl' (.) id [f dt | f <- concatMap stepHandlers rules] + event k ev = foldl' (.) id [f k ev | f <- concatMap eventHandlers rules] + picture k w = pictures [pic k w | pic <- concatMap pictureHandlers rules] + stepHandlers (TimeRule f) = [f] + stepHandlers (Rules rs) = concatMap stepHandlers rs + stepHandlers _ = [] + eventHandlers (EventRule f) = [f] + eventHandlers (Rules rs) = concatMap eventHandlers rs + eventHandlers _ = [] + pictureHandlers (PictureRule f) = [f] + pictureHandlers (Rules rs) = concatMap pictureHandlers rs + pictureHandlers _ = [] diff --git a/src/CodeWorld/App2.hs b/src/CodeWorld/App2.hs --- a/src/CodeWorld/App2.hs +++ b/src/CodeWorld/App2.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTSyntax #-} {-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -Wno-deprecations #-} {- Copyright 2019 The CodeWorld Authors. All rights reserved. @@ -18,9 +19,8 @@ -} module CodeWorld.App2 - {-# WARNING "This is an experimental API. It can change at any time." #-} - ( - Application, + {-# WARNING "This is an experimental API. It can change at any time." #-} + ( Application, defaultApplication, withTimeStep, withEventHandler, @@ -28,63 +28,69 @@ withMultiEventHandler, withMultiPicture, subapplication, - applicationOf - ) where + applicationOf, + ) +where import CodeWorld -import Data.List (foldl') -import System.Random (StdGen) data Application :: * -> * where - App :: state - -> (Double -> state -> state) - -> (Int -> Event -> state -> state) - -> (Int -> state -> Picture) - -> Application state + App :: + state -> + (Double -> state -> state) -> + (Int -> Event -> state -> state) -> + (Int -> state -> Picture) -> + Application state defaultApplication :: state -> Application state defaultApplication s = - App s (const id) (const (const id)) (const (const blank)) + App s (const id) (const (const id)) (const (const blank)) -withTimeStep :: (Double -> state -> state) - -> Application state - -> Application state +withTimeStep :: + (Double -> state -> state) -> + Application state -> + Application state withTimeStep f (App initial step event picture) = - App initial (\dt -> f dt . step dt) event picture + App initial (\dt -> f dt . step dt) event picture -withEventHandler :: (Event -> state -> state) - -> Application state - -> Application state +withEventHandler :: + (Event -> state -> state) -> + Application state -> + Application state withEventHandler f (App initial step event picture) = - App initial step (\k ev -> f ev . event k ev) picture + App initial step (\k ev -> f ev . event k ev) picture withPicture :: (state -> Picture) -> Application state -> Application state withPicture f (App initial step event picture) = - App initial step event (\k s -> f s & picture k s) + App initial step event (\k s -> f s & picture k s) -withMultiEventHandler :: (Int -> Event -> state -> state) - -> Application state - -> Application state +withMultiEventHandler :: + (Int -> Event -> state -> state) -> + Application state -> + Application state withMultiEventHandler f (App initial step event picture) = - App initial step (\k ev -> f k ev . event k ev) picture + App initial step (\k ev -> f k ev . event k ev) picture -withMultiPicture :: (Int -> state -> Picture) - -> Application state - -> Application state +withMultiPicture :: + (Int -> state -> Picture) -> + Application state -> + Application state withMultiPicture f (App initial step event picture) = - App initial step event (\k s -> f k s & picture k s) + App initial step event (\k s -> f k s & picture k s) -subapplication :: (a -> b) - -> (b -> a -> a) - -> Application b - -> (b -> a) - -> Application a +subapplication :: + (a -> b) -> + (b -> a -> a) -> + Application b -> + (b -> a) -> + Application a subapplication getter setter (App initial step event picture) f = - App (f initial) - (\dt s -> setter (step dt (getter s)) s) - (\k ev s -> setter (event k ev (getter s)) s) - (\k -> picture k . getter) + App + (f initial) + (\dt s -> setter (step dt (getter s)) s) + (\k ev s -> setter (event k ev (getter s)) s) + (\k -> picture k . getter) applicationOf :: Application world -> IO () applicationOf (App initial step event picture) = - interactionOf initial step (event 0) (picture 0) + interactionOf initial step (event 0) (picture 0) diff --git a/src/CodeWorld/CanvasM.hs b/src/CodeWorld/CanvasM.hs --- a/src/CodeWorld/CanvasM.hs +++ b/src/CodeWorld/CanvasM.hs @@ -20,28 +20,32 @@ module CodeWorld.CanvasM where -import Control.Monad import Control.Monad.Reader import Control.Monad.Trans (MonadIO) -import Data.Text (Text, pack) +import Data.Text (Text) #ifdef ghcjs_HOST_OS import Data.JSString.Text -import GHCJS.Marshal.Pure +import GHCJS.DOM +import GHCJS.DOM.Document +import GHCJS.DOM.Element +import GHCJS.DOM.Node +import GHCJS.DOM.NonElementParentNode import GHCJS.Types import qualified JavaScript.Web.Canvas as Canvas import qualified JavaScript.Web.Canvas.Internal as Canvas #else +import Data.Text (pack) import qualified Graphics.Blank as Canvas import Graphics.Blank (Canvas) import Text.Printf #endif -class Monad m => MonadCanvas m where +class (Monad m, MonadIO m) => MonadCanvas m where type Image m save :: m () @@ -50,9 +54,13 @@ Double -> Double -> Double -> Double -> Double -> Double -> m () translate :: Double -> Double -> m () scale :: Double -> Double -> m () - newImage :: Int -> Int -> m a -> m (Image m, a) + newImage :: Int -> Int -> m (Image m) + builtinImage :: Text -> m (Maybe (Image m)) + withImage :: Image m -> m a -> m a drawImage :: Image m -> Int -> Int -> Int -> Int -> m () + drawImgURL :: Text -> Text -> Double -> Double -> m () globalCompositeOperation :: Text -> m () + globalAlpha :: Double -> m () lineWidth :: Double -> m () strokeColor :: Int -> Int -> Int -> Double -> m () fillColor :: Int -> Int -> Int -> Double -> m () @@ -75,6 +83,8 @@ measureText :: Text -> m Double isPointInPath :: (Double, Double) -> m Bool isPointInStroke :: (Double, Double) -> m Bool + getScreenWidth :: m Double + getScreenHeight :: m Double saveRestore :: MonadCanvas m => m a -> m a saveRestore m = do @@ -83,129 +93,224 @@ restore return r -#ifdef ghcjs_HOST_OS +#if defined(ghcjs_HOST_OS) data CanvasM a = CanvasM - { unCanvasM :: Canvas.Context -> IO a + { unCanvasM :: (Double, Double) -> Canvas.Context -> IO a } deriving (Functor) -runCanvasM :: Canvas.Context -> CanvasM a -> IO a -runCanvasM = flip unCanvasM +runCanvasM :: (Double, Double) -> Canvas.Context -> CanvasM a -> IO a +runCanvasM dim ctx m = unCanvasM m dim ctx instance Applicative CanvasM where - pure x = CanvasM (const (return x)) - f <*> x = CanvasM (\ctx -> unCanvasM f ctx <*> unCanvasM x ctx) + pure x = CanvasM (\_ _ -> return x) + f <*> x = CanvasM (\dim ctx -> unCanvasM f dim ctx <*> unCanvasM x dim ctx) instance Monad CanvasM where return = pure - m >>= f = CanvasM (\ctx -> unCanvasM m ctx >>= ($ ctx) . unCanvasM . f) + m >>= f = CanvasM $ \dim ctx -> do + x <- unCanvasM m dim ctx + unCanvasM (f x) dim ctx foreign import javascript "$2.globalCompositeOperation = $1;" - js_globalCompositeOperation :: JSString -> Canvas.Context -> IO () + js_globalCompositeOperation :: JSString -> Canvas.Context -> IO () +foreign import javascript "$2.globalAlpha = $1;" + js_globalAlpha :: Double -> Canvas.Context -> IO () + foreign import javascript "$r = $3.isPointInPath($1, $2);" - js_isPointInPath :: Double -> Double -> Canvas.Context -> IO Bool + js_isPointInPath :: Double -> Double -> Canvas.Context -> IO Bool foreign import javascript "$r = $3.isPointInStroke($1, $2);" - js_isPointInStroke :: Double -> Double -> Canvas.Context -> IO Bool + js_isPointInStroke :: Double -> Double -> Canvas.Context -> IO Bool +foreign import javascript interruptible "$1.onload = $c; $1.src = $2;" + js_loadImage :: Element -> JSString -> IO () + instance MonadIO CanvasM where - liftIO = CanvasM . const + liftIO action = CanvasM $ \_ _ -> action +createOrGetImage :: Text -> Text -> IO Element +createOrGetImage name url = do + Just doc <- currentDocument + maybeImg <- getElementById doc name + case maybeImg of + Just img -> return img + Nothing -> do + img <- createElement doc (textToJSString "img") + setAttribute img (textToJSString "style") (textToJSString "display: none") + setAttribute img (textToJSString "id") name + Just body <- getBody doc + _ <- appendChild body img + js_loadImage img (textToJSString url) + return img + instance MonadCanvas CanvasM where type Image CanvasM = Canvas.Canvas - save = CanvasM Canvas.save - restore = CanvasM Canvas.restore - transform a b c d e f = CanvasM (Canvas.transform a b c d e f) - translate x y = CanvasM (Canvas.translate x y) - scale x y = CanvasM (Canvas.scale x y) - newImage w h m = - CanvasM $ - const $ do - buf <- Canvas.create w h - ctx <- Canvas.getContext buf - a <- unCanvasM m ctx - return (buf, a) + save = CanvasM (const Canvas.save) + restore = CanvasM (const Canvas.restore) + transform a b c d e f = CanvasM (const (Canvas.transform a b c d e f)) + translate x y = CanvasM (const (Canvas.translate x y)) + scale x y = CanvasM (const (Canvas.scale x y)) + newImage w h = liftIO (Canvas.create w h) + builtinImage name = liftIO $ do + Just doc <- currentDocument + canvas <- getElementById doc (textToJSString name) + return (Canvas.Canvas . unElement <$> canvas) + withImage img m = liftIO $ do + ctx <- Canvas.getContext img + w <- realToFrac <$> Canvas.width img + h <- realToFrac <$> Canvas.height img + unCanvasM m (w, h) ctx drawImage (Canvas.Canvas c) x y w h = - CanvasM (Canvas.drawImage (Canvas.Image c) x y w h) + CanvasM (const (Canvas.drawImage (Canvas.Image c) x y w h)) + drawImgURL name url w h = CanvasM $ \ _ ctx -> do + img <- createOrGetImage name url + Canvas.drawImage + (Canvas.Image (unElement img)) + (round (-w/2)) + (round (-h/2)) + (round w) + (round h) + ctx globalCompositeOperation op = - CanvasM (js_globalCompositeOperation (textToJSString op)) - lineWidth w = CanvasM (Canvas.lineWidth w) - strokeColor r g b a = CanvasM (Canvas.strokeStyle r g b a) - fillColor r g b a = CanvasM (Canvas.fillStyle r g b a) - font t = CanvasM (Canvas.font (textToJSString t)) - textCenter = CanvasM (Canvas.textAlign Canvas.Center) - textMiddle = CanvasM (Canvas.textBaseline Canvas.Middle) - beginPath = CanvasM Canvas.beginPath - closePath = CanvasM Canvas.closePath - moveTo (x, y) = CanvasM (Canvas.moveTo x y) - lineTo (x, y) = CanvasM (Canvas.lineTo x y) + CanvasM (const (js_globalCompositeOperation (textToJSString op))) + globalAlpha a = CanvasM (const (js_globalAlpha a)) + lineWidth w = CanvasM (const (Canvas.lineWidth w)) + strokeColor r g b a = CanvasM (const (Canvas.strokeStyle r g b a)) + fillColor r g b a = CanvasM (const (Canvas.fillStyle r g b a)) + font t = CanvasM (const (Canvas.font (textToJSString t))) + textCenter = CanvasM (const (Canvas.textAlign Canvas.Center)) + textMiddle = CanvasM (const (Canvas.textBaseline Canvas.Middle)) + beginPath = CanvasM (const Canvas.beginPath) + closePath = CanvasM (const Canvas.closePath) + moveTo (x, y) = CanvasM (const (Canvas.moveTo x y)) + lineTo (x, y) = CanvasM (const (Canvas.lineTo x y)) quadraticCurveTo (x1, y1) (x2, y2) = - CanvasM (Canvas.quadraticCurveTo x1 y1 x2 y2) + CanvasM (const (Canvas.quadraticCurveTo x1 y1 x2 y2)) bezierCurveTo (x1, y1) (x2, y2) (x3, y3) = - CanvasM (Canvas.bezierCurveTo x1 y1 x2 y2 x3 y3) - arc x y r a1 a2 dir = CanvasM (Canvas.arc x y r a1 a2 dir) - rect x y w h = CanvasM (Canvas.rect x y w h) - fill = CanvasM Canvas.fill - stroke = CanvasM Canvas.stroke - fillRect x y w h = CanvasM (Canvas.fillRect x y w h) - fillText t (x, y) = CanvasM (Canvas.fillText (textToJSString t) x y) - measureText t = CanvasM (Canvas.measureText (textToJSString t)) - isPointInPath (x, y) = CanvasM (js_isPointInPath x y) - isPointInStroke (x, y) = CanvasM (js_isPointInStroke x y) + CanvasM (const (Canvas.bezierCurveTo x1 y1 x2 y2 x3 y3)) + arc x y r a1 a2 dir = CanvasM (const (Canvas.arc x y r a1 a2 dir)) + rect x y w h = CanvasM (const (Canvas.rect x y w h)) + fill = CanvasM (const Canvas.fill) + stroke = CanvasM (const Canvas.stroke) + fillRect x y w h = CanvasM (const (Canvas.fillRect x y w h)) + fillText t (x, y) = CanvasM (const (Canvas.fillText (textToJSString t) x y)) + measureText t = CanvasM (const (Canvas.measureText (textToJSString t))) + isPointInPath (x, y) = CanvasM (const (js_isPointInPath x y)) + isPointInStroke (x, y) = CanvasM (const (js_isPointInStroke x y)) + getScreenWidth = CanvasM $ \(w, _) _ -> return w + getScreenHeight = CanvasM $ \(_, h) _ -> return h #else -type CanvasM = Canvas +-- Unfortunately, the Canvas monad from blank-canvas lacks a MonadIO instance. +-- We can recover it by inserting send calls where needed. This looks a lot +-- like a free monad, but we want our own interpreter logic, so it's written +-- by hand. +data CanvasM a = CanvasOp (Maybe Canvas.CanvasContext) (Canvas (CanvasM a)) + | NativeOp (Canvas.DeviceContext -> IO (CanvasM a)) + | PureOp a + deriving (Functor) + +doCanvas :: Maybe Canvas.CanvasContext -> Canvas a -> Canvas a +doCanvas Nothing m = m +doCanvas (Just ctx) m = Canvas.with ctx m + +interpCanvas :: CanvasM a -> Canvas (CanvasM a) +interpCanvas (CanvasOp mctx op) = doCanvas mctx op >>= interpCanvas +interpCanvas other = return other + runCanvasM :: Canvas.DeviceContext -> CanvasM a -> IO a -runCanvasM = Canvas.send +runCanvasM _ (PureOp a) = return a +runCanvasM dctx (NativeOp fm) = fm dctx >>= runCanvasM dctx +runCanvasM dctx m = Canvas.send dctx (interpCanvas m) >>= runCanvasM dctx -instance MonadCanvas Canvas where - type Image Canvas = Canvas.CanvasContext - save = Canvas.save () - restore = Canvas.restore () - transform a b c d e f = Canvas.transform (a, b, c, d, e, f) - translate x y = Canvas.translate (x, y) - scale x y = Canvas.scale (x, y) - newImage w h m = do - ctx <- Canvas.newCanvas (w, h) - a <- Canvas.with ctx m - return (ctx, a) - drawImage img x y w h = +instance Applicative CanvasM where + pure = PureOp + + (CanvasOp mctx1 f) <*> (CanvasOp mctx2 x) = CanvasOp mctx1 (fmap (<*>) f <*> doCanvas mctx2 x) + f <*> x = f `ap` x + +instance Monad CanvasM where + return = pure + PureOp x >>= f = f x + NativeOp op >>= f = NativeOp $ \dctx -> do + next <- op dctx + return (next >>= f) + CanvasOp mctx op >>= f = CanvasOp mctx $ bindCanvas (doCanvas mctx op) f + +bindCanvas :: Canvas (CanvasM a) -> (a -> CanvasM b) -> Canvas (CanvasM b) +bindCanvas m cont = do + next <- m + case next of + CanvasOp mctx op -> bindCanvas (doCanvas mctx op) cont + _ -> return (next >>= cont) + +instance MonadIO CanvasM where + liftIO x = NativeOp $ const $ PureOp <$> x + +liftCanvas :: Canvas a -> CanvasM a +liftCanvas m = CanvasOp Nothing (PureOp <$> m) + +instance MonadCanvas CanvasM where + type Image CanvasM = Canvas.CanvasContext + + save = liftCanvas $ Canvas.save () + restore = liftCanvas $ Canvas.restore () + transform a b c d e f = liftCanvas $ Canvas.transform (a, b, c, d, e, f) + translate x y = liftCanvas $ Canvas.translate (x, y) + scale x y = liftCanvas $ Canvas.scale (x, y) + newImage w h = liftCanvas $ Canvas.newCanvas (w, h) + builtinImage _name = return Nothing + + withImage ctx (CanvasOp Nothing m) = CanvasOp (Just ctx) m + withImage _ (CanvasOp mctx m) = CanvasOp mctx m + withImage ctx (NativeOp fm) = NativeOp $ \dctx -> withImage ctx <$> fm dctx + withImage _ (PureOp x) = PureOp x + + drawImage img x y w h = liftCanvas $ Canvas.drawImageSize ( img , fromIntegral x , fromIntegral y , fromIntegral w , fromIntegral h) - globalCompositeOperation op = Canvas.globalCompositeOperation op - lineWidth w = Canvas.lineWidth w - strokeColor r g b a = Canvas.strokeStyle + + drawImgURL _name _url _w _h = return () + + globalCompositeOperation op = liftCanvas $ Canvas.globalCompositeOperation op + globalAlpha a = liftCanvas $ Canvas.globalAlpha a + lineWidth w = liftCanvas $ Canvas.lineWidth w + strokeColor r g b a = liftCanvas $ Canvas.strokeStyle (pack (printf "rgba(%d,%d,%d,%.2f)" r g b a)) - fillColor r g b a = Canvas.fillStyle + fillColor r g b a = liftCanvas $ Canvas.fillStyle (pack (printf "rgba(%d,%d,%d,%.2f)" r g b a)) - font t = Canvas.font t - textCenter = Canvas.textAlign Canvas.CenterAnchor - textMiddle = Canvas.textBaseline Canvas.MiddleBaseline - beginPath = Canvas.beginPath () - closePath = Canvas.closePath () - moveTo (x, y) = Canvas.moveTo (x, y) - lineTo (x, y) = Canvas.lineTo (x, y) - quadraticCurveTo (x1, y1) (x2, y2) = + font t = liftCanvas $ Canvas.font t + textCenter = liftCanvas $ Canvas.textAlign Canvas.CenterAnchor + textMiddle = liftCanvas $ Canvas.textBaseline Canvas.MiddleBaseline + beginPath = liftCanvas $ Canvas.beginPath () + closePath = liftCanvas $ Canvas.closePath () + moveTo (x, y) = liftCanvas $ Canvas.moveTo (x, y) + lineTo (x, y) = liftCanvas $ Canvas.lineTo (x, y) + quadraticCurveTo (x1, y1) (x2, y2) = liftCanvas $ Canvas.quadraticCurveTo (x1, y1, x2, y2) - bezierCurveTo (x1, y1) (x2, y2) (x3, y3) = + bezierCurveTo (x1, y1) (x2, y2) (x3, y3) = liftCanvas $ Canvas.bezierCurveTo (x1, y1, x2, y2, x3, y3) - arc x y r a1 a2 dir = Canvas.arc (x, y, r, a1, a2, dir) - rect x y w h = Canvas.rect (x, y, w, h) - fill = Canvas.fill () - stroke = Canvas.stroke () - fillRect x y w h = Canvas.fillRect (x, y, w, h) - fillText t (x, y) = Canvas.fillText (t, x, y) - measureText t = do + arc x y r a1 a2 dir = liftCanvas $ + Canvas.arc (x, y, r, a1, a2, dir) + rect x y w h = liftCanvas $ Canvas.rect (x, y, w, h) + fill = liftCanvas $ Canvas.fill () + stroke = liftCanvas $ Canvas.stroke () + fillRect x y w h = liftCanvas $ Canvas.fillRect (x, y, w, h) + fillText t (x, y) = liftCanvas $ Canvas.fillText (t, x, y) + measureText t = liftCanvas $ do Canvas.TextMetrics w <- Canvas.measureText t return w - isPointInPath (x, y) = Canvas.isPointInPath (x, y) - isPointInStroke (x, y) = return False + isPointInPath (x, y) = liftCanvas $ Canvas.isPointInPath (x, y) + isPointInStroke _ = liftCanvas $ return False + getScreenWidth = liftCanvas $ Canvas.width <$> Canvas.myCanvasContext + getScreenHeight = liftCanvas $ Canvas.height <$> Canvas.myCanvasContext #endif diff --git a/src/CodeWorld/CollaborationUI.hs b/src/CodeWorld/CollaborationUI.hs --- a/src/CodeWorld/CollaborationUI.hs +++ b/src/CodeWorld/CollaborationUI.hs @@ -1,11 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors -Wno-name-shadowing #-} {- Copyright 2019 The CodeWorld Authors. All rights reserved. @@ -23,23 +24,22 @@ limitations under the License. -} module CodeWorld.CollaborationUI - ( UIState - , SetupPhase(..) - , Step(..) - , initial - , step - , event - , picture - , startWaiting - , updatePlayers - ) where + ( UIState, + SetupPhase (..), + Step (..), + initial, + step, + event, + picture, + startWaiting, + updatePlayers, + ) +where import CodeWorld.Color import CodeWorld.Event import CodeWorld.Picture - import Data.Char -import Data.Monoid import qualified Data.Text as T import Data.Text (Text) @@ -50,36 +50,39 @@ -- The possible UI-triggered transitions of this state are described by -- 'Step'. data SetupPhase - = SMain - | SConnect - | SWait + = SMain + | SConnect + | SWait -- | Possible steps taken from a given setup phase data family Step :: (SetupPhase -> *) -> SetupPhase -> * -data instance Step f SMain = ContinueMain (f SMain) - | Create (f SConnect) - | Join Text (f SConnect) +data instance Step f SMain + = ContinueMain (f SMain) + | Create (f SConnect) + | Join Text (f SConnect) -data instance Step f SConnect = ContinueConnect (f SConnect) - | CancelConnect (f SMain) +data instance Step f SConnect + = ContinueConnect (f SConnect) + | CancelConnect (f SMain) -data instance Step f SWait = ContinueWait (f SWait) - | CancelWait (f SMain) +data instance Step f SWait + = ContinueWait (f SWait) + | CancelWait (f SMain) -- | The UI state, indexed by the 'SetupPhase' data UIState (s :: SetupPhase) where - MainMenu :: Double -> Point -> UIState SMain - Joining :: Double -> Point -> Text -> UIState SMain - Connecting :: Double -> Point -> UIState SConnect - Waiting - :: Double - -> Point - -> Text - -> Int - -> Int {- numPlayers :: -} - {- present -} - -> UIState SWait + MainMenu :: Double -> Point -> UIState SMain + Joining :: Double -> Point -> Text -> UIState SMain + Connecting :: Double -> Point -> UIState SConnect + Waiting :: + Double -> + Point -> + Text -> + Int -> + Int {- numPlayers :: -} -> + {- present -} + UIState SWait continueUIState :: UIState s -> Step UIState s continueUIState s@MainMenu {} = ContinueMain s @@ -120,7 +123,7 @@ updatePlayers :: Int -> Int -> UIState SWait -> UIState SWait updatePlayers n m (Waiting time mousePos code _ _) = - Waiting time mousePos code n m + Waiting time mousePos code n m -- | Handling a UI event. May change the phase. event :: Event -> UIState s -> Step UIState s @@ -128,35 +131,42 @@ event CreateClick (MainMenu t p) = Create (Connecting t p) event JoinClick (MainMenu t p) = ContinueMain (Joining t p "") event (LetterPress k) (Joining t p code) - | T.length code < 4 = ContinueMain (Joining t p (code <> k)) + | T.length code < 4 = ContinueMain (Joining t p (code <> k)) event BackSpace (Joining t p code) - | T.length code > 0 = ContinueMain (Joining t p (T.init code)) + | T.length code > 0 = ContinueMain (Joining t p (T.init code)) event ConnectClick (Joining t p code) - | T.length code == 4 = Join code (Connecting t p) -event CancelClick (Joining t p code) = ContinueMain (MainMenu t p) + | T.length code == 4 = Join code (Connecting t p) +event CancelClick (Joining t p _) = ContinueMain (MainMenu t p) event CancelClick (Connecting t p) = CancelConnect (MainMenu t p) -event CancelClick (Waiting t p c n m) = CancelWait (MainMenu t p) +event CancelClick (Waiting t p _ _ _) = CancelWait (MainMenu t p) event _ s = continueUIState s +pattern CreateClick :: Event pattern CreateClick <- - PointerPress (inButton 0 1.5 8 2 -> True) + PointerPress (inButton 0 1.5 8 2 -> True) +pattern JoinClick :: Event pattern JoinClick <- - PointerPress (inButton 0 (-1.5) 8 2 -> True) + PointerPress (inButton 0 (-1.5) 8 2 -> True) +pattern ConnectClick :: Event pattern ConnectClick <- - PointerPress (inButton 0 (-3.0) 8 2 -> True) + PointerPress (inButton 0 (-3.0) 8 2 -> True) +pattern LetterPress :: Text -> Event pattern LetterPress c <- (isLetterPress -> Just c) +pattern BackSpace :: Event pattern BackSpace <- KeyPress "Backspace" +pattern CancelClick :: Event pattern CancelClick <- (isCancelClick -> True) isLetterPress :: Event -> Maybe Text isLetterPress (KeyPress k) - | T.length k == 1 - , isLetter (T.head k) = Just (T.toUpper k) + | T.length k == 1, + isLetter (T.head k) = + Just (T.toUpper k) isLetterPress _ = Nothing isCancelClick :: Event -> Bool @@ -166,90 +176,95 @@ picture :: UIState s -> Picture picture (MainMenu time mousePos) = - button "New" (dull green) 0 1.5 8 2 mousePos & - button "Join" (dull green) 0 (-1.5) 8 2 mousePos & - connectScreen "Main Menu" time + button "New" (dull green) 0 1.5 8 2 mousePos + & button "Join" (dull green) 0 (-1.5) 8 2 mousePos + & connectScreen "Main Menu" time picture (Joining time mousePos code) = - translated 0 2 (lettering "Enter the game key:") & letterBoxes white code & - (if T.length code < 4 - then button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos - else button "Join" (dull green) 0 (-3) 8 2 mousePos) & - connectScreen "Join Game" time + translated 0 2 (lettering "Enter the game key:") & letterBoxes white code + & ( if T.length code < 4 + then button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos + else button "Join" (dull green) 0 (-3) 8 2 mousePos + ) + & connectScreen "Join Game" time picture (Connecting time mousePos) = - button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos & - connectScreen "Connecting..." time + button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos + & connectScreen "Connecting..." time picture (Waiting time mousePos code numPlayers present) = - translated 0 2 (lettering "Share this key with other players:") & - translated 0 4 (playerDots numPlayers present) & - letterBoxes (HSL 0 0 0.8) code & - button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos & - connectScreen "Waiting" time + translated 0 2 (lettering "Share this key with other players:") + & translated 0 4 (playerDots numPlayers present) + & letterBoxes (HSL 0 0 0.8) code + & button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos + & connectScreen "Waiting" time letterBoxes :: Color -> Text -> Picture letterBoxes color txt = - pictures - [ translated x 0 (letterBox color (T.singleton c)) - | c <- pad 4 ' ' (take 4 (T.unpack txt)) - | x <- [-3, -1, 1, 3] - ] + pictures + [ translated x 0 (letterBox color (T.singleton c)) + | c <- pad 4 ' ' (take 4 (T.unpack txt)) + | x <- [-3, -1, 1, 3] + ] letterBox :: Color -> Text -> Picture letterBox c t = - thickRectangle 0.1 1.5 1.5 & lettering t & colored c (solidRectangle 1.5 1.5) + thickRectangle 0.1 1.5 1.5 & lettering t & colored c (solidRectangle 1.5 1.5) pad :: Int -> a -> [a] -> [a] pad 0 _ xs = xs -pad n v (x:xs) = x : pad (n - 1) v xs +pad n v (x : xs) = x : pad (n - 1) v xs pad n v [] = v : pad (n - 1) v [] inButton :: Double -> Double -> Double -> Double -> Point -> Bool inButton x y w h (mx, my) = - mx >= x - w / 2 && mx <= x + w / 2 && my >= y - h / 2 && my <= y + h / 2 + mx >= x - w / 2 && mx <= x + w / 2 && my >= y - h / 2 && my <= y + h / 2 button :: - Text -> Color -> Double -> Double -> Double -> Double -> Point -> Picture + Text -> Color -> Double -> Double -> Double -> Double -> Point -> Picture button txt btnColor x y w h (mx, my) = - translated x y $ - colored white (styledLettering Plain SansSerif txt) & - colored color (roundRect w h) + translated x y $ + colored white (styledLettering Plain SansSerif txt) + & colored color (roundRect w h) where color - | inButton x y w h (mx, my) = btnColor - | otherwise = dark btnColor + | inButton x y w h (mx, my) = btnColor + | otherwise = dark btnColor roundRect :: Double -> Double -> Picture roundRect w h = - solidRectangle w (h - 0.5) & solidRectangle (w - 0.5) h & - pictures - [ translated x y (solidCircle 0.25) - | x <- [-w / 2 + 0.25, w / 2 - 0.25] - , y <- [-h / 2 + 0.25, h / 2 - 0.25] - ] + solidRectangle w (h - 0.5) & solidRectangle (w - 0.5) h + & pictures + [ translated x y (solidCircle 0.25) + | x <- [- w / 2 + 0.25, w / 2 - 0.25], + y <- [- h / 2 + 0.25, h / 2 - 0.25] + ] +playerDots :: Int -> Int -> Picture playerDots n m - | n > 8 = lettering $ T.pack $ show m ++ " / " ++ show n + | n > 8 = lettering $ T.pack $ show m ++ " / " ++ show n playerDots n m = - pictures - [ translated - (size * fromIntegral i - size * fromIntegral n / 2) - 0 - (dot (i <= m)) - | i <- [1 .. n] - ] + pictures + [ translated + (size * fromIntegral i - size * fromIntegral n / 2) + 0 + (dot (i <= m)) + | i <- [1 .. n] + ] where dot True = solidCircle (0.4 * size) dot False = circle (0.4 * size) size = 1 connectScreen :: Text -> Double -> Picture -connectScreen hdr t = translated 0 (-7) connectBox - & translated 0 2.5 (colored background (solidRectangle 20 3.5)) - & translated 0 5 codeWorldLogo - & colored background (solidRectangle 20 20) +connectScreen hdr t = + translated 0 (-7) connectBox + & translated 0 2.5 (colored background (solidRectangle 20 4)) + & translated 0 5 codeWorldLogo + & colored background (solidRectangle 20 20) where - connectBox = scaled 2 2 (lettering hdr) - & rectangle 14 3 - & colored connectColor (solidRectangle 14 3) - connectColor = let k = (1 + sin (3 * t)) / 5 - in HSL (k + 0.5) 0.8 0.7 + connectBox = + scaled 2 2 (lettering hdr) + & rectangle 14 3 + & colored connectColor (solidRectangle 14 3) + connectColor = + let k = (1 + sin (3 * t)) / 5 + in HSL (k + 0.5) 0.8 0.7 background = RGBA 0.85 0.86 0.9 1 diff --git a/src/CodeWorld/Color.hs b/src/CodeWorld/Color.hs --- a/src/CodeWorld/Color.hs +++ b/src/CodeWorld/Color.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {- Copyright 2019 The CodeWorld Authors. All rights reserved. @@ -18,29 +20,29 @@ -} module CodeWorld.Color where -import Data.Fixed (mod') -import Data.List (unfoldr) +import Control.DeepSeq +import GHC.Generics (Generic) -import System.Random (mkStdGen) -import System.Random.Shuffle (shuffle') +data Color + = RGBA + !Double + !Double + !Double + !Double + deriving (Generic, Show, Eq) -data Color = - RGBA !Double - !Double - !Double - !Double - deriving (Show, Eq) +instance NFData Color type Colour = Color pattern RGB :: Double -> Double -> Double -> Color - pattern RGB r g b = RGBA r g b 1 pattern HSL :: Double -> Double -> Double -> Color - -pattern HSL h s l <- (toHSL -> Just (h, s, l)) - where HSL h s l = fromHSL h s l +pattern HSL h s l <- + (toHSL -> Just (h, s, l)) + where + HSL h s l = fromHSL h s l -- Utility functions for pattern synonyms. fence :: Double -> Double @@ -58,18 +60,18 @@ where m1 = l * 2 - m2 m2 - | l <= 0.5 = l * (s + 1) - | otherwise = l + s - l * s + | l <= 0.5 = l * (s + 1) + | otherwise = l + s - l * s r = convert m1 m2 (h / 2 / pi + 1 / 3) g = convert m1 m2 (h / 2 / pi) b = convert m1 m2 (h / 2 / pi - 1 / 3) convert m1 m2 h - | h < 0 = convert m1 m2 (h + 1) - | h > 1 = convert m1 m2 (h - 1) - | h * 6 < 1 = m1 + (m2 - m1) * h * 6 - | h * 2 < 1 = m2 - | h * 3 < 2 = m1 + (m2 - m1) * (2 / 3 - h) * 6 - | otherwise = m1 + | h < 0 = convert m1 m2 (h + 1) + | h > 1 = convert m1 m2 (h - 1) + | h * 6 < 1 = m1 + (m2 - m1) * h * 6 + | h * 2 < 1 = m2 + | h * 3 < 2 = m1 + (m2 - m1) * (2 / 3 - h) * 6 + | otherwise = m1 toHSL :: Color -> Maybe (Double, Double, Double) toHSL c@(RGBA _ _ _ 1) = Just (hue c, saturation c, luminosity c) @@ -77,40 +79,41 @@ mixed :: [Color] -> Color mixed colors = go 0 0 0 0 0 colors - where go rr gg bb aa n ((fenceColor -> RGBA r g b a) : cs) = - go (rr + r^2 * a) (gg + g^2 * a) (bb + b^2 * a) (aa + a) (n + 1) cs - go rr gg bb aa n [] - | aa == 0 = RGBA 0 0 0 0 - | otherwise = RGBA (sqrt (rr/aa)) (sqrt (gg/aa)) (sqrt (bb/aa)) (aa/n) + where + go rr gg bb aa n ((fenceColor -> RGBA r g b a) : cs) = + go (rr + r * r * a) (gg + g * g * a) (bb + b * b * a) (aa + a) (n + 1) cs + go rr gg bb aa n [] + | aa == 0 = RGBA 0 0 0 0 + | otherwise = RGBA (sqrt (rr / aa)) (sqrt (gg / aa)) (sqrt (bb / aa)) (aa / n) -- Helper function that sets the alpha of the second color to that -- of the first sameAlpha :: Color -> Color -> Color -sameAlpha (fenceColor -> RGBA r1 g1 b1 a1) (fenceColor -> RGBA r2 g2 b2 a2) = - RGBA r2 g2 b2 a1 +sameAlpha (fenceColor -> RGBA _ _ _ a1) (fenceColor -> RGBA r2 g2 b2 _) = + RGBA r2 g2 b2 a1 lighter :: Double -> Color -> Color lighter d c = - sameAlpha c $ HSL (hue c) (saturation c) (fence (luminosity c + d)) + sameAlpha c $ HSL (hue c) (saturation c) (fence (luminosity c + d)) light :: Color -> Color light = lighter 0.15 darker :: Double -> Color -> Color -darker d = lighter (-d) +darker d = lighter (- d) dark :: Color -> Color dark = darker 0.15 brighter :: Double -> Color -> Color brighter d c = - sameAlpha c $ HSL (hue c) (fence (saturation c + d)) (luminosity c) + sameAlpha c $ HSL (hue c) (fence (saturation c + d)) (luminosity c) bright :: Color -> Color bright = brighter 0.25 duller :: Double -> Color -> Color -duller d = brighter (-d) +duller d = brighter (- d) dull :: Color -> Color dull = duller 0.25 @@ -120,155 +123,150 @@ -- | An infinite list of colors. assortedColors :: [Color] -assortedColors = [ HSL (adjusted h) 0.75 0.5 | h <- [0, 2 * pi / phi ..] ] +assortedColors = [HSL (adjusted h) 0.75 0.5 | h <- [0, 2 * pi / phi ..]] where phi = (1 + sqrt 5) / 2 - adjusted x = x + a0 - + a1 * sin (1*x) + b1 * cos (1*x) - + a2 * sin (2*x) + b2 * cos (2*x) - + a3 * sin (3*x) + b3 * cos (3*x) - + a4 * sin (4*x) + b4 * cos (4*x) + adjusted x = + x + a0 + + a1 * sin (1 * x) + + b1 * cos (1 * x) + + a2 * sin (2 * x) + + b2 * cos (2 * x) + + a3 * sin (3 * x) + + b3 * cos (3 * x) + + a4 * sin (4 * x) + + b4 * cos (4 * x) a0 = -8.6870353473225553e-02 - a1 = 8.6485747604766350e-02 + a1 = 8.6485747604766350e-02 b1 = -9.6564816819163041e-02 a2 = -3.0072759267059756e-03 - b2 = 1.5048456422494966e-01 - a3 = 9.3179137558373148e-02 - b3 = 2.9002513227535595e-03 + b2 = 1.5048456422494966e-01 + a3 = 9.3179137558373148e-02 + b3 = 2.9002513227535595e-03 a4 = -6.6275768228887290e-03 b4 = -1.0451841243520298e-02 hue :: Color -> Double -hue (fenceColor -> RGBA r g b a) - | hi - lo < epsilon = 0 - | r == hi && g >= b = (g - b) / (hi - lo) * pi / 3 - | r == hi = (g - b) / (hi - lo) * pi / 3 + 2 * pi - | g == hi = (b - r) / (hi - lo) * pi / 3 + 2 / 3 * pi - | otherwise = (r - g) / (hi - lo) * pi / 3 + 4 / 3 * pi +hue (fenceColor -> RGBA r g b _) + | hi - lo < epsilon = 0 + | r == hi && g >= b = (g - b) / (hi - lo) * pi / 3 + | r == hi = (g - b) / (hi - lo) * pi / 3 + 2 * pi + | g == hi = (b - r) / (hi - lo) * pi / 3 + 2 / 3 * pi + | otherwise = (r - g) / (hi - lo) * pi / 3 + 4 / 3 * pi where hi = max r (max g b) lo = min r (min g b) epsilon = 0.000001 saturation :: Color -> Double -saturation (fenceColor -> RGBA r g b a) - | hi - lo < epsilon = 0 - | otherwise = (hi - lo) / (1 - abs (hi + lo - 1)) +saturation (fenceColor -> RGBA r g b _) + | hi - lo < epsilon = 0 + | otherwise = (hi - lo) / (1 - abs (hi + lo - 1)) where hi = max r (max g b) lo = min r (min g b) epsilon = 0.000001 luminosity :: Color -> Double -luminosity (fenceColor -> RGBA r g b a) = (lo + hi) / 2 +luminosity (fenceColor -> RGBA r g b _) = (lo + hi) / 2 where hi = max r (max g b) lo = min r (min g b) alpha :: Color -> Double -alpha (RGBA r g b a) = fence a +alpha (RGBA _ _ _ a) = fence a --- New-style colors +-- Old-style colors -pattern White :: Color -pattern White = HSL 0.00 0.00 1.00 +white, black, red, green, blue, cyan, magenta, yellow :: Color -pattern Black :: Color -pattern Black = HSL 0.00 0.00 0.00 +orange, rose, chartreuse, aquamarine, violet, azure :: Color -pattern Gray :: Color -pattern Gray = HSL 0.00 0.00 0.50 +gray, grey, brown, purple, pink :: Color -pattern Grey :: Color -pattern Grey = HSL 0.00 0.00 0.50 +white = HSL 0.00 0.00 1.00 -pattern Red :: Color -pattern Red = HSL 0.00 0.75 0.50 +black = HSL 0.00 0.00 0.00 -pattern Orange :: Color -pattern Orange = HSL 0.61 0.75 0.50 +gray = HSL 0.00 0.00 0.50 -pattern Yellow :: Color -pattern Yellow = HSL 0.98 0.75 0.50 +grey = HSL 0.00 0.00 0.50 -pattern Green :: Color -pattern Green = HSL 2.09 0.75 0.50 +red = HSL 0.00 0.75 0.50 -pattern Blue :: Color -pattern Blue = HSL 3.84 0.75 0.50 +orange = HSL 0.61 0.75 0.50 -pattern Purple :: Color -pattern Purple = HSL 4.80 0.75 0.50 +yellow = HSL 0.98 0.75 0.50 -pattern Pink :: Color -pattern Pink = HSL 5.76 0.75 0.75 +green = HSL 2.09 0.75 0.50 -pattern Brown :: Color -pattern Brown = HSL 0.52 0.60 0.40 +blue = HSL 3.84 0.75 0.50 --- Old-style colors +purple = HSL 4.80 0.75 0.50 -white, black, red, green, blue, cyan, magenta, yellow :: Color -orange, rose, chartreuse, aquamarine, violet, azure :: Color -gray, grey :: Color +pink = HSL 5.76 0.75 0.75 -white = White -black = Black -red = Red -yellow = Yellow -green = Green -blue = Blue -orange = Orange -brown = Brown -purple = Purple -pink = Pink -gray = Gray -grey = Grey +brown = HSL 0.52 0.60 0.40 cyan = HSL (3 / 3 * pi) 0.75 0.5 + magenta = HSL (5 / 3 * pi) 0.75 0.5 + chartreuse = HSL (3 / 6 * pi) 0.75 0.5 + aquamarine = HSL (5 / 6 * pi) 0.75 0.5 + azure = HSL (7 / 6 * pi) 0.75 0.5 + violet = HSL (9 / 6 * pi) 0.75 0.5 + rose = HSL (11 / 6 * pi) 0.75 0.5 -{-# WARNING White [ "Please use white (lower case) instead of White." - , "The value White may be removed July 2019." ] #-} -{-# WARNING Black [ "Please use black (lower case) instead of Black." - , "The value Black may be removed July 2019." ] #-} -{-# WARNING Red [ "Please use red (lower case) instead of Red." - , "The value Red may be removed July 2019." ] #-} -{-# WARNING Green [ "Please use green (lower case) instead of Green." - , "The value Green may be removed July 2019." ] #-} -{-# WARNING Blue [ "Please use blue (lower case) instead of Blue." - , "The value Blue may be removed July 2019." ] #-} -{-# WARNING Yellow [ "Please use yellow (lower case) instead of Yellow." - , "The value Yellow may be removed July 2019." ] #-} -{-# WARNING Orange [ "Please use orange (lower case) instead of Orange." - , "The value Orange may be removed July 2019." ] #-} -{-# WARNING Brown [ "Please use brown (lower case) instead of Brown." - , "The value Brown may be removed July 2019." ] #-} -{-# WARNING Purple [ "Please use purple (lower case) instead of Purple." - , "The value Purple may be removed July 2019." ] #-} -{-# WARNING Pink [ "Please use pink (lower case) instead of Pink." - , "The value Pink may be removed July 2019." ] #-} -{-# WARNING Gray [ "Please use gray (lower case) instead of Gray." - , "The value Gray may be removed July 2019." ] #-} -{-# WARNING Grey [ "Please use grey (lower case) instead of Grey." - , "The value Grey may be removed July 2019." ] #-} +{-# WARNING + magenta + [ "Please use HSL(5 * pi / 3, 0.75, 0.5) instead of magenta.", + "The variable magenta may be removed July 2020." + ] + #-} -{-# WARNING magenta [ "Please use the RGB function instead of magenta." - , "The variable magenta may be removed July 2020." ] #-} -{-# WARNING cyan [ "Please use the RGB function instead of cyan." - , "The variable cyan may be removed July 2020." ] #-} -{-# WARNING chartreuse [ "Please use the RGB function instead of chartreuse." - , "The variable chartreuse may be removed July 2020." ] #-} -{-# WARNING aquamarine [ "Please use the RGB function instead of aquamarine." - , "The variable aquamarine may be removed July 2020." ] #-} -{-# WARNING azure [ "Please use the RGB function instead of azure." - , "The variable azure may be removed July 2020." ] #-} -{-# WARNING rose [ "Please use the RGB function instead of rose." - , "The variable rose may be removed July 2020." ] #-} -{-# WARNING violet [ "Please use Purple instead of violet." - , "The variable violet may be removed July 2020." ] #-} +{-# WARNING + cyan + [ "Please use HSL(pi, 0.75, 0.5) instead of cyan.", + "The variable cyan may be removed July 2020." + ] + #-} + +{-# WARNING + chartreuse + [ "Please use HSL(pi / 2, 0.75, 0.5) instead of chartreuse.", + "The variable chartreuse may be removed July 2020." + ] + #-} + +{-# WARNING + aquamarine + [ "Please use HSL(5 * pi / 6, 0.75, 0.5) instead of aquamarine.", + "The variable aquamarine may be removed July 2020." + ] + #-} + +{-# WARNING + azure + [ "Please use HSL(7 * pi / 6, 0.75, 0.5) instead of azure.", + "The variable azure may be removed July 2020." + ] + #-} + +{-# WARNING + rose + [ "Please use HSL(11 * pi / 6, 0.75, 0.5) instead of rose.", + "The variable rose may be removed July 2020." + ] + #-} + +{-# WARNING + violet + [ "Please use purple instead of violet.", + "The variable violet may be removed July 2020." + ] + #-} diff --git a/src/CodeWorld/DrawState.hs b/src/CodeWorld/DrawState.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/DrawState.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns #-} + +{- + Copyright 2019 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.DrawState where + +import CodeWorld.Color + +data DrawState + = -- | A 'Color', if already chosen. + DrawState + !AffineTransformation + !(Maybe Color) + +-- | @(AffineTransformation a b c d e f)@ represents an affine transformation matrix +-- +-- > a c e +-- > b d f +-- > 0 0 1 +-- +-- References: +-- https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D/transform +-- https://en.wikipedia.org/wiki/Transformation_matrix#Affine_transformations +data AffineTransformation + = AffineTransformation !Double !Double !Double !Double !Double !Double + +initialAffineTransformation :: AffineTransformation +initialAffineTransformation = AffineTransformation 1 0 0 1 0 0 + +mapDSAT :: (AffineTransformation -> AffineTransformation) -> DrawState -> DrawState +mapDSAT f (DrawState at mc) = DrawState (f at) mc + +mapDSColor :: (Maybe Color -> Maybe Color) -> DrawState -> DrawState +mapDSColor f (DrawState at mc) = DrawState at (f mc) + +initialDS :: DrawState +initialDS = DrawState initialAffineTransformation Nothing + +translateDS :: Double -> Double -> DrawState -> DrawState +translateDS x y = mapDSAT $ \(AffineTransformation a b c d e f) -> + AffineTransformation + a + b + c + d + (a * x + c * y + e) + (b * x + d * y + f) + +scaleDS :: Double -> Double -> DrawState -> DrawState +scaleDS x y = mapDSAT $ \(AffineTransformation a b c d e f) -> + AffineTransformation (x * a) (x * b) (y * c) (y * d) e f + +rotateDS :: Double -> DrawState -> DrawState +rotateDS r = mapDSAT $ \(AffineTransformation a b c d e f) -> + AffineTransformation + (a * cos r + c * sin r) + (b * cos r + d * sin r) + (c * cos r - a * sin r) + (d * cos r - b * sin r) + e + f + +setColorDS :: Color -> DrawState -> DrawState +setColorDS col = mapDSColor $ \mcol -> + case (col, mcol) of + (_, Nothing) -> Just col + (RGBA _ _ _ 0, Just _) -> Just col + (RGBA _ _ _ a1, Just (RGBA r0 g0 b0 a0)) -> Just (RGBA r0 g0 b0 (a0 * a1)) + +opaqueDS :: DrawState -> DrawState +opaqueDS = mapDSColor $ fmap $ \(RGBA r g b _) -> RGBA r g b 1 + +getColorDS :: DrawState -> Maybe Color +getColorDS (DrawState _ col) = col diff --git a/src/CodeWorld/Driver.hs b/src/CodeWorld/Driver.hs --- a/src/CodeWorld/Driver.hs +++ b/src/CodeWorld/Driver.hs @@ -1,2412 +1,2049 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE JavaScriptFFI #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StaticPointers #-} -{-# LANGUAGE DataKinds #-} - -{- - Copyright 2019 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 - ( drawingOf - , animationOf - , activityOf - , debugActivityOf - , groupActivityOf - , unsafeGroupActivityOf - , simulationOf - , debugSimulationOf - , interactionOf - , debugInteractionOf - , collaborationOf - , unsafeCollaborationOf - , trace - ) where - -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 -import Control.Concurrent -import Control.Concurrent.Chan -import Control.Concurrent.MVar -import Control.Exception -import Control.Monad -import Control.Monad.Trans (liftIO) -import Data.Char (chr) -import Data.List (find, zip4, intercalate) -import Data.Maybe (fromMaybe, isNothing, mapMaybe) -import Data.Monoid -import Data.Serialize -import Data.Serialize.Text -import qualified Data.Text as T -import Data.Text (Text, pack, singleton) -import qualified Debug.Trace -import GHC.Fingerprint.Type -import GHC.Generics -import GHC.Prim -import GHC.Stack -import GHC.StaticPtr -import Numeric (showFFloatAlt) -import System.Environment -import System.IO -import System.IO.Unsafe -import System.Mem.StableName -import System.Random -import Text.Printf -import Text.Read - -#ifdef ghcjs_HOST_OS - -import CodeWorld.Message -import CodeWorld.Prediction -import qualified Control.Monad.Trans.State as State -import Data.Hashable -import Data.IORef -import qualified Data.JSString -import Data.JSString.Text -import Data.Word -import GHCJS.Concurrent (withoutPreemption) -import GHCJS.DOM -import qualified GHCJS.DOM.ClientRect as ClientRect -import GHCJS.DOM.Document -import GHCJS.DOM.Element -import GHCJS.DOM.EventM -import GHCJS.DOM.GlobalEventHandlers hiding (error) -import GHCJS.DOM.MouseEvent -import GHCJS.DOM.NonElementParentNode -import GHCJS.DOM.Types (Element, unElement) -import qualified GHCJS.DOM.Window as Window -import GHCJS.Foreign -import GHCJS.Foreign.Callback -import GHCJS.Marshal -import GHCJS.Marshal.Pure -import GHCJS.Types -import qualified JavaScript.Array as Array -import JavaScript.Object -import JavaScript.Web.AnimationFrame -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.WebSocket as WS -import Unsafe.Coerce - -#else - -import Data.Time.Clock -import qualified Graphics.Blank as Canvas -import Graphics.Blank (Canvas) -import Text.Printf - -#endif - --------------------------------------------------------------------------------- --- The common interface, provided by both implementations below. --- | Draws a 'Picture'. This is the simplest CodeWorld entry point. -drawingOf :: Picture -- ^ The picture to show on the screen. - -> IO () - --- | Shows an animation, with a picture for each time given by the parameter. -animationOf :: (Double -> Picture) -- ^ A function that produces animation - -- frames, given the time in seconds. - -> IO () - --- | Runs an interactive CodeWorld program that responds to events. Activities --- can interact with the user, change over time, and remember information about --- the past. -activityOf - :: 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 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 - :: Int -- ^ The number of participants to expect. The participants will be - -- ^ numbered starting at 0. - -> StaticPtr (StdGen -> world) - -- ^ The initial state of the activity. - -> StaticPtr (Int -> Event -> world -> world) - -- ^ The event handling function, which updates the state given a - -- participant number and user interface event. - -> StaticPtr (Int -> world -> Picture) - -- ^ The visualization function, which converts a participant number - -- and the state into a picture to display. - -> IO () - --- | A version of 'groupActivityOf' that avoids static pointers, and does not --- check for consistency. -unsafeGroupActivityOf - :: Int -- ^ The number of participants to expect. The participants will be - -- ^ numbered starting at 0. - -> (StdGen -> world) - -- ^ The initial state of the activity. - -> (Int -> Event -> world -> world) - -- ^ The event handling function, which updates the state given a - -- participant number and user interface event. - -> (Int -> world -> Picture) - -- ^ The visualization function, which converts a participant number - -- and the state into a picture to display. - -> IO () - --- | Shows a simulation, which is essentially a continuous-time dynamical --- system described by an initial value and step function. -simulationOf - :: 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 () - -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. -interactionOf - :: 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 () - -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 - :: Int -- ^ The number of participants to expect. The participants will be - -- ^ numbered starting at 0. - -> StaticPtr (StdGen -> world) - -- ^ The initial state of the collaboration. - -> StaticPtr (Double -> world -> world) - -- ^ The time step function, which advances the state given the time - -- difference. - -> StaticPtr (Int -> Event -> world -> world) - -- ^ The event handling function, which updates the state given a - -- participant number and user interface event. - -> StaticPtr (Int -> world -> Picture) - -- ^ The visualization function, which converts a participant number - -- and the state into a picture to display. - -> IO () - --- | A version of 'collaborationOf' that avoids static pointers, and does not --- check for consistent parameters. -unsafeCollaborationOf - :: Int -- ^ The number of participants to expect. The participants will be - -- ^ numbered starting at 0. - -> (StdGen -> world) - -- ^ The initial state of the collaboration. - -> (Double -> world -> world) - -- ^ The time step function, which advances the state given the time - -- difference. - -> (Int -> Event -> world -> world) - -- ^ The event handling function, which updates the state given a - -- participant number and user interface event. - -> (Int -> world -> Picture) - -- ^ The visualization function, which converts a participant number - -- and the state into a picture to display. - -> IO () - --- | Prints a debug message to the CodeWorld console when a value is forced. --- This is equivalent to the similarly named function in `Debug.Trace`, except --- that it uses the CodeWorld console instead of standard output. -trace :: Text -> a -> a - --------------------------------------------------------------------------------- --- A Drawing is an intermediate and simpler representation of a Picture, suitable --- for drawing. A drawing does not contain unnecessary metadata like CallStacks. --- The drawer is specific to the platform. -data Drawing - = Shape Drawer - | Transformation (DrawState -> DrawState) - Drawing - | Drawings [Drawing] - -#if MIN_VERSION_base(4,11,0) - -instance Semigroup Drawing where - a <> Drawings bs = Drawings (a : bs) - a <> b = Drawings [a, b] - -#endif - -instance Monoid Drawing where - mempty = Drawings [] - mappend a (Drawings bs) = Drawings (a : bs) - mappend a b = Drawings [a, b] - mconcat = Drawings - --- A DrawState is an affine transformation matrix, plus a Bool indicating whether --- a color has been chosen yet. -type DrawState = (Double, Double, Double, Double, Double, Double, Maybe Color) - --- A NodeId a unique id for each node in a Picture of Drawing, chosen by the order --- the node appears in DFS. When a Picture is converted to a drawing the NodeId's of --- corresponding nodes are shared. Always >=0. -type NodeId = Int - -pictureToDrawing :: Picture -> Drawing -pictureToDrawing (SolidClosedCurve _ pts) = Shape $ polygonDrawer pts True -pictureToDrawing (SolidPolygon _ pts) = Shape $ polygonDrawer pts False -pictureToDrawing (Polygon _ pts) = Shape $ pathDrawer pts 0 True False -pictureToDrawing (ThickPolygon _ pts w) = Shape $ pathDrawer pts w True False -pictureToDrawing (Rectangle _ w h) = Shape $ pathDrawer (rectangleVertices w h) 0 True False -pictureToDrawing (SolidRectangle _ w h) = Shape $ polygonDrawer (rectangleVertices w h) False -pictureToDrawing (ThickRectangle _ lw w h) = Shape $ pathDrawer (rectangleVertices w h) lw True False -pictureToDrawing (ClosedCurve _ pts) = Shape $ pathDrawer pts 0 True True -pictureToDrawing (ThickClosedCurve _ pts w) = Shape $ pathDrawer pts w True True -pictureToDrawing (Circle _ r) = Shape $ arcDrawer 0 (2 * pi) r 0 -pictureToDrawing (SolidCircle _ r) = Shape $ sectorDrawer 0 (2 * pi) r -pictureToDrawing (ThickCircle _ lw r) = Shape $ arcDrawer 0 (2 * pi) r lw -pictureToDrawing (Polyline _ pts) = Shape $ pathDrawer pts 0 False False -pictureToDrawing (ThickPolyline _ pts w) = Shape $ pathDrawer pts w False False -pictureToDrawing (Curve _ pts) = Shape $ pathDrawer pts 0 False True -pictureToDrawing (ThickCurve _ pts w) = Shape $ pathDrawer pts w False True -pictureToDrawing (Sector _ b e r) = Shape $ sectorDrawer b e r -pictureToDrawing (Arc _ b e r) = Shape $ arcDrawer b e r 0 -pictureToDrawing (ThickArc _ b e r w) = Shape $ arcDrawer b e r w -pictureToDrawing (Lettering _ txt) = Shape $ textDrawer Plain Serif txt -pictureToDrawing (Blank _) = Drawings $ [] -pictureToDrawing (StyledLettering _ sty fnt txt) = Shape $ textDrawer sty fnt txt -pictureToDrawing (Logo _) = Shape $ logoDrawer -pictureToDrawing (CoordinatePlane _) = Shape $ coordinatePlaneDrawer -pictureToDrawing (Color _ col p) = - Transformation (setColorDS col) $ pictureToDrawing p -pictureToDrawing (Translate _ x y p) = - Transformation (translateDS x y) $ pictureToDrawing p -pictureToDrawing (Scale _ x y p) = - Transformation (scaleDS x y) $ pictureToDrawing p -pictureToDrawing (Dilate _ k p) = - Transformation (scaleDS k k) $ pictureToDrawing p -pictureToDrawing (Rotate _ r p) = - Transformation (rotateDS r) $ pictureToDrawing p -pictureToDrawing (Pictures _ ps) = Drawings $ pictureToDrawing <$> ps -pictureToDrawing (PictureAnd _ ps) = Drawings $ pictureToDrawing <$> ps - -initialDS :: DrawState -initialDS = (1, 0, 0, 1, 0, 0, Nothing) - -translateDS :: Double -> Double -> DrawState -> DrawState -translateDS x y (a, b, c, d, e, f, hc) = - (a, b, c, d, a * 25 * x + c * 25 * y + e, b * 25 * x + d * 25 * y + f, hc) - -scaleDS :: Double -> Double -> DrawState -> DrawState -scaleDS x y (a, b, c, d, e, f, hc) = (x * a, x * b, y * c, y * d, e, f, hc) - -rotateDS :: Double -> DrawState -> DrawState -rotateDS r (a, b, c, d, e, f, hc) = - ( a * cos r + c * sin r - , b * cos r + d * sin r - , c * cos r - a * sin r - , d * cos r - b * sin r - , e - , f - , hc) - -setColorDS :: Color -> DrawState -> DrawState -setColorDS col (a, b, c, d, e, f, Nothing) = (a, b, c, d, e, f, Just col) -setColorDS col@(RGBA _ _ _ 0) (a, b, c, d, e, f, _) = - (a, b, c, d, e, f, Just col) -setColorDS (RGBA _ _ _ alpha1) (a, b, c, d, e, f, Just (RGBA rr gg bb alpha2)) = - (a, b, c, d, e, f, Just (RGBA rr gg bb (alpha1 * alpha2))) - -getColorDS :: DrawState -> Maybe Color -getColorDS (a, b, c, d, e, f, col) = col - -polygonDrawer :: [Point] -> Bool -> Drawer -pathDrawer :: [Point] -> Double -> Bool -> Bool -> Drawer -sectorDrawer :: Double -> Double -> Double -> Drawer -arcDrawer :: Double -> Double -> Double -> Double -> Drawer -textDrawer :: TextStyle -> Font -> Text -> Drawer -logoDrawer :: Drawer -coordinatePlaneDrawer :: Drawer -coordinatePlaneDrawing :: Drawing -coordinatePlaneDrawing = pictureToDrawing $ axes <> numbers <> guidelines - where - xline y = thickPolyline 0.01 [(-10, y), (10, y)] - xaxis = thickPolyline 0.03 [(-10, 0), (10, 0)] - axes = xaxis <> rotated (pi / 2) xaxis - xguidelines = pictures [xline k | k <- [-10,-9 .. 10]] - guidelines = xguidelines <> rotated (pi / 2) xguidelines - numbers = xnumbers <> ynumbers - xnumbers = - pictures - [ translated - (fromIntegral k) - 0.3 - (scaled 0.5 0.5 (lettering (pack (show k)))) - | k <- [-9,-8 .. 9] - , k /= 0 - ] - ynumbers = - pictures - [ translated - 0.3 - (fromIntegral k) - (scaled 0.5 0.5 (lettering (pack (show k)))) - | k <- [-9,-8 .. 9] - , k /= 0 - ] - -withDS :: DrawState -> CanvasM a -> CanvasM a -withDS (ta, tb, tc, td, te, tf, col) action = CM.saveRestore $ do - CM.transform ta tb tc td te tf - CM.beginPath - action - -applyColor :: DrawState -> CanvasM () -applyColor ds = - case getColorDS ds of - Nothing -> do - CM.strokeColor 0 0 0 1 - CM.fillColor 0 0 0 1 - Just (RGBA r g b a) -> do - CM.strokeColor - (round $ r * 255) - (round $ g * 255) - (round $ b * 255) - a - CM.fillColor - (round $ r * 255) - (round $ g * 255) - (round $ b * 255) - a - -type Drawer = DrawState -> DrawMethods - -data DrawMethods = DrawMethods - { drawShape :: CanvasM () - , shapeContains :: CanvasM Bool - } - -polygonDrawer ps smooth ds = - DrawMethods - { drawShape = do - trace - applyColor ds - CM.fill - , shapeContains = do - trace - CM.isPointInPath (0, 0) - } - where - trace = withDS ds $ followPath ps True smooth - -pathDrawer ps w closed smooth ds = - DrawMethods - { drawShape = drawFigure ds w $ followPath ps closed smooth - , shapeContains = - do let width = - if w == 0 - then 0.3 - else w - drawFigure ds width $ followPath ps closed smooth - CM.isPointInStroke (0, 0) - } - -sectorDrawer b e r ds = - DrawMethods - { drawShape = do - trace - applyColor ds - CM.fill - , shapeContains = do - trace - CM.isPointInPath (0, 0) - } - where - trace = - withDS ds $ do - CM.arc 0 0 (25 * abs r) b e (b > e) - CM.lineTo (0, 0) - -arcDrawer b e r w ds = - DrawMethods - { drawShape = - drawFigure ds w $ CM.arc 0 0 (25 * abs r) b e (b > e) - , shapeContains = - do let width = - if w == 0 - then 0.3 - else w - CM.lineWidth (width * 25) - drawFigure ds width $ - CM.arc 0 0 (25 * abs r) b e (b > e) - CM.isPointInStroke (0, 0) - } - -textDrawer sty fnt txt ds = - DrawMethods - { drawShape = - withDS ds $ do - CM.scale 1 (-1) - applyColor ds - CM.font (fontString sty fnt) - CM.fillText txt (0, 0) - , shapeContains = - do CM.font (fontString sty fnt) - width <- CM.measureText txt - let height = 25 -- constant, defined in fontString - withDS ds $ - CM.rect ((-0.5) * width) ((-0.5) * height) width height - CM.isPointInPath (0, 0) - } - -logoDrawer ds = - DrawMethods - { drawShape = - withDS ds $ do - CM.scale 1 (-1) - drawCodeWorldLogo ds (-221) (-91) 442 182 - , shapeContains = - withDS ds $ do - CM.rect (-221) (-91) 442 182 - CM.isPointInPath (0, 0) - } - -coordinatePlaneDrawer ds = - DrawMethods - { drawShape = drawDrawing ds coordinatePlaneDrawing - , shapeContains = fst <$> findTopShape ds coordinatePlaneDrawing - } - -followPath :: [Point] -> Bool -> Bool -> CanvasM () -followPath [] closed _ = return () -followPath [p1] closed _ = return () -followPath ((sx, sy):ps) closed False = do - CM.moveTo (25 * sx, 25 * sy) - forM_ ps $ \(x, y) -> CM.lineTo (25 * x, 25 * y) - when closed $ CM.closePath -followPath [p1, p2] False True = followPath [p1, p2] False False -followPath ps False True = do - let [(x1, y1), (x2, y2), (x3, y3)] = take 3 ps - dprev = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) - dnext = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2) - p = dprev / (dprev + dnext) - cx = x2 + p * (x1 - x3) / 2 - cy = y2 + p * (y1 - y3) / 2 - CM.moveTo (25 * x1, 25 * y1) - CM.quadraticCurveTo (25 * cx, 25 * cy) (25 * x2, 25 * y2) - forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) -> do - let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) - d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2) - d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2) - p = d1 / (d1 + d2) - r = d1 / (dp + d1) - cx1 = x2 + r * (x3 - x1) / 2 - cy1 = y2 + r * (y3 - y1) / 2 - cx2 = x3 + p * (x2 - x4) / 2 - cy2 = y3 + p * (y2 - y4) / 2 - CM.bezierCurveTo - (25 * cx1, 25 * cy1) - (25 * cx2, 25 * cy2) - (25 * x3, 25 * y3) - let [(x1, y1), (x2, y2), (x3, y3)] = reverse $ take 3 $ reverse ps - dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) - d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2) - r = d1 / (dp + d1) - cx = x2 + r * (x3 - x1) / 2 - cy = y2 + r * (y3 - y1) / 2 - CM.quadraticCurveTo (25 * cx, 25 * cy) (25 * x3, 25 * y3) -followPath ps@(_:(sx, sy):_) True True = do - CM.moveTo (25 * sx, 25 * sy) - let rep = cycle ps - forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) -> do - let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) - d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2) - d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2) - p = d1 / (d1 + d2) - r = d1 / (dp + d1) - cx1 = x2 + r * (x3 - x1) / 2 - cy1 = y2 + r * (y3 - y1) / 2 - cx2 = x3 + p * (x2 - x4) / 2 - cy2 = y3 + p * (y2 - y4) / 2 - CM.bezierCurveTo - (25 * cx1, 25 * cy1) - (25 * cx2, 25 * cy2) - (25 * x3, 25 * y3) - CM.closePath - -drawFigure :: DrawState -> Double -> CanvasM () -> CanvasM () -drawFigure ds w figure = do - withDS ds $ do - figure - when (w /= 0) $ do - CM.lineWidth (25 * w) - applyColor ds - CM.stroke - when (w == 0) $ do - CM.lineWidth 1 - applyColor ds - CM.stroke - -fontString :: TextStyle -> Font -> Text -fontString style font = stylePrefix style <> "25px " <> fontName font - where - stylePrefix Plain = "" - stylePrefix Bold = "bold " - stylePrefix Italic = "italic " - fontName SansSerif = "sans-serif" - fontName Serif = "serif" - fontName Monospace = "monospace" - fontName Handwriting = "cursive" - fontName Fancy = "fantasy" - fontName (NamedFont txt) = "\"" <> T.filter (/= '"') txt <> "\"" - -drawDrawing :: DrawState -> Drawing -> CanvasM () -drawDrawing ds (Shape shape) = drawShape $ shape ds -drawDrawing ds (Transformation f d) = drawDrawing (f ds) d -drawDrawing ds (Drawings drs) = mapM_ (drawDrawing ds) (reverse drs) - -findTopShape :: DrawState -> Drawing -> CanvasM (Bool, Int) -findTopShape ds (Shape drawer) = do - contained <- shapeContains $ drawer ds - case contained of - True -> return (True, 0) - False -> return (False, 1) -findTopShape ds (Transformation f d) = - fmap (+ 1) <$> findTopShape (f ds) d -findTopShape ds (Drawings []) = return (False, 1) -findTopShape ds (Drawings (dr:drs)) = do - (found, count) <- findTopShape ds dr - case found of - True -> return (True, count + 1) - False -> fmap (+ count) <$> findTopShape ds (Drawings drs) - -#ifdef ghcjs_HOST_OS - --------------------------------------------------------------------------------- --- GHCJS implementation of drawing - --- Debug Mode logic -inspect :: - IO Picture -> (Bool -> IO ()) -> (Bool -> Maybe NodeId -> IO ()) -> IO () -inspect getPic handleActive highlight = - initDebugMode (handlePointRequest getPic) handleActive getPic highlight - -handlePointRequest :: IO Picture -> Point -> IO (Maybe NodeId) -handlePointRequest getPic pt = do - drawing <- pictureToDrawing <$> getPic - findTopShapeFromPoint pt drawing - -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 - -foreign import javascript unsafe "showCanvas()" - showCanvas :: IO () - -canvasFromElement :: Element -> Canvas.Canvas -canvasFromElement = Canvas.Canvas . unElement - -elementFromCanvas :: Canvas.Canvas -> Element -elementFromCanvas = pFromJSVal . jsval - -getTime :: IO Double -getTime = (/ 1000) <$> js_getHighResTimestamp - -foreign import javascript unsafe "performance.now()" - js_getHighResTimestamp :: IO Double - -nextFrame :: IO Double -nextFrame = waitForAnimationFrame >> getTime - -drawCodeWorldLogo :: - DrawState -> Int -> Int -> Int -> Int -> CanvasM () -drawCodeWorldLogo ds x y w h = do - Just doc <- liftIO $ currentDocument - Just canvas <- liftIO $ getElementById doc ("cwlogo" :: JSString) - case getColorDS ds of - Nothing -> CM.drawImage (canvasFromElement canvas) x y w h - Just (RGBA r g b a) - -- This is a tough case. The best we can do is to allocate an - -- offscreen buffer as a temporary. - -> do - (img, _) <- CM.newImage w h $ do - applyColor ds - CM.fillRect 0 0 (fromIntegral w) (fromIntegral h) - CM.globalCompositeOperation "destination-in" - CM.drawImage (canvasFromElement canvas) 0 0 w h - CM.drawImage img x y w h - -initDebugMode :: - (Point -> IO (Maybe NodeId)) - -> (Bool -> IO ()) - -> IO Picture - -> (Bool -> Maybe NodeId -> IO ()) - -> IO () -initDebugMode getnode setactive getpicture highlight = do - getnodeCB <- - syncCallback1' $ \pointJS -> do - let obj = unsafeCoerce pointJS - x <- pFromJSVal <$> getProp "x" obj - y <- pFromJSVal <$> getProp "y" obj - pToJSVal . fromMaybe (-1) <$> getnode (x, y) - setactiveCB <- syncCallback1 ContinueAsync $ setactive . pFromJSVal - getpictureCB <- syncCallback' $ getpicture >>= picToObj - highlightCB <- - syncCallback2 ContinueAsync $ \t n -> - let select = pFromJSVal t - node = - case ((pFromJSVal n) :: Int) < 0 of - True -> Nothing - False -> Just $ pFromJSVal n - in highlight select node - drawCB <- - syncCallback2 ContinueAsync $ \c n -> do - let canvas = unsafeCoerce c :: Element - nodeId = pFromJSVal n - drawing <- pictureToDrawing <$> getpicture - let node = fromMaybe (Drawings []) $ fst <$> getDrawNode nodeId drawing - offscreenCanvas <- Canvas.create 500 500 - setCanvasSize canvas canvas - setCanvasSize (elementFromCanvas offscreenCanvas) canvas - screen <- getCodeWorldContext (canvasFromElement canvas) - rect <- getBoundingClientRect canvas - withScreen (elementFromCanvas offscreenCanvas) rect $ - drawFrame (node <> coordinatePlaneDrawing) - rect <- getBoundingClientRect canvas - cw <- ClientRect.getWidth rect - ch <- ClientRect.getHeight rect - canvasDrawImage - screen - (elementFromCanvas offscreenCanvas) - 0 - 0 - (round cw) - (round ch) - js_initDebugMode getnodeCB setactiveCB getpictureCB highlightCB drawCB - -foreign import javascript unsafe "initDebugMode($1,$2,$3,$4,$5)" - js_initDebugMode :: Callback (JSVal -> IO JSVal) - -> Callback (JSVal -> IO ()) - -> Callback (IO JSVal) - -> Callback (JSVal -> JSVal -> IO ()) - -> Callback (JSVal -> JSVal -> IO ()) - -> IO () - -picToObj :: Picture -> IO JSVal -picToObj = fmap fst . flip State.runStateT 0 . picToObj' - -picToObj' :: Picture -> State.StateT Int IO JSVal -picToObj' pic = objToJSVal <$> case pic of - Pictures _ ps -> mkNodeWithChildren ps - PictureAnd _ ps -> mkNodeWithChildren ps - Color _ _ p -> mkNodeWithChild p - Translate _ _ _ p -> mkNodeWithChild p - Scale _ _ _ p -> mkNodeWithChild p - Dilate _ _ p -> mkNodeWithChild p - Rotate _ _ p -> mkNodeWithChild p - _ -> mkSimpleNode - where - mkSimpleNode :: State.StateT Int IO Object - mkSimpleNode = do - obj <- liftIO create - id <- do - currentId <- State.get - State.put (currentId + 1) - return currentId - liftIO $ do - setProp "id" (pToJSVal id) obj - setProp "name" (pToJSVal $ (trim 80 . describePicture) pic) obj - case getPictureSrcLoc pic of - Just loc -> do - setProp "startLine" (pToJSVal $ srcLocStartLine loc) obj - setProp "startCol" (pToJSVal $ srcLocStartCol loc) obj - setProp "endLine" (pToJSVal $ srcLocEndLine loc) obj - setProp "endCol" (pToJSVal $ srcLocEndCol loc) obj - Nothing -> return () - return obj - - mkNodeWithChild :: Picture -> State.StateT Int IO Object - mkNodeWithChild p = do - obj <- mkSimpleNode - subPic <- picToObj' p - liftIO $ setProp "picture" subPic obj - return obj - - mkNodeWithChildren :: [Picture] -> State.StateT Int IO Object - mkNodeWithChildren ps = do - obj <- mkSimpleNode - arr <- liftIO $ Array.create - mapM_ (\p -> picToObj' p >>= liftIO . flip Array.push arr) ps - liftIO $ setProp "pictures" (unsafeCoerce arr) obj - return obj - - objToJSVal = unsafeCoerce :: Object -> JSVal - -trim :: Int -> String -> String -trim x y = let mid = (x - 2) `div` 2 - in case x >= (length y) of - True -> y :: String - False -> take mid y ++ ".." ++ (reverse $ take mid $ reverse y) - -foreign import javascript unsafe "/\\bmode=haskell\\b/.test(location.search)" - haskellMode :: Bool - -showFloat :: Double -> String -showFloat x - | haskellMode && x < 0 = "(" ++ result ++ ")" - | otherwise = result - where result = stripZeros (showFFloatAlt (Just 4) x "") - stripZeros = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse - -showPoints :: [Point] -> String -showPoints pts = - "[" ++ - intercalate ", " [ - "(" ++ showFloat x ++ ", " ++ showFloat y ++ ")" - | (x, y) <- pts - ] ++ - "]" - -showColor :: Color -> String -showColor c@(RGBA r g b a) - | c == black = "black" - | c == white = "white" - | c == red = "red" - | c == green = "green" - | c == blue = "blue" - | c == yellow = "yellow" - | c == orange = "orange" - | c == brown = "brown" - | c == pink = "pink" - | c == purple = "purple" - | c == gray = "gray" - | haskellMode, a == 1 = printf "(RGB %s %s %s)" (showFloat r) (showFloat g) (showFloat b) - | a == 1 = printf "RGB(%s, %s, %s)" (showFloat r) (showFloat g) (showFloat b) - | haskellMode = printf "(RGBA %s %s %s %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a) - | otherwise = printf "RGBA(%s, %s, %s, %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a) - -describePicture :: Picture -> String -describePicture (Rectangle _ w h) - | haskellMode = printf "rectangle %s %s" (showFloat w) (showFloat h) - | otherwise = printf "rectangle(%s, %s)" (showFloat w) (showFloat h) -describePicture (SolidRectangle _ w h) - | haskellMode = printf "solidRectangle %s %s" (showFloat w) (showFloat h) - | otherwise = printf "solidRectangle(%s, %s)" (showFloat w) (showFloat h) -describePicture (ThickRectangle _ lw w h) - | haskellMode = printf "thickRectangle %s %s %s" (showFloat lw) (showFloat w) (showFloat h) - | otherwise = printf "thickRectangle(%s, %s, %s)" (showFloat w) (showFloat h) (showFloat lw) -describePicture (Circle _ r) - | haskellMode = printf "circle %s" (showFloat r) - | otherwise = printf "circle(%s)" (showFloat r) -describePicture (SolidCircle _ r) - | haskellMode = printf "solidCircle %s" (showFloat r) - | otherwise = printf "solidCircle(%s)" (showFloat r) -describePicture (ThickCircle _ lw r) - | haskellMode = printf "thickCircle %s %s" (showFloat lw) (showFloat r) - | otherwise = printf "thickCircle(%s, %s)" (showFloat r) (showFloat lw) -describePicture (SolidPolygon _ pts) - | haskellMode = printf "solidPolygon %s" (showPoints pts) - | otherwise = printf "solidPolygon(%s)" (showPoints pts) -describePicture (SolidClosedCurve _ pts) - | haskellMode = printf "solidClosedCurve %s" (showPoints pts) - | otherwise = printf "solidClosedCurve(%s)" (showPoints pts) -describePicture (Polygon _ pts) - | haskellMode = printf "polygon %s" (showPoints pts) - | otherwise = printf "polygon(%s)" (showPoints pts) -describePicture (ThickPolygon _ pts w) - | haskellMode = printf "thickPolygon %s %s" (showFloat w) (showPoints pts) - | otherwise = printf "thickPolygon(%s, %s)" (showPoints pts) (showFloat w) -describePicture (ClosedCurve _ pts) - | haskellMode = printf "closedCurve %s" (showPoints pts) - | otherwise = printf "closedCurve(%s)" (showPoints pts) -describePicture (ThickClosedCurve _ pts w) - | haskellMode = printf "thickClosedCurve %s %s" (showFloat w) (showPoints pts) - | otherwise = printf "thickClosedCurve(%s, %s)" (showPoints pts) (showFloat w) -describePicture (Polyline _ pts) - | haskellMode = printf "polyline %s" (showPoints pts) - | otherwise = printf "polyline(%s)" (showPoints pts) -describePicture (ThickPolyline _ pts w) - | haskellMode = printf "thickPolyline %s %s" (showFloat w) (showPoints pts) - | otherwise = printf "thickPolyline(%s, %s)" (showPoints pts) (showFloat w) -describePicture (Curve _ pts) - | haskellMode = printf "curve %s" (showPoints pts) - | otherwise = printf "curve(%s)" (showPoints pts) -describePicture (ThickCurve _ pts w) - | haskellMode = printf "thickCurve %s %s" (showFloat w) (showPoints pts) - | otherwise = printf "thickCurve(%s, %s)" (showPoints pts) (showFloat w) -describePicture (Sector _ b e r) - | haskellMode = printf "sector %s %s %s" (showFloat b) (showFloat e) (showFloat r) - | otherwise = printf "sector(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r) -describePicture (Arc _ b e r) - | haskellMode = printf "arc %s %s %s" (showFloat b) (showFloat e) (showFloat r) - | otherwise = printf "arc(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r) -describePicture (ThickArc _ b e r w) - | haskellMode = printf "thickArc %s %s %s %s" (showFloat w) (showFloat b) (showFloat e) (showFloat r) - | otherwise = printf "thickArc(%s°, %s°, %s, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r) (showFloat w) -describePicture (Lettering _ txt) - | haskellMode = printf "lettering %s" (show txt) - | otherwise = printf "lettering(%s)" (show txt) -describePicture (Blank _) = "blank" -describePicture (StyledLettering _ style font txt) - | haskellMode = printf "styledLettering %s %s %s" (showsPrec 10 style "") (showsPrec 10 font "") (show txt) - | otherwise = printf "styledLettering(%s, %s, %s)" (show txt) (show font) (show style) -describePicture (Color _ c _) - | haskellMode = printf "colored %s" (showColor c) - | otherwise = printf "colored(..., %s)" (showColor c) -describePicture (Translate _ x y _) - | haskellMode = printf "translated %s %s" (showFloat x) (showFloat y) - | otherwise = printf "translated(..., %s, %s)" (showFloat x) (showFloat y) -describePicture (Scale _ x y _) - | haskellMode = printf "scaled %s %s" (showFloat x) (showFloat y) - | otherwise = printf "scaled(..., %s, %s)" (showFloat x) (showFloat y) -describePicture (Rotate _ angle _) - | haskellMode = printf "rotated %s" (showFloat angle) - | otherwise = printf "rotated(..., %s°)" (showFloat (180 * angle / pi)) -describePicture (Dilate _ k _) - | haskellMode = printf "dilated %s" (showFloat k) - | otherwise = printf "dilated(..., %s)" (showFloat k) -describePicture (Logo _) = "codeWorldLogo" -describePicture (CoordinatePlane _) = "coordinatePlane" -describePicture (Pictures _ _) - | haskellMode = "pictures" - | otherwise = "pictures(...)" -describePicture (PictureAnd _ _) - | haskellMode = "(&)" - | otherwise = "... & ..." - -getPictureSrcLoc :: Picture -> Maybe SrcLoc -getPictureSrcLoc (SolidPolygon loc _) = loc -getPictureSrcLoc (SolidClosedCurve loc _) = loc -getPictureSrcLoc (Polygon loc _) = loc -getPictureSrcLoc (ThickPolygon loc _ _) = loc -getPictureSrcLoc (Rectangle loc _ _) = loc -getPictureSrcLoc (SolidRectangle loc _ _) = loc -getPictureSrcLoc (ThickRectangle loc _ _ _) = loc -getPictureSrcLoc (ClosedCurve loc _) = loc -getPictureSrcLoc (ThickClosedCurve loc _ _) = loc -getPictureSrcLoc (Circle loc _) = loc -getPictureSrcLoc (SolidCircle loc _) = loc -getPictureSrcLoc (ThickCircle loc _ _) = loc -getPictureSrcLoc (Polyline loc _) = loc -getPictureSrcLoc (ThickPolyline loc _ _) = loc -getPictureSrcLoc (Curve loc _) = loc -getPictureSrcLoc (ThickCurve loc _ _) = loc -getPictureSrcLoc (Sector loc _ _ _) = loc -getPictureSrcLoc (Arc loc _ _ _) = loc -getPictureSrcLoc (ThickArc loc _ _ _ _) = loc -getPictureSrcLoc (Lettering loc _) = loc -getPictureSrcLoc (Blank loc) = loc -getPictureSrcLoc (StyledLettering loc _ _ _) = loc -getPictureSrcLoc (Color loc _ _) = loc -getPictureSrcLoc (Translate loc _ _ _) = loc -getPictureSrcLoc (Scale loc _ _ _) = loc -getPictureSrcLoc (Dilate loc _ _) = loc -getPictureSrcLoc (Rotate loc _ _) = loc -getPictureSrcLoc (Logo loc) = loc -getPictureSrcLoc (CoordinatePlane loc) = loc -getPictureSrcLoc (Pictures loc _) = loc -getPictureSrcLoc (PictureAnd loc _) = loc - --- If a picture is found, the result will include an array of the base picture --- and all transformations. -findTopShapeFromPoint :: Point -> Drawing -> IO (Maybe NodeId) -findTopShapeFromPoint (x, y) pic = do - buf <- Canvas.create 500 500 - ctx <- Canvas.getContext buf - (found, node) <- runCanvasM ctx $ - findTopShape (translateDS (10 - x / 25) (y / 25 - 10) initialDS) - pic - case found of - True -> return $ Just node - False -> return Nothing - -drawFrame :: Drawing -> CanvasM () -drawFrame drawing = do - CM.fillColor 255 255 255 1 - CM.fillRect (-250) (-250) 500 500 - drawDrawing initialDS drawing - -withScreen :: Element -> ClientRect.ClientRect -> CanvasM a -> IO a -withScreen canvas rect action = do - cw <- ClientRect.getWidth rect - ch <- ClientRect.getHeight rect - ctx <- getCodeWorldContext (canvasFromElement canvas) - runCanvasM ctx $ CM.saveRestore $ do - CM.translate (realToFrac cw / 2) (realToFrac ch / 2) - CM.scale (realToFrac cw / 500) (-realToFrac ch / 500) - CM.lineWidth 0 - CM.textCenter - CM.textMiddle - action - -setCanvasSize :: Element -> Element -> IO () -setCanvasSize target canvas = do - rect <- getBoundingClientRect canvas - cx <- ClientRect.getWidth rect - cy <- ClientRect.getHeight rect - setAttribute target ("width" :: JSString) (show (round cx)) - setAttribute target ("height" :: JSString) (show (round cy)) - -#else - --------------------------------------------------------------------------------- --- Stand-alone implementation of drawing - -drawCodeWorldLogo :: - DrawState -> Int -> Int -> Int -> Int -> CanvasM () -drawCodeWorldLogo ds x y w h = return () - -setupScreenContext :: (Int, Int) -> Canvas () -setupScreenContext (cw, ch) - -- blank before transformation (canvas might be non-sqare) - = do - Canvas.fillStyle "white" - Canvas.fillRect (0, 0, fromIntegral cw, fromIntegral ch) - Canvas.translate (realToFrac cw / 2, realToFrac ch / 2) - let s = min (realToFrac cw / 500) (realToFrac ch / 500) - Canvas.scale (s, -s) - Canvas.lineWidth 0 - Canvas.textAlign Canvas.CenterAnchor - Canvas.textBaseline Canvas.MiddleBaseline - -type Port = Int - -readPortFromEnv :: String -> Port -> IO Port -readPortFromEnv envName defaultPort = do - ms <- lookupEnv envName - return (fromMaybe defaultPort (ms >>= readMaybe)) - -runBlankCanvas :: (Canvas.DeviceContext -> IO ()) -> IO () -runBlankCanvas act = do - port <- readPortFromEnv "CODEWORLD_API_PORT" 3000 - let options = - (fromIntegral port) - { Canvas.events = - ["mousedown", "mouseup", "mousemove", "keydown", "keyup"] - } - putStrLn $ printf "Open me on http://127.0.0.1:%d/" (Canvas.port options) - Canvas.blankCanvas options $ \context -> do - putStrLn "Program is starting..." - act context - -#endif - --------------------------------------------------------------------------------- --- Common event handling and core interaction code - -keyCodeToText :: Word -> Text -keyCodeToText n = - case n of - _ - | n >= 47 && n <= 90 -> fromAscii n - _ - | n >= 96 && n <= 105 -> fromNum (n - 96) - _ - | n >= 112 && n <= 135 -> "F" <> fromNum (n - 111) - 3 -> "Cancel" - 6 -> "Help" - 8 -> "Backspace" - 9 -> "Tab" - 12 -> "5" - 13 -> "Enter" - 16 -> "Shift" - 17 -> "Ctrl" - 18 -> "Alt" - 19 -> "Break" - 20 -> "CapsLock" - 27 -> "Esc" - 32 -> " " - 33 -> "PageUp" - 34 -> "PageDown" - 35 -> "End" - 36 -> "Home" - 37 -> "Left" - 38 -> "Up" - 39 -> "Right" - 40 -> "Down" - 42 -> "*" - 43 -> "+" - 44 -> "PrintScreen" - 45 -> "Insert" - 46 -> "Delete" - 47 -> "Help" - 91 -> "OS" - 92 -> "OS" - 93 -> "ContextMenu" - 106 -> "*" - 107 -> "+" - 108 -> "," - 109 -> "-" - 110 -> "." - 111 -> "/" - 144 -> "NumLock" - 145 -> "ScrollLock" - 173 -> "-" - 186 -> ";" - 187 -> "=" - 188 -> "," - 189 -> "-" - 190 -> "." - 191 -> "/" - 192 -> "`" - 193 -> "IntlRo" - 194 -> "," - 219 -> "[" - 220 -> "\\" - 221 -> "]" - 222 -> "'" - 225 -> "AltGraph" - 255 -> "IntlYen" - _ -> "Unknown:" <> fromNum n - where - fromAscii n = singleton (chr (fromIntegral n)) - fromNum n = pack (show (fromIntegral n)) - -isUniversallyConstant :: (a -> s -> s) -> s -> Bool -isUniversallyConstant f old = - unsafePerformIO $ falseOr $ do - oldName <- makeStableName $! old - genName <- makeStableName $! f undefined old - return (genName == oldName) - where - falseOr x = x `catch` \(e :: SomeException) -> return False - -ifDifferent :: (s -> s) -> s -> Maybe s -ifDifferent f s0 = unsafePerformIO $ do - oldName <- makeStableName $! s0 - newName <- makeStableName $! s1 - if newName == oldName then return Nothing else return (Just s1) - where s1 = f s0 - -modifyMVarIfDifferent :: MVar s -> (s -> s) -> IO Bool -modifyMVarIfDifferent var f = - modifyMVar var $ \s0 -> do - case ifDifferent f s0 of - Nothing -> return (s0, False) - Just s1 -> return (s1, True) - -data GameToken - = FullToken { tokenDeployHash :: Text - , tokenNumPlayers :: Int - , tokenInitial :: StaticKey - , tokenStep :: StaticKey - , tokenEvent :: StaticKey - , tokenDraw :: StaticKey } - | SteplessToken { tokenDeployHash :: Text - , tokenNumPlayers :: Int - , tokenInitial :: StaticKey - , tokenEvent :: StaticKey - , tokenDraw :: StaticKey } - | PartialToken { tokenDeployHash :: Text } - | NoToken - deriving (Generic) - -deriving instance Generic Fingerprint - -instance Serialize Fingerprint - -instance Serialize GameToken - -#ifdef ghcjs_HOST_OS - --------------------------------------------------------------------------------- --- GHCJS event handling and core interaction code - -getMousePos :: IsMouseEvent e => Element -> EventM w e Point -getMousePos canvas = do - (ix, iy) <- mouseClientXY - liftIO $ do - rect <- getBoundingClientRect canvas - cx <- ClientRect.getLeft rect - cy <- ClientRect.getTop rect - cw <- ClientRect.getWidth rect - ch <- ClientRect.getHeight rect - return - ( 20 * fromIntegral (ix - round cx) / realToFrac cw - 10 - , 20 * fromIntegral (round cy - iy) / realToFrac cw + 10) - -onEvents :: Element -> (Event -> IO ()) -> IO () -onEvents canvas handler = do - Just window <- currentWindow - on window keyDown $ do - code <- uiKeyCode - let keyName = keyCodeToText code - when (keyName /= "") $ do - liftIO $ handler (KeyPress keyName) - preventDefault - stopPropagation - on window keyUp $ do - code <- uiKeyCode - 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) - -isRunning :: GameState s -> Bool -isRunning Running {} = True -isRunning _ = False - -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 _) -> - return - (Running - ws - gid - t - pid - (initFuture (initial (mkStdGen (hash gid))) numPlayers)) - (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 s1 -> 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 - encodeClientMessage :: ClientMessage -> JSString - encodeClientMessage m = Data.JSString.pack (show m) - -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) - showCanvas - Just window <- currentWindow - Just doc <- currentDocument - Just canvas <- getElementById doc ("screen" :: JSString) - 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 - currentGameState <- newMVar initialGameState - onEvents canvas $ - gameHandle - numPlayers - initial - fullStepHandler - eventHandler - token - currentGameState - screen <- getCodeWorldContext (canvasFromElement canvas) - let go t0 lastFrame = do - gs <- readMVar currentGameState - let pic = gameDraw fullStepHandler drawHandler gs t0 - picFrame <- makeStableName $! pic - when (picFrame /= lastFrame) $ do - rect <- getBoundingClientRect canvas - withScreen (elementFromCanvas offscreenCanvas) rect $ - drawFrame (pictureToDrawing pic) - rect <- getBoundingClientRect canvas - cw <- ClientRect.getWidth rect - ch <- ClientRect.getHeight rect - when (cw > 0 && ch > 0) $ canvasDrawImage - screen - (elementFromCanvas offscreenCanvas) - 0 - 0 - (round cw) - (round ch) - t1 <- nextFrame - modifyMVar_ currentGameState $ return . gameStep fullStepHandler t1 - go t1 picFrame - t0 <- getTime - nullFrame <- makeStableName undefined - initialStateName <- makeStableName $! initialGameState - go t0 nullFrame - -getDeployHash :: IO Text -getDeployHash = pFromJSVal <$> js_getDeployHash - -foreign import javascript "/[&?]dhash=(.{22})/.exec(window.location.search)[1]" - js_getDeployHash :: IO JSVal - -foreign import javascript "console.log($1);" - js_debugLog :: JSString -> IO () - -debugLog :: String -> IO () -debugLog = js_debugLog . Data.JSString.pack - -propagateErrors :: ThreadId -> IO () -> IO () -propagateErrors tid action = action `catch` \ (e :: SomeException) -> throwTo tid e - -run :: s - -> (Double -> s -> s) - -> (e -> s -> s) - -> (s -> Drawing) - -> (Double -> e) - -> IO (e -> IO (), IO s) -run initial stepHandler eventHandler drawHandler injectTime = do - let fullStepHandler dt = stepHandler dt . eventHandler (injectTime dt) - showCanvas - Just window <- currentWindow - Just doc <- currentDocument - Just canvas <- getElementById doc ("screen" :: JSString) - offscreenCanvas <- Canvas.create 500 500 - setCanvasSize canvas canvas - 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 () - screen <- getCodeWorldContext (canvasFromElement canvas) - let go t0 lastFrame lastStateName needsTime = do - pic <- drawHandler <$> readMVar currentState - picFrame <- makeStableName $! pic - when (picFrame /= lastFrame) $ do - rect <- getBoundingClientRect canvas - withScreen (elementFromCanvas offscreenCanvas) rect $ - drawFrame pic - rect <- getBoundingClientRect canvas - cw <- ClientRect.getWidth rect - ch <- ClientRect.getHeight rect - when (cw > 0 && ch > 0) $ canvasDrawImage - screen - (elementFromCanvas offscreenCanvas) - 0 - 0 - (round cw) - (round ch) - t1 <- - if | needsTime -> - do t1 <- nextFrame - let dt = min (t1 - t0) 0.25 - modifyMVarIfDifferent currentState (fullStepHandler dt) - return t1 - | otherwise -> - do takeMVar eventHappened - getTime - nextState <- readMVar currentState - nextStateName <- makeStableName $! nextState - let nextNeedsTime = - nextStateName /= lastStateName || - needsTime && not (isUniversallyConstant fullStepHandler nextState) - nextFrame <- tryTakeMVar needsRedraw >>= \case - Nothing -> return picFrame - Just () -> makeStableName undefined - go t1 nextFrame nextStateName nextNeedsTime - t0 <- getTime - 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) - -data DebugState = DebugState - { debugStateActive :: Bool - , shapeHighlighted :: Maybe NodeId - , shapeSelected :: Maybe NodeId - } - -data DebugEvent - = DebugStart - | DebugStop - | HighlightEvent (Maybe NodeId) - | SelectEvent (Maybe NodeId) - -debugStateInit :: DebugState -debugStateInit = DebugState False Nothing Nothing - -updateDebugState :: DebugEvent -> DebugState -> DebugState -updateDebugState DebugStart prev = DebugState True Nothing Nothing -updateDebugState DebugStop prev = DebugState False Nothing Nothing -updateDebugState (HighlightEvent n) prev = - case debugStateActive prev of - True -> prev {shapeHighlighted = n} - False -> DebugState False Nothing Nothing -updateDebugState (SelectEvent n) prev = - case debugStateActive prev of - True -> prev {shapeSelected = n} - False -> DebugState False Nothing Nothing - -drawDebugState :: DebugState -> Drawing -> Drawing -drawDebugState state drawing = - case debugStateActive state of - True -> - highlightSelectShape - (shapeHighlighted state) - (shapeSelected state) - drawing - False -> drawing - --- 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 :: - (Wrapped s -> [Control s]) - -> s - -> (Double -> s -> s) - -> (Event -> s -> s) - -> (s -> Picture) - -> IO () -runInspect controls initial stepHandler eventHandler drawHandler = do - Just window <- currentWindow - Just doc <- currentDocument - Just canvas <- getElementById doc ("screen" :: JSString) - let initialWrapper = (debugStateInit, wrappedInitial initial) - stepHandlerWrapper dt wrapper@(debugState, _) = - case debugStateActive debugState of - 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 $ pictureToDrawing $ drawHandler (state wrappedState) - False -> pictureToDrawing (wrappedDraw controls drawHandler wrappedState) - drawPicHandler (debugState, wrappedState) = - drawHandler $ state wrappedState - (sendEvent, getState) <- - run - initialWrapper - stepHandlerWrapper - (\e w -> (eventHandlerWrapper e) w) - 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 - waitForever - --- Given a drawing, highlight the first node and select second node. Both recolor --- the nodes, but highlight also brings the node to the top. -highlightSelectShape :: Maybe NodeId -> Maybe NodeId -> Drawing -> Drawing -highlightSelectShape h s drawing - | isNothing s = - fromMaybe drawing $ do - h' <- h - hp <- piece h' - return $ hp <> drawing - | isNothing h = - fromMaybe drawing $ do - s' <- s - sp <- piece s' - replaceDrawNode s' sp drawing - | otherwise = - fromMaybe drawing $ do - h' <- h - s' <- s - hp <- piece h' - sp <- piece s' - replaced <- replaceDrawNode s' sp drawing - return $ hp <> replaced - where - piece n = - (\(node, ds) -> highlightDrawing ds node) <$> getDrawNode n drawing - -highlightDrawing :: DrawState -> Drawing -> Drawing -highlightDrawing (a, b, c, d, e, f, _) drawing = - Transformation (\_ -> (a, b, c, d, e, f, Just col')) drawing - where - col' = RGBA 0 0 0 0.25 - -getDrawNode :: NodeId -> Drawing -> Maybe (Drawing, DrawState) -getDrawNode n _ - | n < 0 = Nothing -getDrawNode n drawing = either Just (const Nothing) $ go initialDS n drawing - where - go ds 0 d = Left (d, ds) - go ds n (Shape _) = Right (n - 1) - go ds n (Transformation f dr) = go (f ds) (n - 1) dr - go ds n (Drawings []) = Right (n - 1) - go ds n (Drawings (dr:drs)) = - case go ds (n - 1) dr of - Left d -> Left d - Right n -> go ds (n + 1) $ Drawings drs - -replaceDrawNode :: NodeId -> Drawing -> Drawing -> Maybe Drawing -replaceDrawNode n _ _ - | n < 0 = Nothing -replaceDrawNode n with drawing = either Just (const Nothing) $ go n drawing - where - go :: Int -> Drawing -> Either Drawing Int - go 0 _ = Left with - go n (Shape _) = Right (n - 1) - go n (Transformation f d) = mapLeft (Transformation f) $ go (n - 1) d - go n (Drawings []) = Right (n - 1) - go n (Drawings (dr:drs)) = - case go (n - 1) dr of - Left d -> Left $ Drawings (d : drs) - Right m -> - mapLeft (\(Drawings qs) -> Drawings (dr : qs)) $ - go (m + 1) $ Drawings drs - mapLeft :: (a -> b) -> Either a c -> Either b c - mapLeft f = either (Left . f) Right - -#else - -debugLog :: String -> IO () -debugLog = putStrLn - --------------------------------------------------------------------------------- --- Stand-Alone event handling and core interaction code - -getMousePos :: (Int, Int) -> (Double, Double) -> (Double, Double) -getMousePos (w, h) (x, y) = - ((x - fromIntegral w / 2) / s, -(y - fromIntegral h / 2) / s) - where - s = min (realToFrac w / 20) (realToFrac h / 20) - -toEvent :: (Int, Int) -> Canvas.Event -> Maybe Event -toEvent rect Canvas.Event {..} - | eType == "keydown" - , Just code <- eWhich = Just $ KeyPress (keyCodeToText (fromIntegral code)) - | eType == "keyup" - , Just code <- eWhich = - Just $ KeyRelease (keyCodeToText (fromIntegral code)) - | eType == "mousedown" - , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerPress pos - | eType == "mouseup" - , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerRelease pos - | eType == "mousemove" - , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerMovement pos - | otherwise = Nothing - -onEvents :: Canvas.DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO () -onEvents context rect handler = - void $ - forkIO $ - forever $ do - maybeEvent <- toEvent rect <$> Canvas.wait context - forM_ maybeEvent handler - -run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO () -run initial stepHandler eventHandler drawHandler = - runBlankCanvas $ \context -> do - let fullStepHandler dt = stepHandler dt . eventHandler (TimePassing dt) - let rect = (Canvas.width context, Canvas.height context) - offscreenCanvas <- Canvas.send context $ Canvas.newCanvas rect - currentState <- newMVar initial - eventHappened <- newMVar () - onEvents context rect $ \event -> do - modifyMVar_ currentState (return . eventHandler event) - tryPutMVar eventHappened () - return () - let go t0 lastFrame lastStateName needsTime = do - pic <- drawHandler <$> readMVar currentState - picFrame <- makeStableName $! pic - when (picFrame /= lastFrame) $ - Canvas.send context $ do - Canvas.with offscreenCanvas $ - Canvas.saveRestore $ do - setupScreenContext rect - drawDrawing initialDS (pictureToDrawing pic) - Canvas.drawImageAt (offscreenCanvas, 0, 0) - t1 <- - if | needsTime -> - do tn <- getCurrentTime - threadDelay $ - max - 0 - (50000 - - round ((tn `diffUTCTime` t0) * 1000000)) - t1 <- getCurrentTime - let dt = realToFrac (t1 `diffUTCTime` t0) - modifyMVar_ currentState (return . fullStepHandler dt) - return t1 - | otherwise -> - do takeMVar eventHappened - getCurrentTime - nextState <- readMVar currentState - nextStateName <- makeStableName $! nextState - let nextNeedsTime = - nextStateName /= lastStateName || - needsTime && not (isUniversallyConstant fullStepHandler nextState) - go t1 picFrame nextStateName nextNeedsTime - t0 <- getCurrentTime - nullFrame <- makeStableName undefined - initialStateName <- makeStableName $! initial - go t0 nullFrame initialStateName True - -runInspect :: - (Wrapped s -> [Control s]) - -> s - -> (Double -> s -> s) - -> (Event -> s -> s) - -> (s -> Picture) - -> IO () -runInspect controls initial stepHandler eventHandler drawHandler = - run (wrappedInitial initial) - (wrappedStep stepHandler) - (wrappedEvent controls stepHandler eventHandler) - (wrappedDraw controls drawHandler) - -getDeployHash :: IO Text -getDeployHash = error "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 = error "game API unimplemented in stand-alone interface mode" - -#endif - --------------------------------------------------------------------------------- --- Common code for game interface - -groupActivityOf numPlayers initial event draw = do - dhash <- getDeployHash - let token = - SteplessToken - { tokenDeployHash = dhash - , tokenNumPlayers = numPlayers - , tokenInitial = staticKey initial - , tokenEvent = staticKey event - , tokenDraw = staticKey draw - } - runGame - token - numPlayers - (deRefStaticPtr initial) - (const id) - (deRefStaticPtr event) - (deRefStaticPtr draw) - -unsafeGroupActivityOf numPlayers initial event draw = - unsafeCollaborationOf numPlayers initial (const id) event draw - -unsafeCollaborationOf numPlayers initial step event draw = do - dhash <- getDeployHash - let token = PartialToken dhash - runGame token numPlayers initial step event draw - where - token = NoToken - -collaborationOf numPlayers initial step event draw = do - dhash <- getDeployHash - let token = - FullToken - { tokenDeployHash = dhash - , tokenNumPlayers = numPlayers - , tokenInitial = staticKey initial - , tokenStep = staticKey step - , tokenEvent = staticKey event - , tokenDraw = staticKey draw - } - runGame - token - numPlayers - (deRefStaticPtr initial) - (deRefStaticPtr step) - (deRefStaticPtr event) - (deRefStaticPtr draw) - --------------------------------------------------------------------------------- --- Common code for activity, interaction, animation and simulation interfaces - -activityOf initial change picture = - interactionOf initial (const id) change picture - -interactionOf = runInspect (const []) - -data Wrapped a = Wrapped - { state :: a - , playbackSpeed :: Double - , lastInteractionTime :: Double - , zoomFactor :: Double - , panCenter :: Point - , panDraggingAnchor :: Maybe Point - , isDraggingSpeed :: Bool - , isDraggingHistory :: Bool - , isDraggingZoom :: Bool - } deriving (Show, Functor) - -data Control :: * -> * where - PlayButton :: Point -> Control a - PauseButton :: Point -> Control a - StepButton :: Point -> Control a - RestartButton :: Point -> Control Double - ZoomInButton :: Point -> Control a - ZoomOutButton :: Point -> Control a - PanningLayer :: Control a - ResetViewButton :: Point -> Control a - FastForwardButton :: Point -> Control a - StartOverButton :: Point -> Control ([a], [a]) - BackButton :: Point -> Control Double - TimeLabel :: Point -> Control Double - SpeedSlider :: Point -> Control a - ZoomSlider :: Point -> Control a - UndoButton :: Point -> Control ([a], [a]) - RedoButton :: Point -> Control ([a], [a]) - HistorySlider :: Point -> Control ([a], [a]) - -wrappedInitial :: a -> Wrapped a -wrappedInitial w = Wrapped { - state = w, - playbackSpeed = 1, - lastInteractionTime = 1000, - zoomFactor = 1, - panCenter = (0,0), - panDraggingAnchor = Nothing, - isDraggingSpeed = False, - isDraggingHistory = False, - isDraggingZoom = False - } - -toState :: (a -> a) -> (Wrapped a -> Wrapped a) -toState f w = case ifDifferent f (state w) of - Just newState -> w { state = newState } - _ -> w - -wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a -wrappedStep f dt w = updateInteractionTime (updateState w) - where updateInteractionTime w - | lastInteractionTime w > 5 = w - | otherwise = w { lastInteractionTime = lastInteractionTime w + dt } - updateState w - | playbackSpeed w == 0 = w - | otherwise = toState (f (dt * playbackSpeed w)) w - -reportDiff :: String -> (a -> a) -> (a -> a) -reportDiff msg f x = unsafePerformIO $ do - a <- makeStableName $! x - b <- makeStableName $! r - when (a /= b) $ debugLog $ msg ++ ": reportDiff found a diff" - return r - where r = f x - -wrappedEvent :: forall a . - (Wrapped a -> [Control a]) - -> (Double -> a -> a) - -> (Event -> a -> a) - -> Event - -> Wrapped a - -> Wrapped a -wrappedEvent _ _ eventHandler (TimePassing dt) w - | playbackSpeed w == 0 = w - | otherwise = toState (eventHandler (TimePassing (dt * playbackSpeed w))) w -wrappedEvent ctrls stepHandler eventHandler event w - | playbackSpeed w == 0 || handled = afterControls {lastInteractionTime = 0} - | otherwise = toState (eventHandler (adaptEvent event)) afterControls {lastInteractionTime = 0} - where - (afterControls, handled) = foldr stepFunction (w, False) (ctrls w) - - stepFunction control (world, True) = (world, True) - stepFunction control (world, False) = handleControl fullStep event control world - - fullStep dt = stepHandler dt . eventHandler (TimePassing dt) - - adaptEvent (PointerMovement p) = PointerMovement (adaptPoint p) - adaptEvent (PointerPress p) = PointerPress (adaptPoint p) - adaptEvent (PointerRelease p) = PointerRelease (adaptPoint p) - adaptEvent other = other - - adaptPoint (x, y) = (x / k - dx, y / k - dy) - - (dx, dy) = panCenter w - k = zoomFactor w - -scaleRange :: (Double, Double) -> (Double, Double) -> Double -> Double -scaleRange (a1, b1) (a2, b2) x = min b2 $ max a2 $ (x - a1) / (b1 - a1) * (b2 - a2) + a2 - -snapSlider :: Double -> [Double] -> Double -> Double -snapSlider eps targets val = foldr snap val targets - where snap t v | abs (t - v) < eps = t - | otherwise = v - -xToPlaybackSpeed :: Double -> Double -xToPlaybackSpeed x = snapSlider 0.2 [1..4] $ scaleRange (-1.4, 1.4) (0, 5) x - -playbackSpeedToX :: Double -> Double -playbackSpeedToX s = scaleRange (0, 5) (-1.4, 1.4) s - -zoomIncrement = 8 ** (1/10) - -yToZoomFactor :: Double -> Double -yToZoomFactor y = zoomIncrement ** (scaleRange (-1.4, 1.4) (-10, 10) y) - -zoomFactorToY :: Double -> Double -zoomFactorToY z = scaleRange (-10, 10) (-1.4, 1.4) (logBase zoomIncrement z) - -handleControl :: - (Double -> a -> a) -> Event -> Control a -> Wrapped a -> (Wrapped a, Bool) -handleControl _ (PointerPress (x, y)) (RestartButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = 0}, True) -handleControl _ (PointerPress (x, y)) (StartOverButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (fmap f w, True) - where - f (past, future) = let x:xs = reverse past in ([x], xs ++ future) -handleControl _ (PointerPress (x, y)) (PlayButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = 1}, True) -handleControl _ (PointerPress (x, y)) (PauseButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = 0}, True) -handleControl _ (PointerPress (x, y)) (FastForwardButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = min 5 $ max 2 $ playbackSpeed w + 1}, True) -handleControl _ (PointerPress (x, y)) (ZoomInButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = min (zoomIncrement ** 10) (zoomFactor w * zoomIncrement)}, True) -handleControl _ (PointerPress (x, y)) (ZoomOutButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = max (zoomIncrement ** (-10)) (zoomFactor w / zoomIncrement)}, True) -handleControl _ (PointerPress (x, y)) (ResetViewButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = 1, panCenter = (0, 0)}, True) -handleControl _ (PointerPress (x,y)) (BackButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = - (w {state = max 0 (state w - 0.1)}, True) -handleControl _ (PointerPress (x,y)) (UndoButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = - (fmap (\(x:xs, ys) -> (xs, x:ys)) w, True) -handleControl _ (PointerPress (x,y)) (RedoButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = - (fmap (\(xs, y:ys) -> (y:xs, ys)) w, True) -handleControl f (PointerPress (x, y)) (StepButton (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = f 0.1 (state w)}, True) -handleControl _ (PointerPress (x, y)) (SpeedSlider (cx, cy)) w - | abs (x - cx) < 1.5 && abs (y - cy) < 0.4 = - (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = True}, True) -handleControl _ (PointerMovement (x, y)) (SpeedSlider (cx, cy)) w - | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx)}, True) -handleControl _ (PointerRelease (x, y)) (SpeedSlider (cx, cy)) w - | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = False}, True) -handleControl _ (PointerPress (x, y)) (ZoomSlider (cx, cy)) w - | abs (x - cx) < 0.4 && abs (y - cy) < 1.5 = - (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = True}, True) -handleControl _ (PointerMovement (x, y)) (ZoomSlider (cx, cy)) w - | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy)}, True) -handleControl _ (PointerRelease (x, y)) (ZoomSlider (cx, cy)) w - | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = False}, True) -handleControl _ (PointerPress (x, y)) (HistorySlider (cx, cy)) w - | abs (x - cx) < 2.5 && abs (y - cy) < 0.4 = - (travelToTime (x - cx) <$> w {isDraggingHistory = True}, True) -handleControl _ (PointerMovement (x, y)) (HistorySlider (cx, cy)) w - | isDraggingHistory w = (travelToTime (x - cx) <$> w, True) -handleControl _ (PointerRelease (x, y)) (HistorySlider (cx, cy)) w - | isDraggingHistory w = (travelToTime (x - cx) <$> w {isDraggingHistory = False}, True) -handleControl _ (PointerPress (x, y)) PanningLayer w = - (w {panDraggingAnchor = Just (x, y)}, True) -handleControl _ (PointerMovement (x, y)) PanningLayer w - | Just (ax, ay) <- panDraggingAnchor w - , (px, py) <- panCenter w - = (w { panCenter = (px + (x - ax) / zoomFactor w, py + (y - ay) / zoomFactor w), - panDraggingAnchor = Just (x, y) - }, True) -handleControl _ (PointerRelease (x, y)) PanningLayer w - | Just (ax, ay) <- panDraggingAnchor w = (w {panDraggingAnchor = Nothing}, True) -handleControl _ _ _ w = (w, False) - -travelToTime :: Double -> ([s],[s]) -> ([s],[s]) -travelToTime t (past, future) - | n == 1 = (past, future) - | otherwise = go past future (n1 - desiredN1) - where n1 = length past - n2 = length future - n = n1 + n2 - desiredN1 = round (scaleRange (-2.4, 2.4) (1, fromIntegral n) t) - go past future diff - | diff > 0 = go (tail past) (head past : future) (diff - 1) - | diff < 0 = go (head future : past) (tail future) (diff + 1) - | otherwise = (past, future) - -wrappedDraw :: - (Wrapped a -> [Control a]) -> (a -> Picture) -> Wrapped a -> Picture -wrappedDraw ctrls f w = drawControlPanel ctrls w <> dilated k (translated dx dy (f (state w))) - where (dx, dy) = panCenter w - k = zoomFactor w - -drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture -drawControlPanel ctrls w - | alpha > 0 = pictures [drawControl w alpha c | c <- ctrls w] - | otherwise = blank - where - alpha - | lastInteractionTime w < 4.5 = 1 - | lastInteractionTime w < 5.0 = 10 - 2 * lastInteractionTime w - | otherwise = 0 - -drawControl :: Wrapped a -> Double -> Control a -> Picture -drawControl _ alpha (RestartButton (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 <> - translated 0.173 (-0.1) (solidRectangle 0.17 0.17)) <> - 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 (StartOverButton (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 <> - translated 0.173 (-0.1) (solidRectangle 0.17 0.17)) <> - 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 (PlayButton (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (solidPolygon [(-0.2, 0.25), (-0.2, -0.25), (0.2, 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 (PauseButton (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (translated (-0.15) 0 (solidRectangle 0.2 0.6) <> - translated 0.15 0 (solidRectangle 0.2 0.6)) <> - 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 (FastForwardButton (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (solidPolygon [(-0.3, 0.25), (-0.3, -0.25), (-0.05, 0)] <> - 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 (ZoomInButton (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (translated (-0.05) (0.05) ( - thickCircle 0.1 0.22 <> - solidRectangle 0.06 0.25 <> - solidRectangle 0.25 0.06 <> - rotated (-pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1)) - )) <> - 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 (ZoomOutButton (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (translated (-0.05) (0.05) ( - thickCircle 0.1 0.22 <> - solidRectangle 0.25 0.06 <> - rotated (-pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1)) - )) <> - 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 _ _ PanningLayer = blank -drawControl _ alpha (ResetViewButton (x,y)) = translated x y p - where - p = - colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.7 0.2) <> - colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.2 0.7) <> - colored (RGBA 0.0 0.0 0.0 alpha) (thickRectangle 0.1 0.5 0.5) <> - 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 (BackButton (x,y)) = translated x y 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 (UndoButton (x,y)) = translated x y 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 (x,y)) = translated x y 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 (RedoButton (x,y)) = translated x y 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 w alpha (TimeLabel (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (scaled 0.5 0.5 $ lettering (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 (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (translated xoff 0.75 $ scaled 0.5 0.5 $ - lettering (pack (showFFloatAlt (Just 2) (playbackSpeed w) "x"))) <> - colored (RGBA 0 0 0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8)) <> - 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) - xoff = playbackSpeedToX (playbackSpeed w) -drawControl w alpha (ZoomSlider (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (translated (-1.1) yoff $ scaled 0.5 0.5 $ - lettering (pack (show (round (zoomFactor w * 100) :: Int) ++ "%"))) <> - colored (RGBA 0 0 0 alpha) (translated 0 yoff (solidRectangle 0.8 0.2)) <> - colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.25 2.8) <> - colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.25 2.8) - yoff = zoomFactorToY (zoomFactor w) -drawControl w alpha (HistorySlider (x,y)) = translated x y p - where - p = - colored - (RGBA 0 0 0 alpha) - (translated xoff 0.75 $ scaled 0.5 0.5 $ - lettering (pack (show n1 ++ "/" ++ show (n1 + n2)))) <> - colored (RGBA 0.0 0.0 0.0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8)) <> - colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 4.8 0.25) <> - colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 4.8 0.25) - xoff | n < 2 = 2.4 - | otherwise = scaleRange (1, fromIntegral n) (-2.4, 2.4) (fromIntegral n1) - n1 = length (fst (state w)) - n2 = length (snd (state w)) - n = n1 + n2 - -drawingControls :: Wrapped () -> [Control ()] -drawingControls w - | lastInteractionTime w > 5 = [] - | otherwise = commonControls ++ resetViewButton - where - commonControls = [ - PanningLayer, - ZoomInButton (9, -4), - ZoomOutButton (9, -8), - ZoomSlider (9, -6) - ] - resetViewButton - | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)] - | otherwise = [] - -drawingOf pic = runInspect drawingControls () (\_ _ -> ()) (\_ _ -> ()) (const pic) - -animationControls :: Wrapped Double -> [Control Double] -animationControls w - | lastInteractionTime w > 5 = [] - | otherwise = commonControls ++ pauseDependentControls ++ - backButton ++ resetViewButton - where - commonControls = [ - PanningLayer, - RestartButton (-9, -9), - TimeLabel (8, -9), - SpeedSlider (-3, -9), - FastForwardButton (-1, -9), - ZoomInButton (9, -4), - ZoomOutButton (9, -8), - ZoomSlider (9, -6) - ] - pauseDependentControls - | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-6, -9)] - | otherwise = [PauseButton (-8, -9)] - backButton - | playbackSpeed w == 0 && state w > 0 = [BackButton (-7, -9)] - | otherwise = [] - resetViewButton - | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)] - | otherwise = [] - -animationOf f = runInspect animationControls 0 (+) (\_ r -> r) f - -simulationControls :: Wrapped w -> [Control w] -simulationControls w - | lastInteractionTime w > 5 = [] - | otherwise = commonControls ++ pauseDependentControls ++ resetViewButton - where - commonControls = [ - PanningLayer, - FastForwardButton (-4, -9), - SpeedSlider (-6, -9), - ZoomInButton (9, -4), - ZoomOutButton (9, -8), - ZoomSlider (9, -6) - ] - pauseDependentControls - | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-2, -9)] - | otherwise = [PauseButton (-8, -9)] - resetViewButton - | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)] - | otherwise = [] - -statefulDebugControls :: Wrapped ([w],[w]) -> [Control ([w],[w])] -statefulDebugControls w - | lastInteractionTime w > 5 = [] - | otherwise = panningLayer ++ pauseDependentControls ++ commonControls ++ - resetViewButton - where - hasHistory = not (null (tail (fst (state w)))) - hasFuture = not (null (snd (state w))) - advance | hasFuture = [RedoButton (6, -9)] - | otherwise = [StepButton (6, -9)] - regress | hasHistory = [UndoButton (0, -9)] - | otherwise = [] - commonControls = [ - StartOverButton (-1, -9), - FastForwardButton (-4, -9), - SpeedSlider (-6, -9), - ZoomInButton (9, -4), - ZoomOutButton (9, -8), - ZoomSlider (9, -6) - ] - pauseDependentControls - | playbackSpeed w == 0 = - [PlayButton (-8, -9), HistorySlider (3, -9)] ++ advance ++ regress - | otherwise = [PauseButton (-8, -9)] - resetViewButton - | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)] - | otherwise = [] - panningLayer - | playbackSpeed w == 0 = [PanningLayer] - | otherwise = [] - -simulationOf initial step draw = - runInspect simulationControls initial step (\_ r -> r) draw - -prependIfChanged :: (a -> a) -> ([a],[a]) -> ([a],[a]) -prependIfChanged f (x:xs, ys) = - case x `seq` x' `seq` (reallyUnsafePtrEquality# x x') of - 0# -> (x' : x : xs, []) - _ -> (x : xs, ys) - where x' = f x - -debugSimulationOf initial simStep simDraw = - runInspect statefulDebugControls ([initial],[]) step (\_ r -> r) draw - where - step dt = prependIfChanged (simStep dt) - draw (x:_, _) = 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:_, _) = baseDraw x - -debugActivityOf initial change picture = - debugInteractionOf initial (const id) change picture - -trace msg x = unsafePerformIO $ do - hPutStrLn stderr (T.unpack msg) - return x +{-# OPTIONS_GHC -Wno-name-shadowing -Wno-orphans -Wno-unticked-promoted-constructors #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- + Copyright 2019 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.IORef +import Data.List (zip4, intercalate) +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 + +#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 qualified GHCJS.DOM.ClientRect as ClientRect +import GHCJS.Concurrent (withoutPreemption) +import GHCJS.DOM +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.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 JavaScript.Web.AnimationFrame +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 (DrawState (AffineTransformation ta tb tc td te tf) _col) action = + CM.saveRestore $ do + CM.transform ta tb tc td te tf + CM.beginPath + action + +setColor :: MonadCanvas m => Color -> m () +setColor (RGBA r g b a) = do + CM.strokeColor + (round $ r * 255) + (round $ g * 255) + (round $ b * 255) + a + CM.fillColor + (round $ r * 255) + (round $ g * 255) + (round $ b * 255) + a + +applyColor :: MonadCanvas m => DrawState -> m () +applyColor ds = case getColorDS ds of + Nothing -> setColor (RGBA 0 0 0 1) + Just c -> setColor 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 (RGBA r g b a) pic = do + w <- CM.getScreenWidth + h <- CM.getScreenHeight + img <- CM.newImage (round w) (round h) + CM.withImage img $ do + setupScreenContext (round w) (round h) + pic (RGBA r g b 1) + CM.saveRestore $ do + px <- pixelSize + CM.scale px (-px) + CM.globalAlpha a + CM.drawImage img (round (-w/2)) (round (-h/2)) (round w) (round h) + +followPath :: MonadCanvas m => [Point] -> Bool -> Bool -> m () +followPath [] _ _ = return () +followPath [_] _ _ = return () +followPath ((sx, sy):ps) closed False = do + CM.moveTo (sx, sy) + forM_ ps $ \(x, y) -> CM.lineTo (x, y) + when closed $ CM.closePath +followPath [p1, p2] False True = followPath [p1, p2] False False +followPath ps False True = do + let [p1@(x1, y1), p2@(x2, y2), p3@(x3, y3)] = take 3 ps + dprev = euclideanDistance p1 p2 + dnext = euclideanDistance p2 p3 + p = dprev / (dprev + dnext) + cx = x2 + p * (x1 - x3) / 2 + cy = y2 + p * (y1 - y3) / 2 + CM.moveTo (x1, y1) + CM.quadraticCurveTo (cx, cy) (x2, y2) + forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \(p1@(x1, y1), p2@(x2, y2), p3@(x3, y3), p4@(x4, y4)) -> do + let dp = euclideanDistance p1 p2 + d1 = euclideanDistance p2 p3 + d2 = euclideanDistance p3 p4 + p = d1 / (d1 + d2) + r = d1 / (dp + d1) + cx1 = x2 + r * (x3 - x1) / 2 + cy1 = y2 + r * (y3 - y1) / 2 + cx2 = x3 + p * (x2 - x4) / 2 + cy2 = y3 + p * (y2 - y4) / 2 + CM.bezierCurveTo + (cx1, cy1) + (cx2, cy2) + (x3, y3) + let [p1@(x1, y1), p2@(x2, y2), p3@(x3, y3)] = reverse $ take 3 $ reverse ps + dp = euclideanDistance p1 p2 + d1 = euclideanDistance p2 p3 + r = d1 / (dp + d1) + cx = x2 + r * (x3 - x1) / 2 + cy = y2 + r * (y3 - y1) / 2 + CM.quadraticCurveTo (cx, cy) (x3, y3) +followPath ps@(_:(sx, sy):_) True True = do + CM.moveTo (sx, sy) + let rep = cycle ps + forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \(p1@(x1, y1), p2@(x2, y2), p3@(x3, y3), p4@(x4, y4)) -> do + let dp = euclideanDistance p1 p2 + d1 = euclideanDistance p2 p3 + d2 = euclideanDistance p3 p4 + p = d1 / (d1 + d2) + r = d1 / (dp + d1) + cx1 = x2 + r * (x3 - x1) / 2 + cy1 = y2 + r * (y3 - y1) / 2 + cx2 = x3 + p * (x2 - x4) / 2 + cy2 = y3 + p * (y2 - y4) / 2 + CM.bezierCurveTo + (cx1, cy1) + (cx2, cy2) + (x3, y3) + CM.closePath + +euclideanDistance :: Point -> Point -> Double +euclideanDistance (x1, y1) (x2, y2) = sqrt $ square (x2 - x1) + square (y2 - y1) + where + square x = x * x + +drawFigure :: MonadCanvas m => DrawState -> Double -> m () -> m () +drawFigure ds w figure = do + withDS ds $ do + figure + when (w /= 0) $ do + CM.lineWidth w + applyColor ds + CM.stroke + when (w == 0) $ do + CM.lineWidth =<< pixelSize + applyColor ds + CM.stroke + +fillFigure :: MonadCanvas m => DrawState -> m () -> m () +fillFigure ds figure = do + withDS ds $ figure + applyColor ds + CM.fill + +-------------------------------------------------------------------------------- + +drawPicture :: MonadCanvas m => Picture -> DrawState -> m () +drawPicture (SolidClosedCurve _ pts) ds = drawPolygon pts True ds +drawPicture (SolidPolygon _ pts) ds = drawPolygon pts False ds +drawPicture (Polygon _ pts) ds = drawPath pts 0 True False ds +drawPicture (ThickPolygon _ pts w) ds = drawPath pts w True False ds +drawPicture (Rectangle _ w h) ds = drawPath (rectangleVertices w h) 0 True False ds +drawPicture (SolidRectangle _ w h) ds = drawPolygon (rectangleVertices w h) False ds +drawPicture (ThickRectangle _ lw w h) ds = drawPath (rectangleVertices w h) lw True False ds +drawPicture (ClosedCurve _ pts) ds = drawPath pts 0 True True ds +drawPicture (ThickClosedCurve _ pts w) ds = drawPath pts w True True ds +drawPicture (Circle _ r) ds = drawArc 0 (2 * pi) r 0 ds +drawPicture (SolidCircle _ r) ds = drawSector 0 (2 * pi) r ds +drawPicture (ThickCircle _ lw r) ds = drawArc 0 (2 * pi) r lw ds +drawPicture (Polyline _ pts) ds = drawPath pts 0 False False ds +drawPicture (ThickPolyline _ pts w) ds = drawPath pts w False False ds +drawPicture (Curve _ pts) ds = drawPath pts 0 False True ds +drawPicture (ThickCurve _ pts w) ds = drawPath pts w False True ds +drawPicture (Sector _ b e r) ds = drawSector b e r ds +drawPicture (Arc _ b e r) ds = drawArc b e r 0 ds +drawPicture (ThickArc _ b e r w) ds = drawArc b e r w ds +drawPicture (Lettering _ txt) ds = drawText Plain Serif txt ds +drawPicture (Blank _) _ = return () +drawPicture (StyledLettering _ sty fnt txt) ds = drawText sty fnt txt ds +drawPicture (Sketch _ name url w h) ds = drawImage name url w h ds +drawPicture (CoordinatePlane _) ds = drawPicture coordinatePlanePic ds +drawPicture (Color _ col p) ds + | isSimplePic p || isOpaque col = drawPicture p (setColorDS col ds) + | otherwise = viaOffscreen col $ \c -> drawPicture p (setColorDS c ds) +drawPicture (Translate _ x y p) ds = drawPicture p (translateDS x y ds) +drawPicture (Scale _ x y p) ds = drawPicture p (scaleDS x y ds) +drawPicture (Dilate _ k p) ds = drawPicture p (scaleDS k k ds) +drawPicture (Rotate _ r p) ds = drawPicture p (rotateDS r ds) +drawPicture (Pictures _ ps) ds = forM_ (reverse ps) $ \p -> drawPicture p ds +drawPicture (PictureAnd _ ps) ds = forM_ (reverse ps) $ \p -> drawPicture p ds + +pictureContains :: MonadCanvas m => Picture -> DrawState -> Point -> m Bool +pictureContains (SolidClosedCurve _ pts) ds pt = polygonContains pts True ds pt +pictureContains (SolidPolygon _ pts) ds pt = polygonContains pts False ds pt +pictureContains (Polygon _ pts) ds pt = pathContains pts 0 True False ds pt +pictureContains (ThickPolygon _ pts w) ds pt = pathContains pts w True False ds pt +pictureContains (Rectangle _ w h) ds pt = pathContains (rectangleVertices w h) 0 True False ds pt +pictureContains (SolidRectangle _ w h) ds pt = polygonContains (rectangleVertices w h) False ds pt +pictureContains (ThickRectangle _ lw w h) ds pt = pathContains (rectangleVertices w h) lw True False ds pt +pictureContains (ClosedCurve _ pts) ds pt = pathContains pts 0 True True ds pt +pictureContains (ThickClosedCurve _ pts w) ds pt = pathContains pts w True True ds pt +pictureContains (Circle _ r) ds pt = arcContains 0 (2 * pi) r 0 ds pt +pictureContains (SolidCircle _ r) ds pt = sectorContains 0 (2 * pi) r ds pt +pictureContains (ThickCircle _ lw r) ds pt = arcContains 0 (2 * pi) r lw ds pt +pictureContains (Polyline _ pts) ds pt = pathContains pts 0 False False ds pt +pictureContains (ThickPolyline _ pts w) ds pt = pathContains pts w False False ds pt +pictureContains (Curve _ pts) ds pt = pathContains pts 0 False True ds pt +pictureContains (ThickCurve _ pts w) ds pt = pathContains pts w False True ds pt +pictureContains (Sector _ b e r) ds pt = sectorContains b e r ds pt +pictureContains (Arc _ b e r) ds pt = arcContains b e r 0 ds pt +pictureContains (ThickArc _ b e r w) ds pt = arcContains b e r w ds pt +pictureContains (Lettering _ txt) ds pt = textContains Plain Serif txt ds pt +pictureContains (Blank _) _ _ = return False +pictureContains (StyledLettering _ sty fnt txt) ds pt = textContains sty fnt txt ds pt +pictureContains (Sketch _ name url w h) ds pt = imageContains name url w h ds pt +pictureContains (CoordinatePlane _) ds pt = pictureContains coordinatePlanePic ds pt +pictureContains (Color _ _ p) ds pt = pictureContains p ds pt +pictureContains (Translate _ x y p) ds pt = pictureContains p (translateDS x y ds) pt +pictureContains (Scale _ x y p) ds pt = pictureContains p (scaleDS x y ds) pt +pictureContains (Dilate _ k p) ds pt = pictureContains p (scaleDS k k ds) pt +pictureContains (Rotate _ r p) ds pt = pictureContains p (rotateDS r ds) pt +pictureContains (Pictures _ ps) ds pt = orM [pictureContains p ds pt | p <- ps] +pictureContains (PictureAnd _ ps) ds pt = orM [pictureContains p ds pt | p <- ps] + +isSimplePic :: Picture -> Bool +isSimplePic (Pictures _ []) = True +isSimplePic (Pictures _ [p]) = isSimplePic p +isSimplePic (Pictures _ _) = False +isSimplePic (PictureAnd _ []) = True +isSimplePic (PictureAnd _ [p]) = isSimplePic p +isSimplePic (PictureAnd _ _) = False +isSimplePic (Translate _ _ _ p) = isSimplePic p +isSimplePic (Scale _ _ _ p) = isSimplePic p +isSimplePic (Dilate _ _ p) = isSimplePic p +isSimplePic (Rotate _ _ p) = isSimplePic p +isSimplePic (Color _ c p) = not (isOpaque c) || isSimplePic p +isSimplePic _ = True + +isOpaque :: Color -> Bool +isOpaque (RGBA _ _ _ 1) = True +isOpaque _ = False + +drawPolygon :: MonadCanvas m => [Point] -> Bool -> DrawState -> m () +drawPolygon ps smooth ds = fillFigure ds $ followPath ps True smooth + +polygonContains :: MonadCanvas m => [Point] -> Bool -> DrawState -> Point -> m Bool +polygonContains ps smooth ds p = do + withDS ds $ followPath ps True smooth + CM.isPointInPath p + +drawPath :: MonadCanvas m => [Point] -> Double -> Bool -> Bool -> DrawState -> m () +drawPath ps w closed smooth ds = drawFigure ds w $ followPath ps closed smooth + +pathContains :: MonadCanvas m => [Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool +pathContains ps w closed smooth ds p = do + s <- pixelSize + drawFigure ds (max s w) $ followPath ps closed smooth + CM.isPointInStroke p + +drawSector :: MonadCanvas m => Double -> Double -> Double -> DrawState -> m () +drawSector b e r ds = do + fillFigure ds $ CM.arc 0 0 (abs r) b e (b > e) >> CM.lineTo (0, 0) + +sectorContains :: MonadCanvas m => Double -> Double -> Double -> DrawState -> Point -> m Bool +sectorContains b e r ds p = do + withDS ds $ CM.arc 0 0 (abs r) b e (b > e) >> CM.lineTo (0, 0) + CM.isPointInPath p + +drawArc :: MonadCanvas m => Double -> Double -> Double -> Double -> DrawState -> m () +drawArc b e r w ds = do + drawFigure ds w $ CM.arc 0 0 (abs r) b e (b > e) + +arcContains :: MonadCanvas m => Double -> Double -> Double -> Double -> DrawState -> Point -> m Bool +arcContains b e r w ds p = do + s <- pixelSize + let width = max s w + CM.lineWidth width + drawFigure ds width $ + CM.arc 0 0 (abs r) b e (b > e) + CM.isPointInStroke p + +drawText :: MonadCanvas m => TextStyle -> Font -> Text -> DrawState -> m () +drawText sty fnt txt ds = withDS ds $ do + CM.scale (1/25) (-1/25) + applyColor ds + CM.font (fontString sty fnt) + CM.fillText txt (0, 0) + +textContains :: MonadCanvas m => TextStyle -> Font -> Text -> DrawState -> Point -> m Bool +textContains sty fnt txt ds p = do + CM.font (fontString sty fnt) + width <- (/ 25) <$> CM.measureText txt + let height = 1 -- constant, defined in fontString + withDS ds $ CM.rect ((-0.5) * width) ((-0.5) * height) width height + CM.isPointInPath p + +fontString :: TextStyle -> Font -> Text +fontString style font = stylePrefix style <> "25px " <> fontName font + where + stylePrefix Plain = "" + stylePrefix Bold = "bold " + stylePrefix Italic = "italic " + + fontName SansSerif = "sans-serif" + fontName Serif = "serif" + fontName Monospace = "monospace" + fontName Handwriting = "cursive" + fontName Fancy = "fantasy" + fontName (NamedFont txt) = "\"" <> T.filter (/= '"') txt <> "\"" + +drawImage :: MonadCanvas m => Text -> Text -> Double -> Double -> DrawState -> m () +drawImage name url imgw imgh ds = case getColorDS ds of + -- Fast path: draw in original color. + Nothing -> withDS ds $ do + CM.scale 1 (-1) + CM.drawImgURL name url imgw imgh + + -- Slow path: draw in a different color via an offscreen canvas. + Just oc -> viaOffscreen oc $ \c -> do + setColor c + w <- CM.getScreenWidth + h <- CM.getScreenHeight + CM.fillRect (-w/2) (-h/2) w h + CM.globalCompositeOperation "destination-in" + withDS ds $ do + CM.scale (1) (-1) + CM.drawImgURL name url imgw imgh + +imageContains :: MonadCanvas m => Text -> Text -> Double -> Double -> DrawState -> Point -> m Bool +imageContains _ _ imgw imgh ds p = withDS ds $ do + CM.rect (-imgw / 2) (-imgh / 2) imgw imgh + CM.isPointInPath p + +coordinatePlanePic :: Picture +coordinatePlanePic = axes <> numbers <> guidelines + where + xline y = colored (RGBA 0 0 0 0.25) $ polyline [(-10, y), (10, y)] + xaxis = colored (RGBA 0 0 0 0.75) $ polyline [(-10, 0), (10, 0)] + axes = xaxis <> rotated (pi / 2) xaxis + xguidelines = pictures [xline k | k <- [-10,-9 .. 10]] + guidelines = xguidelines <> rotated (pi / 2) xguidelines + numbers = xnumbers <> ynumbers + xnumbers = + pictures + [ translated + (fromIntegral k) + 0.3 + (scaled 0.5 0.5 (lettering (T.pack (show k)))) + | k <- [-9,-8 .. 9] + , k /= (0 :: Int) + ] + ynumbers = + pictures + [ translated + 0.3 + (fromIntegral k) + (scaled 0.5 0.5 (lettering (T.pack (show k)))) + | k <- [-9,-8 .. 9] + , k /= (0 :: Int) + ] + +-------------------------------------------------------------------------------- + +clearScreen :: MonadCanvas m => m () +clearScreen = do + w <- CM.getScreenWidth + h <- CM.getScreenHeight + px <- pixelSize + CM.fillColor 255 255 255 1 + CM.fillRect (-w/2 * px) (-h/2 * px) (w * px) (h * px) + +drawFrame :: MonadCanvas m => Picture -> m () +drawFrame pic = clearScreen >> drawPicture pic initialDS + +pixelSize :: MonadCanvas m => m Double +pixelSize = do + cw <- CM.getScreenWidth + ch <- CM.getScreenHeight + return $ max (20 / realToFrac cw) (20 / realToFrac ch) + +setupScreenContext :: MonadCanvas m => Int -> Int -> m () +setupScreenContext cw ch = do + CM.translate (realToFrac cw / 2) (realToFrac ch / 2) + s <- pixelSize + CM.scale (1/s) (-1/s) + CM.lineWidth 0 + CM.textCenter + 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 { getNodeId :: Int} + deriving (Eq, Ord, Enum, Show) + +getChildNodes :: Picture -> [Picture] +getChildNodes (Color _ _ p) = [p] +getChildNodes (Translate _ _ _ p) = [p] +getChildNodes (Scale _ _ _ p) = [p] +getChildNodes (Dilate _ _ p) = [p] +getChildNodes (Rotate _ _ p) = [p] +getChildNodes (Pictures _ ps) = ps +getChildNodes (PictureAnd _ ps) = ps +getChildNodes _ = [] + +getRootTransform :: Picture -> DrawState -> DrawState +getRootTransform (Color _ c _) = setColorDS c +getRootTransform (Translate _ x y _) = translateDS x y +getRootTransform (Scale _ x y _) = scaleDS x y +getRootTransform (Dilate _ k _) = scaleDS k k +getRootTransform (Rotate _ r _) = rotateDS r +getRootTransform _ = id + +findTopShape :: MonadCanvas m => DrawState -> Picture -> Double -> Double -> m (Maybe NodeId) +findTopShape ds pic x y = do + (found, n) <- searchSingle ds pic x y + return $ if found + then Just (NodeId n) + else Nothing + where + searchSingle ds pic x y = case getChildNodes pic of + [] -> do + contained <- pictureContains pic ds (x, y) + case contained of + True -> return (True, 0) + False -> return (False, 1) + pics -> fmap (+ 1) <$> searchMulti (getRootTransform pic ds) pics x y + searchMulti _ [] _ _ = return (False, 0) + searchMulti ds (pic:pics) x y = do + (found, count) <- searchSingle ds pic x y + case found of + True -> return (True, count) + False -> fmap (+ count) <$> searchMulti ds pics x y + +-- 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 (x, y) pic = do + cw <- CM.getScreenWidth + ch <- CM.getScreenHeight + img <- CM.newImage (round cw) (round ch) + CM.withImage img $ do + setupScreenContext (round cw) (round ch) + findTopShape initialDS pic x y + +trim :: Int -> String -> String +trim x y + | x >= length y = y + | otherwise = take mid y ++ "..." ++ (reverse $ take mid $ reverse y) + where mid = (x - 3) `div` 2 + +showFloat :: Double -> String +showFloat x + | haskellMode && x < 0 = "(" ++ result ++ ")" + | otherwise = result + where result = stripZeros (showFFloatAlt (Just 4) x "") + stripZeros = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse + +showPoints :: [Point] -> String +showPoints pts = + "[" ++ + intercalate ", " [ + "(" ++ showFloat x ++ ", " ++ showFloat y ++ ")" + | (x, y) <- pts + ] ++ + "]" + +showColor :: Color -> String +showColor c@(RGBA r g b a) + | c == black = "black" + | c == white = "white" + | c == red = "red" + | c == green = "green" + | c == blue = "blue" + | c == yellow = "yellow" + | c == orange = "orange" + | c == brown = "brown" + | c == pink = "pink" + | c == purple = "purple" + | c == gray = "gray" + | haskellMode, a == 1 = printf "(RGB %s %s %s)" (showFloat r) (showFloat g) (showFloat b) + | a == 1 = printf "RGB(%s, %s, %s)" (showFloat r) (showFloat g) (showFloat b) + | haskellMode = printf "(RGBA %s %s %s %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a) + | otherwise = printf "RGBA(%s, %s, %s, %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a) + +describePicture :: Picture -> String +describePicture (Rectangle _ w h) + | haskellMode = printf "rectangle %s %s" (showFloat w) (showFloat h) + | otherwise = printf "rectangle(%s, %s)" (showFloat w) (showFloat h) +describePicture (SolidRectangle _ w h) + | haskellMode = printf "solidRectangle %s %s" (showFloat w) (showFloat h) + | otherwise = printf "solidRectangle(%s, %s)" (showFloat w) (showFloat h) +describePicture (ThickRectangle _ lw w h) + | haskellMode = printf "thickRectangle %s %s %s" (showFloat lw) (showFloat w) (showFloat h) + | otherwise = printf "thickRectangle(%s, %s, %s)" (showFloat w) (showFloat h) (showFloat lw) +describePicture (Circle _ r) + | haskellMode = printf "circle %s" (showFloat r) + | otherwise = printf "circle(%s)" (showFloat r) +describePicture (SolidCircle _ r) + | haskellMode = printf "solidCircle %s" (showFloat r) + | otherwise = printf "solidCircle(%s)" (showFloat r) +describePicture (ThickCircle _ lw r) + | haskellMode = printf "thickCircle %s %s" (showFloat lw) (showFloat r) + | otherwise = printf "thickCircle(%s, %s)" (showFloat r) (showFloat lw) +describePicture (SolidPolygon _ pts) + | haskellMode = printf "solidPolygon %s" (showPoints pts) + | otherwise = printf "solidPolygon(%s)" (showPoints pts) +describePicture (SolidClosedCurve _ pts) + | haskellMode = printf "solidClosedCurve %s" (showPoints pts) + | otherwise = printf "solidClosedCurve(%s)" (showPoints pts) +describePicture (Polygon _ pts) + | haskellMode = printf "polygon %s" (showPoints pts) + | otherwise = printf "polygon(%s)" (showPoints pts) +describePicture (ThickPolygon _ pts w) + | haskellMode = printf "thickPolygon %s %s" (showFloat w) (showPoints pts) + | otherwise = printf "thickPolygon(%s, %s)" (showPoints pts) (showFloat w) +describePicture (ClosedCurve _ pts) + | haskellMode = printf "closedCurve %s" (showPoints pts) + | otherwise = printf "closedCurve(%s)" (showPoints pts) +describePicture (ThickClosedCurve _ pts w) + | haskellMode = printf "thickClosedCurve %s %s" (showFloat w) (showPoints pts) + | otherwise = printf "thickClosedCurve(%s, %s)" (showPoints pts) (showFloat w) +describePicture (Polyline _ pts) + | haskellMode = printf "polyline %s" (showPoints pts) + | otherwise = printf "polyline(%s)" (showPoints pts) +describePicture (ThickPolyline _ pts w) + | haskellMode = printf "thickPolyline %s %s" (showFloat w) (showPoints pts) + | otherwise = printf "thickPolyline(%s, %s)" (showPoints pts) (showFloat w) +describePicture (Curve _ pts) + | haskellMode = printf "curve %s" (showPoints pts) + | otherwise = printf "curve(%s)" (showPoints pts) +describePicture (ThickCurve _ pts w) + | haskellMode = printf "thickCurve %s %s" (showFloat w) (showPoints pts) + | otherwise = printf "thickCurve(%s, %s)" (showPoints pts) (showFloat w) +describePicture (Sector _ b e r) + | haskellMode = printf "sector %s %s %s" (showFloat b) (showFloat e) (showFloat r) + | otherwise = printf "sector(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r) +describePicture (Arc _ b e r) + | haskellMode = printf "arc %s %s %s" (showFloat b) (showFloat e) (showFloat r) + | otherwise = printf "arc(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r) +describePicture (ThickArc _ b e r w) + | haskellMode = printf "thickArc %s %s %s %s" (showFloat w) (showFloat b) (showFloat e) (showFloat r) + | otherwise = printf "thickArc(%s°, %s°, %s, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r) (showFloat w) +describePicture (Lettering _ txt) + | haskellMode = printf "lettering %s" (show txt) + | otherwise = printf "lettering(%s)" (show txt) +describePicture (Blank _) = "blank" +describePicture (StyledLettering _ style font txt) + | haskellMode = printf "styledLettering %s %s %s" (showsPrec 10 style "") (showsPrec 10 font "") (show txt) + | otherwise = printf "styledLettering(%s, %s, %s)" (show txt) (show font) (show style) +describePicture (Color _ c _) + | haskellMode = printf "colored %s" (showColor c) + | otherwise = printf "colored(..., %s)" (showColor c) +describePicture (Translate _ x y _) + | haskellMode = printf "translated %s %s" (showFloat x) (showFloat y) + | otherwise = printf "translated(..., %s, %s)" (showFloat x) (showFloat y) +describePicture (Scale _ x y _) + | haskellMode = printf "scaled %s %s" (showFloat x) (showFloat y) + | otherwise = printf "scaled(..., %s, %s)" (showFloat x) (showFloat y) +describePicture (Rotate _ angle _) + | haskellMode = printf "rotated %s" (showFloat angle) + | otherwise = printf "rotated(..., %s°)" (showFloat (180 * angle / pi)) +describePicture (Dilate _ k _) + | haskellMode = printf "dilated %s" (showFloat k) + | otherwise = printf "dilated(..., %s)" (showFloat k) +describePicture (Sketch _ name _ _ _) = T.unpack name +describePicture (CoordinatePlane _) = "coordinatePlane" +describePicture (Pictures _ _) + | haskellMode = "pictures" + | otherwise = "pictures(...)" +describePicture (PictureAnd _ _) + | haskellMode = "(&)" + | otherwise = "... & ..." + +getPictureSrcLoc :: Picture -> Maybe SrcLoc +getPictureSrcLoc (SolidPolygon loc _) = loc +getPictureSrcLoc (SolidClosedCurve loc _) = loc +getPictureSrcLoc (Polygon loc _) = loc +getPictureSrcLoc (ThickPolygon loc _ _) = loc +getPictureSrcLoc (Rectangle loc _ _) = loc +getPictureSrcLoc (SolidRectangle loc _ _) = loc +getPictureSrcLoc (ThickRectangle loc _ _ _) = loc +getPictureSrcLoc (ClosedCurve loc _) = loc +getPictureSrcLoc (ThickClosedCurve loc _ _) = loc +getPictureSrcLoc (Circle loc _) = loc +getPictureSrcLoc (SolidCircle loc _) = loc +getPictureSrcLoc (ThickCircle loc _ _) = loc +getPictureSrcLoc (Polyline loc _) = loc +getPictureSrcLoc (ThickPolyline loc _ _) = loc +getPictureSrcLoc (Curve loc _) = loc +getPictureSrcLoc (ThickCurve loc _ _) = loc +getPictureSrcLoc (Sector loc _ _ _) = loc +getPictureSrcLoc (Arc loc _ _ _) = loc +getPictureSrcLoc (ThickArc loc _ _ _ _) = loc +getPictureSrcLoc (Lettering loc _) = loc +getPictureSrcLoc (Blank loc) = loc +getPictureSrcLoc (StyledLettering loc _ _ _) = loc +getPictureSrcLoc (Color loc _ _) = loc +getPictureSrcLoc (Translate loc _ _ _) = loc +getPictureSrcLoc (Scale loc _ _ _) = loc +getPictureSrcLoc (Dilate loc _ _) = loc +getPictureSrcLoc (Rotate loc _ _) = loc +getPictureSrcLoc (Sketch loc _ _ _ _) = loc +getPictureSrcLoc (CoordinatePlane loc) = loc +getPictureSrcLoc (Pictures loc _) = loc +getPictureSrcLoc (PictureAnd loc _) = 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 + +foreign import javascript unsafe "showCanvas()" + 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 <- ClientRect.getWidth rect + ch <- ClientRect.getHeight rect + when (cw > 0 && ch > 0) $ + 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 + 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 -> ClientRect.ClientRect -> CanvasM a -> IO a +withScreen canvas rect action = do + cw <- realToFrac <$> ClientRect.getWidth rect + ch <- realToFrac <$> ClientRect.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 <- ClientRect.getWidth rect + cy <- ClientRect.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 = True + +type Port = Int + +readPortFromEnv :: String -> Port -> IO Port +readPortFromEnv envName defaultPort = do + ms <- lookupEnv envName + return (fromMaybe defaultPort (ms >>= readMaybe)) + +runBlankCanvas :: (Canvas.DeviceContext -> IO ()) -> IO () +runBlankCanvas act = do + port <- readPortFromEnv "CODEWORLD_API_PORT" 3000 + let options = + (fromIntegral port) + { Canvas.events = + ["mousedown", "mouseup", "mousemove", "keydown", "keyup"] + } + putStrLn $ printf "Open me on http://127.0.0.1:%d/" (Canvas.port options) + Canvas.blankCanvas options $ \context -> do + putStrLn "Program is starting..." + act context + +#endif + +-------------------------------------------------------------------------------- +-- Common event handling and core interaction code + +keyCodeToText :: Word -> Text +keyCodeToText n = + case n of + _ | n >= 47 && n <= 90 -> fromAscii n + _ | n >= 96 && n <= 105 -> fromNum (n - 96) + _ | n >= 112 && n <= 135 -> "F" <> fromNum (n - 111) + 3 -> "Cancel" + 6 -> "Help" + 8 -> "Backspace" + 9 -> "Tab" + 12 -> "5" + 13 -> "Enter" + 16 -> "Shift" + 17 -> "Ctrl" + 18 -> "Alt" + 19 -> "Break" + 20 -> "CapsLock" + 27 -> "Esc" + 32 -> " " + 33 -> "PageUp" + 34 -> "PageDown" + 35 -> "End" + 36 -> "Home" + 37 -> "Left" + 38 -> "Up" + 39 -> "Right" + 40 -> "Down" + 42 -> "*" + 43 -> "+" + 44 -> "PrintScreen" + 45 -> "Insert" + 46 -> "Delete" + 47 -> "Help" + 91 -> "OS" + 92 -> "OS" + 93 -> "ContextMenu" + 106 -> "*" + 107 -> "+" + 108 -> "," + 109 -> "-" + 110 -> "." + 111 -> "/" + 144 -> "NumLock" + 145 -> "ScrollLock" + 173 -> "-" + 186 -> ";" + 187 -> "=" + 188 -> "," + 189 -> "-" + 190 -> "." + 191 -> "/" + 192 -> "`" + 193 -> "IntlRo" + 194 -> "," + 219 -> "[" + 220 -> "\\" + 221 -> "]" + 222 -> "'" + 225 -> "AltGraph" + 255 -> "IntlYen" + _ -> "Unknown:" <> fromNum n + where + fromAscii n = T.singleton (chr (fromIntegral n)) + fromNum n = T.pack (show n) + +isUniversallyConstant :: (a -> s -> s) -> s -> Bool +isUniversallyConstant f old = + unsafePerformIO $ falseOr $ do + oldName <- makeStableName $! old + genName <- makeStableName $! f undefined old + return (genName == oldName) + where + falseOr x = x `catch` \(_ :: SomeException) -> return False + +ifDifferent :: (s -> s) -> s -> Maybe s +ifDifferent f s0 = unsafePerformIO $ do + oldName <- makeStableName $! s0 + newName <- makeStableName $! s1 + if newName == oldName then return Nothing else return (Just s1) + where s1 = f s0 + +modifyMVarIfDifferent :: MVar s -> (s -> s) -> IO Bool +modifyMVarIfDifferent var f = + modifyMVar var $ \s0 -> do + case ifDifferent f s0 of + Nothing -> return (s0, False) + Just s1 -> return (s1, True) + +data GameToken + = FullToken { tokenDeployHash :: Text + , tokenNumPlayers :: Int + , tokenInitial :: StaticKey + , tokenStep :: StaticKey + , tokenEvent :: StaticKey + , tokenDraw :: StaticKey } + | SteplessToken { tokenDeployHash :: Text + , tokenNumPlayers :: Int + , tokenInitial :: StaticKey + , tokenEvent :: StaticKey + , tokenDraw :: StaticKey } + | PartialToken { tokenDeployHash :: Text } + deriving (Generic) + +deriving instance Generic Fingerprint + +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 <$> ClientRect.getLeft rect + cy <- realToFrac <$> ClientRect.getTop rect + cw <- realToFrac <$> ClientRect.getWidth rect + ch <- realToFrac <$> ClientRect.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) + + Just window <- currentWindow + Just doc <- currentDocument + Just canvas <- getElementById doc ("screen" :: JSString) + + setCanvasSize canvas canvas + _ <- on window resize $ do + liftIO $ setCanvasSize canvas canvas + + showCanvas + + 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) + + Just window <- currentWindow + Just doc <- currentDocument + Just canvas <- getElementById doc ("screen" :: JSString) + + needsRedraw <- newMVar () + _ <- on window resize $ void $ liftIO $ do + setCanvasSize canvas canvas + tryPutMVar needsRedraw () + setCanvasSize canvas canvas + + showCanvas + + 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 <$> ClientRect.getLeft rect + cy <- realToFrac <$> ClientRect.getTop rect + cw <- realToFrac <$> ClientRect.getWidth rect + ch <- realToFrac <$> ClientRect.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 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 + + -- Sample the current user picture to draw to a canvas. + drawCB <- syncCallback2 ContinueAsync $ \c n -> do + let canvas = unsafeCoerce c :: Element + let nodeId = NodeId (pFromJSVal n) + drawPartialPic canvas nodeId =<< samplePicture + + -- 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 drawCB + +foreign import javascript unsafe "initDebugMode($1,$2,$3,$4,$5)" + js_initDebugMode :: Callback (JSVal -> IO JSVal) + -> Callback (JSVal -> IO ()) + -> Callback (IO JSVal) + -> Callback (JSVal -> JSVal -> IO ()) + -> 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 + + Just doc <- currentDocument + Just canvas <- getElementById doc ("screen" :: JSString) + 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) + 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 (w, h) (x, y) = + ((x - mx) / unitLen, (my - y) / unitLen) + where + w' = fromIntegral w + h' = fromIntegral h + unitLen = min w' h' / 20 + mx = w' / 2 + my = h' / 2 + +toEvent :: (Int, Int) -> Canvas.Event -> Maybe Event +toEvent rect Canvas.Event {..} + | eType == "keydown" + , Just code <- eWhich = Just $ KeyPress (keyCodeToText (fromIntegral code)) + | eType == "keyup" + , Just code <- eWhich = + Just $ KeyRelease (keyCodeToText (fromIntegral code)) + | eType == "mousedown" + , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerPress pos + | eType == "mouseup" + , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerRelease pos + | eType == "mousemove" + , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerMovement pos + | otherwise = Nothing + +onEvents :: Canvas.DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO () +onEvents context rect handler = void $ forkIO $ forever $ do + maybeEvent <- toEvent rect <$> Canvas.wait context + forM_ maybeEvent handler + +run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO () +run initial stepHandler eventHandler drawHandler = + runBlankCanvas $ \context -> do + let fullStepHandler dt = stepHandler dt . eventHandler (TimePassing dt) + let cw = Canvas.width context + let ch = Canvas.height context + offscreenCanvas <- runCanvasM context $ CM.newImage cw ch + currentState <- newMVar initial + eventHappened <- newMVar () + onEvents context (cw, ch) $ \event -> do + modifyMVar_ currentState (return . eventHandler event) + void $ tryPutMVar eventHappened () + let go t0 lastFrame lastStateName needsTime = do + pic <- drawHandler <$> readMVar currentState + picFrame <- makeStableName $! pic + when (picFrame /= lastFrame) $ + runCanvasM context $ do + CM.withImage offscreenCanvas $ + CM.saveRestore $ do + setupScreenContext cw ch + drawFrame pic + CM.drawImage offscreenCanvas 0 0 cw ch + t1 <- case needsTime of + True -> do + tn <- getCurrentTime + threadDelay $ + max + 0 + (50000 - + round ((tn `diffUTCTime` t0) * 1000000)) + t1 <- getCurrentTime + let dt = realToFrac (t1 `diffUTCTime` t0) + when (dt > 0) $ modifyMVar_ currentState (return . fullStepHandler dt) + return t1 + False -> do + takeMVar eventHappened + getCurrentTime + nextState <- readMVar currentState + nextStateName <- makeStableName $! nextState + let nextNeedsTime = + nextStateName /= lastStateName || + needsTime && not (isUniversallyConstant fullStepHandler nextState) + go t1 picFrame nextStateName nextNeedsTime + t0 <- getCurrentTime + nullFrame <- makeStableName undefined + initialStateName <- makeStableName $! initial + go t0 nullFrame initialStateName True + +runInspect + :: s + -> (Double -> s -> s) + -> (Event -> s -> s) + -> (s -> Picture) + -> (s -> Picture) + -> IO () +runInspect initial step event draw _rawDraw = run initial step event draw + +getDeployHash :: IO Text +getDeployHash = error "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 = error "game API unimplemented in stand-alone interface mode" + +#endif + +-------------------------------------------------------------------------------- +-- FRP implementation + +data ReactiveInput t = ReactiveInput { + keyPress :: R.Event t Text, + keyRelease :: R.Event t Text, + textEntry :: R.Event t Text, + pointerPress :: R.Event t Point, + pointerRelease :: R.Event t Point, + pointerPosition :: R.Dynamic t Point, + pointerDown :: R.Dynamic t Bool, + timePassing :: R.Event t Double + } + +data ReactiveOutput = ReactiveOutput { + userPictures :: [Picture], + userTransform :: Picture -> Picture, + systemPicture :: Picture + } + +instance Semigroup ReactiveOutput where + a <> b = ReactiveOutput { + userPictures = userPictures a ++ userPictures b, + userTransform = userTransform a . userTransform b, + systemPicture = systemPicture a & systemPicture b + } + +instance Monoid ReactiveOutput where + mempty = ReactiveOutput [] id blank + +newtype ReactiveProgram t m a = ReactiveProgram { + 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 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.PerformEvent t m => R.PerformEvent 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 a0 a' = + ReactiveProgram $ R.runWithReplace (unReactiveProgram a0) $ fmap unReactiveProgram a' + traverseIntMapWithKeyWithAdjust f dm0 dm' = + ReactiveProgram $ R.traverseIntMapWithKeyWithAdjust (\k v -> unReactiveProgram (f k v)) dm0 dm' + traverseDMapWithKeyWithAdjust f dm0 dm' = + ReactiveProgram $ R.traverseDMapWithKeyWithAdjust (\k v -> unReactiveProgram (f k v)) dm0 dm' + traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = + ReactiveProgram $ R.traverseDMapWithKeyWithAdjustWithMove (\k v -> unReactiveProgram (f k v)) dm0 dm' + +runReactiveProgram + :: (R.Reflex t, MonadFix m) + => ReactiveProgram t m () + -> ReactiveInput t + -> m (R.Dynamic t Picture, R.Dynamic t Picture) +runReactiveProgram (ReactiveProgram program) input = do + ((), output) <- R.runDynamicWriterT (runReaderT program input) + return $ R.splitDynPure $ do + pics <- userPictures <$> output + let userPicture = case pics of + [] -> blank + [p] -> p + ps -> pictures ps + tform <- userTransform <$> output + sysPic <- systemPicture <$> output + return (userPicture, sysPic & tform userPicture) + +withReactiveInput + :: ReactiveInput t + -> (ReactiveProgram t m a -> ReactiveProgram t m a) +withReactiveInput input (ReactiveProgram program) + = ReactiveProgram (withReaderT (const input) program) + +getReactiveInput :: Monad m => ReactiveProgram t m (ReactiveInput t) +getReactiveInput = ReactiveProgram ask + +systemDraw :: (R.Reflex t, Monad m) => R.Dynamic t Picture -> ReactiveProgram t m () +systemDraw = ReactiveProgram . R.tellDyn . fmap (\a -> mempty { systemPicture = a }) + +transformUserPicture + :: (R.Reflex t, Monad m) => R.Dynamic t (Picture -> Picture) -> ReactiveProgram t m () +transformUserPicture = + ReactiveProgram . R.tellDyn . fmap (\a -> mempty { userTransform = a }) + +-- | Type class for the builder monad of a CodeWorld/Reflex app. +class (R.Reflex t, R.MonadHold t m, MonadFix m, R.PerformEvent t m, + R.Adjustable t m, MonadIO (R.Performable m), R.PostBuild t 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.MonadHold t m, MonadFix m, R.PerformEvent t m, + R.Adjustable t m, MonadIO (R.Performable m), R.PostBuild t m) + => ReflexCodeWorld t (ReactiveProgram t m) where + getKeyPress = ReactiveProgram $ asks keyPress + + getKeyRelease = ReactiveProgram $ asks keyRelease + + getTextEntry = ReactiveProgram $ asks textEntry + + getPointerClick = ReactiveProgram $ asks pointerPress + + getPointerPosition = ReactiveProgram $ asks pointerPosition + + isPointerDown = ReactiveProgram $ asks pointerDown + + getTimePassing = ReactiveProgram $ asks timePassing + + draw = ReactiveProgram . R.tellDyn . fmap (\a -> mempty { userPictures = [a] }) + +splitDyn :: forall t a. R.Reflex t => R.Dynamic t (a -> Bool) -> R.Event t a -> (R.Event t a, R.Event t a) +splitDyn predicate e = R.fanEither $ R.attachPromptlyDynWith f predicate e + where f pred val = if pred val then Right val else Left val + +gateDyn :: forall t a. R.Reflex t => R.Dynamic t Bool -> R.Event t a -> R.Event t a +gateDyn dyn e = R.switchDyn (bool R.never e <$> dyn) + +#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.mergeWith (&&) [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.MonadHold t m, MonadFix m, R.PerformEvent t m, + R.Adjustable t m, MonadIO (R.Performable m), R.PostBuild t m) + => (ReactiveInput t -> m (R.Dynamic t Picture, R.Dynamic t Picture))) + -> IO () +runReactive program = do + showCanvas + + Just window <- currentWindow + Just doc <- currentDocument + Just canvas <- getElementById doc ("screen" :: JSString) + 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 + + 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 + (inspectPicture, fireCommand) <- R.runSpiderHost $ R.hostPerformEventT $ do + (inspectPicture, displayPicture) <- R.runPostBuildT (program logicalInput) postBuild + let logicalPicture = drawDebugState <$> debugState + <*> inspectPicture + <*> displayPicture + R.performEvent_ $ liftIO <$> R.mergeWith const [ + (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 f = R.runSpiderHost $ do + state <- readRef debugUpdateTriggerRef + case state of + Just trigger -> void $ + R.runFireCommand fireCommand [trigger ==> f] (return ()) + Nothing -> return () + let samplePicture = R.runSpiderHost $ R.runHostFrame $ R.sample $ R.current inspectPicture + connectInspect canvas samplePicture fireDebugUpdateAndRedraw + + maybePostBuildTrigger <- readRef postBuildTriggerRef + case maybePostBuildTrigger of + Just trigger -> R.runSpiderHost $ void $ + R.runFireCommand fireCommand [trigger ==> ()] (return ()) + Nothing -> return () + + waitForever + +#else + +runReactive + :: (forall t m. (R.Reflex t, R.MonadHold t m, MonadFix m, R.PerformEvent t m, + R.Adjustable t m, MonadIO (R.Performable m), R.PostBuild t m) + => (ReactiveInput t -> m (R.Dynamic t Picture, R.Dynamic t Picture))) + -> IO () +runReactive program = runBlankCanvas $ \context -> do + let cw = Canvas.width context + let ch = Canvas.height context + offscreenCanvas <- runCanvasM context $ CM.newImage cw ch + + let frame pic = runCanvasM context $ do + CM.withImage offscreenCanvas $ + CM.saveRestore $ do + setupScreenContext cw ch + drawFrame pic + CM.drawImage offscreenCanvas 0 0 cw ch + + (postBuild, postBuildTriggerRef) <- R.runSpiderHost R.newEventWithTriggerRef + + (keyPress, keyPressTrigger) <- R.runSpiderHost R.newEventWithTriggerRef + (textEntry, textEntryTrigger) <- R.runSpiderHost R.newEventWithTriggerRef + (keyRelease, keyReleaseTrigger) <- R.runSpiderHost R.newEventWithTriggerRef + (pointerPress, pointerPressTrigger) <- R.runSpiderHost R.newEventWithTriggerRef + (pointerRelease, pointerReleaseTrigger) <- R.runSpiderHost R.newEventWithTriggerRef + (pointerMovement, pointerMovementTrigger) <- R.runSpiderHost R.newEventWithTriggerRef + (timePassing, timePassingTrigger) <- R.runSpiderHost R.newEventWithTriggerRef + + pointerPosition <- R.runSpiderHost $ R.holdDyn (0, 0) pointerMovement + pointerDown <- R.runSpiderHost $ R.holdDyn False $ + R.mergeWith (&&) [True <$ pointerPress, False <$ pointerRelease] + + let input = ReactiveInput{..} + + (_, fireCommand) <- R.runSpiderHost $ R.hostPerformEventT $ do + (_inspectPicture, displayPicture) <- R.runPostBuildT (program input) postBuild + R.performEvent_ $ liftIO <$> R.mergeWith const [ + frame <$> R.updated displayPicture, + frame <$> R.tagPromptlyDyn displayPicture postBuild + ] + return () + + let sendEvent :: forall a. IORef (Maybe (R.EventTrigger (R.SpiderTimeline R.Global) a)) -> a -> IO () + sendEvent triggerRef val = do + mtrigger <- readRef triggerRef + case mtrigger of + Just trigger -> R.runSpiderHost $ void $ + R.runFireCommand fireCommand [trigger ==> val] (return ()) + Nothing -> return () + + maybePostBuildTrigger <- readRef postBuildTriggerRef + case maybePostBuildTrigger of + Just trigger -> R.runSpiderHost $ void $ + R.runFireCommand fireCommand [trigger ==> ()] (return ()) + Nothing -> return () + + t0 <- getCurrentTime + let go t1 = do + events <- Canvas.flush context + forM_ events $ \event -> case Canvas.eType event of + "keydown" | Just code <- Canvas.eWhich event -> do + let keyName = keyCodeToText (fromIntegral code) + sendEvent keyPressTrigger keyName + when (T.length keyName == 1) $ sendEvent textEntryTrigger keyName + "keyup" | Just code <- Canvas.eWhich event -> do + let keyName = keyCodeToText (fromIntegral code) + sendEvent keyReleaseTrigger keyName + "mousedown" | Just pos <- getMousePos (cw, ch) <$> Canvas.ePageXY event -> do + sendEvent pointerPressTrigger pos + "mouseup" | Just pos <- getMousePos (cw, ch) <$> Canvas.ePageXY event -> do + sendEvent pointerReleaseTrigger pos + "mousemove" | Just pos <- getMousePos (cw, ch) <$> Canvas.ePageXY event -> do + sendEvent pointerMovementTrigger pos + _ -> return () + + tn <- getCurrentTime + threadDelay $ max 0 (50000 - (round ((tn `diffUTCTime` t0) * 1000000))) + t2 <- getCurrentTime + let dt = realToFrac (t2 `diffUTCTime` t1) + sendEvent timePassingTrigger dt + go t2 + go t0 + +#endif diff --git a/src/CodeWorld/EntryPoints.hs b/src/CodeWorld/EntryPoints.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/EntryPoints.hs @@ -0,0 +1,936 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +{- + Copyright 2019 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.EntryPoints where + +import CodeWorld.Color +import CodeWorld.Driver +import CodeWorld.Event +import CodeWorld.Picture +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Prim +import GHC.StaticPtr +import GHC.Types +import Numeric (showFFloatAlt) +import System.IO +import System.IO.Unsafe +import System.Random + +-------------------------------------------------------------------------------- +-- Common code for activity, interaction, animation and simulation interfaces + +-- | Runs an interactive CodeWorld program that responds to 'Event's. +-- Activities can interact with the user, change over time, and remember +-- information about the past. +-- +-- Example: a program which draws a circle and changes its radius when user +-- presses Up or Down keys on her keyboard +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- import CodeWorld +-- +-- main = activityOf initialRadius updateRadius circle +-- where +-- initialRadius = 1 +-- +-- updateRadius event radius = +-- case event of +-- KeyPress "Up" -> radius + 1 +-- KeyPress "Down" -> radius - 1 +-- _ -> radius +-- @ +activityOf :: + -- | The initial state of the activity. + world -> + -- | The event handling function, which updates + -- the state given an event. + (Event -> world -> world) -> + -- | The visualization function, which converts + -- the state into a picture to display. + (world -> Picture) -> + IO () +activityOf initial change picture = + interactionOf initial (const id) change picture + +-- | Runs an interactive event-driven CodeWorld program. This is a +-- generalization of simulations that can respond to events like key presses +-- and mouse movement. +interactionOf :: + -- | The initial state of the interaction. + world -> + -- | The time step function, which advances + -- the state given the time difference. + (Double -> world -> world) -> + -- | The event handling function, which updates + -- the state given a user interface event. + (Event -> world -> world) -> + -- | The visualization function, which converts + -- the state into a picture to display. + (world -> Picture) -> + IO () +interactionOf initial step event draw = do + hFlush stdout + runInspect initial step event draw draw +{-# WARNING + interactionOf + [ "Please use activityOf instead of interactionOf.", + "interactionOf may be removed July 2020." + ] + #-} + +data Timeline a + = Timeline + { past :: [a], -- reversed list of past states + present :: !a, -- present state + future :: [a] -- list of future states + } + +newTimeline :: a -> Timeline a +newTimeline x = Timeline [] x [] + +applyToTimeline :: (a -> a) -> Timeline a -> Timeline a +applyToTimeline f timeline@Timeline {..} + | identical present new = timeline + | otherwise = Timeline (present : past) new [] + where + new = f present + +undoTimeline :: Timeline a -> Timeline a +undoTimeline timeline@Timeline {..} = case past of + [] -> timeline + (x : xs) -> Timeline xs x (present : future) + +redoTimeline :: Timeline a -> Timeline a +redoTimeline timeline@Timeline {..} = case future of + [] -> timeline + (x : xs) -> Timeline (present : past) x xs + +restartTimeline :: Timeline a -> Timeline a +restartTimeline timeline@Timeline {..} + | null past = timeline + | otherwise = Timeline [] x (xs ++ present : future) + where + x : xs = reverse past + +timelineLength :: Timeline a -> Int +timelineLength Timeline {..} = length past + 1 + length future + +travelToTime :: Double -> Timeline a -> Timeline a +travelToTime t timeline@Timeline {..} + | diff >= 0 = iterate redoTimeline timeline !! diff + | otherwise = iterate undoTimeline timeline !! (- diff) + where + desiredPast = round (t * (fromIntegral (timelineLength timeline - 1))) + actualPast = length past + diff = desiredPast - actualPast + +timelinePos :: Timeline a -> Double +timelinePos Timeline {..} + | null past && null future = 1 + | otherwise = fromIntegral (length past) / fromIntegral (length past + length future) + +data Control :: * -> * where + PlayButton :: Point -> Control a + PauseButton :: Point -> Control a + StepButton :: Point -> Control a + RestartButton :: Point -> Control Double + ZoomInButton :: Point -> Control a + ZoomOutButton :: Point -> Control a + PanningLayer :: Control a + ResetViewButton :: Point -> Control a + FastForwardButton :: Point -> Control a + StartOverButton :: Point -> Control (Timeline a) + BackButton :: Point -> Control Double + TimeLabel :: Point -> Control Double + SpeedSlider :: Point -> Control a + ZoomSlider :: Point -> Control a + UndoButton :: Point -> Control (Timeline a) + RedoButton :: Point -> Control (Timeline a) + HistorySlider :: Point -> Control (Timeline a) + +data StrictPoint = SP !Double !Double deriving (Eq, Show) + +data StrictMaybe a = SNothing | SJust !a deriving (Functor, Show) + +data Wrapped a + = Wrapped + { state :: a, + playbackSpeed :: !Double, + lastInteractionTime :: !Double, + zoomFactor :: !Double, + panCenter :: !StrictPoint, + panDraggingAnchor :: !(StrictMaybe StrictPoint), + isDraggingSpeed :: !Bool, + isDraggingHistory :: !Bool, + isDraggingZoom :: !Bool + } + deriving (Show, Functor) + +wrappedInitial :: a -> Wrapped a +wrappedInitial w = Wrapped + { state = w, + playbackSpeed = 1, + lastInteractionTime = 1000, + zoomFactor = 1, + panCenter = SP 0 0, + panDraggingAnchor = SNothing, + isDraggingSpeed = False, + isDraggingHistory = False, + isDraggingZoom = False + } + +identical :: a -> a -> Bool +identical !x !y = isTrue# (reallyUnsafePtrEquality# x y) + +toState :: (a -> a) -> (Wrapped a -> Wrapped a) +toState f w + | identical s s' = w + | otherwise = w {state = s'} + where + s = state w + s' = f s + +wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a +wrappedStep f dt w + | playbackSpeed w == 0 = w + | otherwise = toState (f (dt * playbackSpeed w)) w + +wrappedEvent :: + (Wrapped a -> [Control a]) -> + (Double -> a -> a) -> + (Event -> a -> a) -> + Event -> + Wrapped a -> + Wrapped a +wrappedEvent ctrls stepHandler eventHandler event = markInteraction . handleChange + where + markInteraction w + | TimePassing _ <- event, lastInteractionTime w > 5 = w + | TimePassing dt <- event = w {lastInteractionTime = lastInteractionTime w + dt} + | otherwise = w {lastInteractionTime = 0} + handleChange w0 + | playbackSpeed w0 == 0 || handled = w1 + | otherwise = toState (eventHandler (adaptEvent event)) w1 + where + (w1, handled) = foldr doCtrl (w0, False) (ctrls w0) + doCtrl _ (w, True) = (w, True) + doCtrl ctrl (w, False) = handleControl fullStep event ctrl w + fullStep dt = stepHandler dt . eventHandler (TimePassing dt) + adaptEvent (PointerMovement p) = PointerMovement (adaptPoint p) + adaptEvent (PointerPress p) = PointerPress (adaptPoint p) + adaptEvent (PointerRelease p) = PointerRelease (adaptPoint p) + adaptEvent (TimePassing dt) = TimePassing (dt * playbackSpeed w0) + adaptEvent other = other + adaptPoint (x, y) = (x / k - dx, y / k - dy) + SP dx dy = panCenter w1 + k = zoomFactor w1 + +scaleRange :: (Double, Double) -> (Double, Double) -> Double -> Double +scaleRange (a1, b1) (a2, b2) x = min b2 $ max a2 $ (x - a1) / (b1 - a1) * (b2 - a2) + a2 + +snapSlider :: Double -> [Double] -> Double -> Double +snapSlider eps targets val = foldr snap val targets + where + snap t v + | abs (t - v) < eps = t + | otherwise = v + +xToPlaybackSpeed :: Double -> Double +xToPlaybackSpeed x = snapSlider 0.2 [1 .. 4] $ scaleRange (-1.4, 1.4) (0, 5) x + +playbackSpeedToX :: Double -> Double +playbackSpeedToX s = scaleRange (0, 5) (-1.4, 1.4) s + +zoomIncrement :: Double +zoomIncrement = 8 ** (1 / 10) + +yToZoomFactor :: Double -> Double +yToZoomFactor y = zoomIncrement ** (scaleRange (-1.4, 1.4) (-10, 10) y) + +zoomFactorToY :: Double -> Double +zoomFactorToY z = scaleRange (-10, 10) (-1.4, 1.4) (logBase zoomIncrement z) + +handleControl :: + (Double -> a -> a) -> Event -> Control a -> Wrapped a -> (Wrapped a, Bool) +handleControl _ (PointerPress (x, y)) (RestartButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = 0}, True) +handleControl _ (PointerPress (x, y)) (StartOverButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (restartTimeline <$> w, True) +handleControl _ (PointerPress (x, y)) (PlayButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = 1}, True) +handleControl _ (PointerPress (x, y)) (PauseButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = 0}, True) +handleControl _ (PointerPress (x, y)) (FastForwardButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = max 2 (playbackSpeed w + 1)}, True) +handleControl _ (PointerPress (x, y)) (ZoomInButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = zoomFactor w * zoomIncrement}, True) +handleControl _ (PointerPress (x, y)) (ZoomOutButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = zoomFactor w / zoomIncrement}, True) +handleControl _ (PointerPress (x, y)) (ResetViewButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = 1, panCenter = SP 0 0}, True) +handleControl _ (PointerPress (x, y)) (BackButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (max 0 . (subtract 0.1) <$> w, True) +handleControl _ (PointerPress (x, y)) (UndoButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (undoTimeline <$> w, True) +handleControl _ (PointerPress (x, y)) (RedoButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (redoTimeline <$> w, True) +handleControl f (PointerPress (x, y)) (StepButton (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = f 0.1 (state w)}, True) +handleControl _ (PointerPress (x, y)) (SpeedSlider (cx, cy)) w + | abs (x - cx) < 1.5 && abs (y - cy) < 0.4 = + (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = True}, True) +handleControl _ (PointerMovement (x, _)) (SpeedSlider (cx, _)) w + | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx)}, True) +handleControl _ (PointerRelease (x, _)) (SpeedSlider (cx, _)) w + | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = False}, True) +handleControl _ (PointerPress (x, y)) (ZoomSlider (cx, cy)) w + | abs (x - cx) < 0.4 && abs (y - cy) < 1.5 = + (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = True}, True) +handleControl _ (PointerMovement (_, y)) (ZoomSlider (_, cy)) w + | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy)}, True) +handleControl _ (PointerRelease (_, y)) (ZoomSlider (_, cy)) w + | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = False}, True) +handleControl _ (PointerPress (x, y)) (HistorySlider (cx, cy)) w + | abs (x - cx) < 2.5 && abs (y - cy) < 0.4 = + (travelToTime (1 / 2 + (x - cx) / 4.8) <$> w {isDraggingHistory = True}, True) +handleControl _ (PointerMovement (x, _)) (HistorySlider (cx, _)) w + | isDraggingHistory w = (travelToTime (1 / 2 + (x - cx) / 4.8) <$> w, True) +handleControl _ (PointerRelease (x, _)) (HistorySlider (cx, _)) w + | isDraggingHistory w = (travelToTime (1 / 2 + (x - cx) / 4.8) <$> w {isDraggingHistory = False}, True) +handleControl _ (PointerPress (x, y)) PanningLayer w = + (w {panDraggingAnchor = SJust (SP x y)}, True) +handleControl _ (PointerMovement (x, y)) PanningLayer w + | SJust (SP ax ay) <- panDraggingAnchor w, + SP px py <- panCenter w = + ( w + { panCenter = + SP + (px + (x - ax) / zoomFactor w) + (py + (y - ay) / zoomFactor w), + panDraggingAnchor = SJust (SP x y) + }, + True + ) +handleControl _ (PointerRelease _) PanningLayer w + | SJust _ <- panDraggingAnchor w = (w {panDraggingAnchor = SNothing}, True) +handleControl _ _ _ w = (w, False) + +wrappedDraw :: + (Wrapped a -> [Control a]) -> (a -> Picture) -> Wrapped a -> Picture +wrappedDraw ctrls f w = drawControlPanel ctrls w <> dilated k (translated dx dy (f (state w))) + where + SP dx dy = panCenter w + k = zoomFactor w + +drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture +drawControlPanel ctrls w + | alpha > 0 = pictures [drawControl w alpha c | c <- ctrls w] + | otherwise = blank + where + alpha + | lastInteractionTime w < 4.5 = 1 + | lastInteractionTime w < 5.0 = 10 - 2 * lastInteractionTime w + | otherwise = 0 + +drawControl :: Wrapped a -> Double -> Control a -> Picture +drawControl _ alpha (RestartButton (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + ( thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 + <> translated 0.173 (-0.1) (solidRectangle 0.17 0.17) + ) + <> 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 (StartOverButton (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + ( thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 + <> translated 0.173 (-0.1) (solidRectangle 0.17 0.17) + ) + <> 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 (PlayButton (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + (solidPolygon [(-0.2, 0.25), (-0.2, -0.25), (0.2, 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 (PauseButton (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + ( translated (-0.15) 0 (solidRectangle 0.2 0.6) + <> translated 0.15 0 (solidRectangle 0.2 0.6) + ) + <> 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 (FastForwardButton (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + ( solidPolygon [(-0.3, 0.25), (-0.3, -0.25), (-0.05, 0)] + <> 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 (ZoomInButton (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + ( translated + (-0.05) + (0.05) + ( thickCircle 0.1 0.22 + <> solidRectangle 0.06 0.25 + <> solidRectangle 0.25 0.06 + <> rotated (- pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1)) + ) + ) + <> 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 (ZoomOutButton (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + ( translated + (-0.05) + (0.05) + ( thickCircle 0.1 0.22 + <> solidRectangle 0.25 0.06 + <> rotated (- pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1)) + ) + ) + <> 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 _ _ PanningLayer = blank +drawControl _ alpha (ResetViewButton (x, y)) = translated x y p + where + p = + colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.7 0.2) + <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.2 0.7) + <> colored (RGBA 0.0 0.0 0.0 alpha) (thickRectangle 0.1 0.5 0.5) + <> 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 (BackButton (x, y)) = translated x y 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 (UndoButton (x, y)) = translated x y 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 (x, y)) = translated x y 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 (RedoButton (x, y)) = translated x y 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 w alpha (TimeLabel (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + (scaled 0.5 0.5 $ lettering (T.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 (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + ( translated xoff 0.75 $ scaled 0.5 0.5 $ + lettering (T.pack (showFFloatAlt (Just 2) (playbackSpeed w) "x")) + ) + <> colored (RGBA 0 0 0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8)) + <> 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) + xoff = playbackSpeedToX (playbackSpeed w) +drawControl w alpha (ZoomSlider (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + ( translated (-1.1) yoff $ scaled 0.5 0.5 $ + lettering (T.pack (show (round (zoomFactor w * 100) :: Int) ++ "%")) + ) + <> colored (RGBA 0 0 0 alpha) (translated 0 yoff (solidRectangle 0.8 0.2)) + <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.25 2.8) + <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.25 2.8) + yoff = zoomFactorToY (zoomFactor w) +drawControl w alpha (HistorySlider (x, y)) = translated x y p + where + p = + colored + (RGBA 0 0 0 alpha) + ( translated xoff 0.75 $ scaled 0.5 0.5 $ + lettering (T.pack (show i ++ "/" ++ show n)) + ) + <> colored (RGBA 0.0 0.0 0.0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8)) + <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 4.8 0.25) + <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 4.8 0.25) + xoff = timelinePos (state w) * 4.8 - 2.4 + i = 1 + length (past (state w)) + n = timelineLength (state w) + +drawingControls :: Wrapped () -> [Control ()] +drawingControls w + | lastInteractionTime w > 5 = [] + | otherwise = commonControls ++ resetViewButton + where + commonControls = + [ PanningLayer, + ZoomInButton (9, -4), + ZoomOutButton (9, -8), + ZoomSlider (9, -6) + ] + resetViewButton + | zoomFactor w /= 1 || panCenter w /= SP 0 0 = [ResetViewButton (9, -3)] + | otherwise = [] + +-- | Draws a 'Picture'. This is the simplest CodeWorld entry point. +-- +-- Example: a program which draws a circle of radius 1 in the middle of canvas +-- +-- @ +-- main = drawingOf $ circle 1 +-- @ +drawingOf :: + -- | The picture to show on the screen. + Picture -> + IO () +drawingOf pic = do + hFlush stdout + runInspect + (wrappedInitial ()) + (wrappedStep step) + (wrappedEvent drawingControls step event) + (wrappedDraw drawingControls draw) + (draw . state) + where + step _ _ = () + event _ _ = () + draw _ = pic + +animationControls :: Wrapped Double -> [Control Double] +animationControls w + | lastInteractionTime w > 5 = [] + | otherwise = + commonControls ++ pauseDependentControls + ++ backButton + ++ resetViewButton + where + commonControls = + [ PanningLayer, + RestartButton (-9, -9), + TimeLabel (8, -9), + SpeedSlider (-3, -9), + FastForwardButton (-1, -9), + ZoomInButton (9, -4), + ZoomOutButton (9, -8), + ZoomSlider (9, -6) + ] + pauseDependentControls + | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-6, -9)] + | otherwise = [PauseButton (-8, -9)] + backButton + | playbackSpeed w == 0 && state w > 0 = [BackButton (-7, -9)] + | otherwise = [] + resetViewButton + | zoomFactor w /= 1 || panCenter w /= SP 0 0 = [ResetViewButton (9, -3)] + | otherwise = [] + +-- | Shows an animation, with a picture for each time given by the parameter. +-- +-- Example: a program showing a square which rotates once every two seconds +-- +-- @ +-- main = animationOf rotatingSquare +-- +-- rotatingSquare :: Double -> Picture +-- rotatingSquare seconds = rotated angle square +-- where +-- square = rectangle 2 2 +-- angle = pi * seconds +-- @ +animationOf :: + -- | A function that produces animation + -- frames, given the time in seconds. + (Double -> Picture) -> + IO () +animationOf f = do + hFlush stdout + runInspect + (wrappedInitial 0) + (wrappedStep (+)) + (wrappedEvent animationControls (+) (const id)) + (wrappedDraw animationControls f) + (f . state) + +simulationControls :: Wrapped w -> [Control w] +simulationControls w + | lastInteractionTime w > 5 = [] + | otherwise = commonControls ++ pauseDependentControls ++ resetViewButton + where + commonControls = + [ PanningLayer, + FastForwardButton (-4, -9), + SpeedSlider (-6, -9), + ZoomInButton (9, -4), + ZoomOutButton (9, -8), + ZoomSlider (9, -6) + ] + pauseDependentControls + | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-2, -9)] + | otherwise = [PauseButton (-8, -9)] + resetViewButton + | zoomFactor w /= 1 || panCenter w /= SP 0 0 = [ResetViewButton (9, -3)] + | otherwise = [] + +statefulDebugControls :: Wrapped (Timeline w) -> [Control (Timeline w)] +statefulDebugControls w + | lastInteractionTime w > 5 = [] + | otherwise = + panningLayer ++ pauseDependentControls ++ commonControls + ++ resetViewButton + where + hasHistory = not (null (past (state w))) + hasFuture = not (null (future (state w))) + advance + | hasFuture = [RedoButton (6, -9)] + | otherwise = [StepButton (6, -9)] + regress + | hasHistory = [UndoButton (0, -9)] + | otherwise = [] + commonControls = + [ StartOverButton (-1, -9), + FastForwardButton (-4, -9), + SpeedSlider (-6, -9), + ZoomInButton (9, -4), + ZoomOutButton (9, -8), + ZoomSlider (9, -6) + ] + pauseDependentControls + | playbackSpeed w == 0 = + [PlayButton (-8, -9), HistorySlider (3, -9)] ++ advance ++ regress + | otherwise = [PauseButton (-8, -9)] + resetViewButton + | zoomFactor w /= 1 || panCenter w /= SP 0 0 = [ResetViewButton (9, -3)] + | otherwise = [] + panningLayer + | playbackSpeed w == 0 = [PanningLayer] + | otherwise = [] + +-- | Shows a simulation, which is essentially a continuous-time dynamical +-- system described by an initial value and step function. +simulationOf :: + -- | The initial state of the simulation. + world -> + -- | The time step function, which advances + -- the state given the time difference. + (Double -> world -> world) -> + -- | The visualization function, which converts + -- the state into a picture to display. + (world -> Picture) -> + IO () +simulationOf initial step draw = do + hFlush stdout + runInspect + (wrappedInitial initial) + (wrappedStep step) + (wrappedEvent simulationControls step (const id)) + (wrappedDraw simulationControls draw) + (draw . state) +{-# WARNING + simulationOf + [ "Please use activityOf instead of simulationOf.", + "simulationOf may be removed July 2020." + ] + #-} + +debugSimulationOf :: + -- | The initial state of the simulation. + world -> + -- | The time step function, which advances + -- the state given the time difference. + (Double -> world -> world) -> + -- | The visualization function, which converts + -- the state into a picture to display. + (world -> Picture) -> + IO () +debugSimulationOf simInitial simStep simDraw = do + hFlush stdout + runInspect + (wrappedInitial initial) + (wrappedStep step) + (wrappedEvent statefulDebugControls step (const id)) + (wrappedDraw statefulDebugControls draw) + (draw . state) + where + initial = newTimeline simInitial + step = applyToTimeline . simStep + draw = simDraw . present +{-# WARNING + debugSimulationOf + [ "Please use debugActivityOf instead of debugSimulationOf.", + "debugSimulationOf may be removed July 2020." + ] + #-} + +debugInteractionOf :: + -- | The initial state of the interaction. + world -> + -- | The time step function, which advances + -- the state given the time difference. + (Double -> world -> world) -> + -- | The event handling function, which updates + -- the state given a user interface event. + (Event -> world -> world) -> + -- | The visualization function, which converts + -- the state into a picture to display. + (world -> Picture) -> + IO () +debugInteractionOf baseInitial baseStep baseEvent baseDraw = do + hFlush stdout + runInspect + (wrappedInitial initial) + (wrappedStep step) + (wrappedEvent statefulDebugControls step event) + (wrappedDraw statefulDebugControls draw) + (draw . state) + where + initial = newTimeline baseInitial + step = applyToTimeline . baseStep + event = applyToTimeline . baseEvent + draw = baseDraw . present +{-# WARNING + debugInteractionOf + [ "Please use debugActivityOf instead of debugInteractionOf.", + "debugInteractionOf may be removed July 2020." + ] + #-} + +-- | A version of 'activityOf' which 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 :: + -- | The initial state of the interaction. + world -> + -- | The event handling function, which updates + -- the state given an event. + (Event -> world -> world) -> + -- | The visualization function, which converts + -- the state into a picture to display. + (world -> Picture) -> + IO () +debugActivityOf initial change picture = + debugInteractionOf initial (const id) change picture + +-- | Runs an interactive multi-user CodeWorld program that is joined by several +-- participants over the internet. +-- +-- Example: a skeleton of a game for two players +-- +-- @ +-- {-\# LANGUAGE StaticPointers, OverloadedStrings \#-} +-- import CodeWorld +-- +-- main = groupActivityOf 2 init step view +-- where +-- init = static (\\gen -> {- initialize state of the game world, possibly using random number generator -}) +-- step = static (\\playerNumber event world -> {- modify world based on event occuring for given player -}) +-- view = static (\\playerNumber world -> {- generate a picture that will be shown to given player in the given state of the world-}) +-- @ +groupActivityOf :: + -- | The number of participants to expect. The participants will be + -- numbered starting at 0. + Int -> + -- | The function to create initial state of the activity. 'System.Random.StdGen' parameter can be used to generate random numbers. + StaticPtr (StdGen -> world) -> + -- | The event handling function, which updates the state given a + -- participant number and user interface event. + StaticPtr (Int -> Event -> world -> world) -> + -- | The visualization function, which converts a participant number + -- and the state into a picture to display. + StaticPtr (Int -> world -> Picture) -> + IO () +groupActivityOf numPlayers initial event draw = do + hFlush stdout + dhash <- getDeployHash + let token = + SteplessToken + { tokenDeployHash = dhash, + tokenNumPlayers = numPlayers, + tokenInitial = staticKey initial, + tokenEvent = staticKey event, + tokenDraw = staticKey draw + } + runGame + token + numPlayers + (deRefStaticPtr initial) + (const id) + (deRefStaticPtr event) + (deRefStaticPtr draw) + +-- | A version of 'groupActivityOf' that avoids static pointers, and does not +-- check for consistency. +unsafeGroupActivityOf :: + -- | The number of participants to expect. The participants will be + -- numbered starting at 0. + Int -> + -- | The initial state of the activity. + (StdGen -> world) -> + -- | The event handling function, which updates the state given a + -- participant number and user interface event. + (Int -> Event -> world -> world) -> + -- | The visualization function, which converts a participant number + -- and the state into a picture to display. + (Int -> world -> Picture) -> + IO () +unsafeGroupActivityOf numPlayers initial event draw = + unsafeCollaborationOf numPlayers initial (const id) event draw + +-- | A version of 'collaborationOf' that avoids static pointers, and does not +-- check for consistent parameters. +unsafeCollaborationOf :: + -- | The number of participants to expect. The participants will be + -- numbered starting at 0. + Int -> + -- | The initial state of the collaboration. + (StdGen -> world) -> + -- | The time step function, which advances the state given the time + -- difference. + (Double -> world -> world) -> + -- | The event handling function, which updates the state given a + -- participant number and user interface event. + (Int -> Event -> world -> world) -> + -- | The visualization function, which converts a participant number + -- and the state into a picture to display. + (Int -> world -> Picture) -> + IO () +unsafeCollaborationOf numPlayers initial step event draw = do + hFlush stdout + dhash <- getDeployHash + let token = PartialToken dhash + runGame token numPlayers initial step event draw +{-# WARNING + unsafeCollaborationOf + [ "Please use unsafeGroupActivityOf instead of unsafeCollaborationOf.", + "unsafeCollaborationOf may be removed July 2020." + ] + #-} + +-- | Runs an interactive multi-user CodeWorld program, involving multiple +-- participants over the internet. +collaborationOf :: + -- | The number of participants to expect. The participants will be + -- numbered starting at 0. + Int -> + -- | The initial state of the collaboration. + StaticPtr (StdGen -> world) -> + -- | The time step function, which advances the state given the time + -- difference. + StaticPtr (Double -> world -> world) -> + -- | The event handling function, which updates the state given a + -- participant number and user interface event. + StaticPtr (Int -> Event -> world -> world) -> + -- | The visualization function, which converts a participant number + -- and the state into a picture to display. + StaticPtr (Int -> world -> Picture) -> + IO () +collaborationOf numPlayers initial step event draw = do + hFlush stdout + dhash <- getDeployHash + let token = + FullToken + { tokenDeployHash = dhash, + tokenNumPlayers = numPlayers, + tokenInitial = staticKey initial, + tokenStep = staticKey step, + tokenEvent = staticKey event, + tokenDraw = staticKey draw + } + runGame + token + numPlayers + (deRefStaticPtr initial) + (deRefStaticPtr step) + (deRefStaticPtr event) + (deRefStaticPtr draw) +{-# WARNING + collaborationOf + [ "Please use groupActivityOf instead of collaborationOf.", + "collaborationOf may be removed July 2020." + ] + #-} + +-- | Prints a debug message to the CodeWorld console when a value is forced. +-- This is equivalent to the similarly named function in `Debug.Trace`, except +-- that it sets appropriate buffering to use the CodeWorld console. +trace :: Text -> a -> a +trace msg x = unsafePerformIO $ do + oldMode <- hGetBuffering stderr + hSetBuffering stderr (BlockBuffering Nothing) + hPutStrLn stderr (T.unpack msg) + hFlush stderr + hSetBuffering stderr oldMode + return x diff --git a/src/CodeWorld/Event.hs b/src/CodeWorld/Event.hs --- a/src/CodeWorld/Event.hs +++ b/src/CodeWorld/Event.hs @@ -20,46 +20,46 @@ import CodeWorld.Picture (Point) import Data.Text (Text) -{-| An event initiated by the user. - - Values of this type represent events that the user triggers when - using an interactive program. - - Key events describe the key as 'Text'. Most keys are represented - by a single character text string, with the capital letter or other - symbol from the key. Keys that don't correspond to a single - character use longer names from the following list. Keep in mind - that not all of these keys appear on all keyboards. - - * Up, Down, Left, and Right for the cursor keys. - * F1, F2, etc. for function keys. - * Backspace - * Tab - * Enter - * Shift - * Ctrl - * Alt - * Esc - * PageUp - * PageDown - * End - * Home - * Insert - * Delete - * CapsLock - * NumLock - * ScrollLock - * PrintScreen - * Break - * Separator - * Cancel - * Help --} +-- | An event initiated by the user. +-- +-- Values of this type represent events that the user triggers when +-- using an interactive program. +-- +-- Key events describe the key as 'Text'. Most keys are represented +-- by a single character text string, with the capital letter or other +-- symbol from the key. Keys that don't correspond to a single +-- character use longer names from the following list. Keep in mind +-- that not all of these keys appear on all keyboards. +-- +-- * Up, Down, Left, and Right for the cursor keys. +-- * F1, F2, etc. for function keys. +-- * Backspace +-- * Tab +-- * Enter +-- * Shift +-- * Ctrl +-- * Alt +-- * Esc +-- * PageUp +-- * PageDown +-- * End +-- * Home +-- * Insert +-- * Delete +-- * CapsLock +-- * NumLock +-- * ScrollLock +-- * PrintScreen +-- * Break +-- * Separator +-- * Cancel +-- * Help data Event - = KeyPress !Text - | KeyRelease !Text - | PointerPress !Point - | PointerRelease !Point - | PointerMovement !Point - | TimePassing !Double - deriving (Eq, Show, Read) + = KeyPress !Text + | KeyRelease !Text + | PointerPress !Point + | PointerRelease !Point + | PointerMovement !Point + | TextEntry !Text + | TimePassing !Double + deriving (Eq, Show, Read) diff --git a/src/CodeWorld/Picture.hs b/src/CodeWorld/Picture.hs --- a/src/CodeWorld/Picture.hs +++ b/src/CodeWorld/Picture.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {- Copyright 2019 The CodeWorld Authors. All rights reserved. @@ -18,13 +21,21 @@ module CodeWorld.Picture where import CodeWorld.Color +import Control.DeepSeq import Data.List import Data.Monoid ((<>)) -import Data.Text (Text, pack) +import Data.Text (Text) +import GHC.Generics (Generic) import GHC.Stack +import Util.EmbedAsUrl type Point = (Double, Double) +-- | Move given point by given X-axis and Y-axis offsets +-- >>> translatedPoint 1 2 (10,10) +-- (11.0,12.0) +-- >>> translatedPoint (-1) (-2) (0,0) +-- (-1.0,-2.0) translatedPoint :: Double -> Double -> Point -> Point translatedPoint tx ty (x, y) = (x + tx, y + ty) @@ -40,8 +51,17 @@ type Vector = (Double, Double) vectorLength :: Vector -> Double -vectorLength (x, y) = sqrt (x ^ 2 + y ^ 2) +vectorLength (x, y) = sqrt (x*x + y*y) +{-| Given vector, calculate angle in radians that it has with the X-axis. + +>>> vectorDirection (1,0) +0.0 +>>> vectorDirection (1,1) +0.7853981633974483 +>>> vectorDirection (0,1) +1.5707963267948966 +-} vectorDirection :: Vector -> Double vectorDirection (x, y) = atan2 y x @@ -54,7 +74,13 @@ scaledVector :: Double -> Vector -> Vector scaledVector k (x, y) = (k * x, k * y) -{-| Angle is in radians -} +{-| Rotate given vector by given angle in radians + +>>> rotatedVector pi (1.0, 0.0) +(-1.0,1.2246467991473532e-16) +>>> rotatedVector (pi / 2) (1.0, 0.0) +(6.123233995736766e-17,1.0) + -} rotatedVector :: Double -> Vector -> Vector rotatedVector angle (x, y) = (x * cos angle - y * sin angle, x * sin angle + y * cos angle) @@ -63,102 +89,60 @@ dotProduct (x1, y1) (x2, y2) = x1 * x2 + y1 * y2 data Picture - = SolidPolygon (Maybe SrcLoc) - [Point] - | SolidClosedCurve (Maybe SrcLoc) - [Point] - | Polygon (Maybe SrcLoc) - [Point] - | ThickPolygon (Maybe SrcLoc) - [Point] - !Double - | Rectangle (Maybe SrcLoc) - !Double - !Double - | SolidRectangle (Maybe SrcLoc) - !Double - !Double - | ThickRectangle (Maybe SrcLoc) - !Double - !Double - !Double - | ClosedCurve (Maybe SrcLoc) - [Point] - | ThickClosedCurve (Maybe SrcLoc) - [Point] - !Double - | Polyline (Maybe SrcLoc) - [Point] - | ThickPolyline (Maybe SrcLoc) - [Point] - !Double - | Curve (Maybe SrcLoc) - [Point] - | ThickCurve (Maybe SrcLoc) - [Point] - !Double - | Circle (Maybe SrcLoc) - !Double - | SolidCircle (Maybe SrcLoc) - !Double - | ThickCircle (Maybe SrcLoc) - !Double - !Double - | Sector (Maybe SrcLoc) - !Double - !Double - !Double - | Arc (Maybe SrcLoc) - !Double - !Double - !Double - | ThickArc (Maybe SrcLoc) - !Double - !Double - !Double - !Double - | StyledLettering (Maybe SrcLoc) - !TextStyle - !Font - !Text - | Lettering (Maybe SrcLoc) - !Text - | Color (Maybe SrcLoc) - !Color - !Picture - | Translate (Maybe SrcLoc) - !Double - !Double - !Picture - | Scale (Maybe SrcLoc) - !Double - !Double - !Picture - | Dilate (Maybe SrcLoc) - !Double - !Picture - | Rotate (Maybe SrcLoc) - !Double - !Picture + = SolidPolygon (Maybe SrcLoc) [Point] + | SolidClosedCurve (Maybe SrcLoc) [Point] + | Polygon (Maybe SrcLoc) [Point] + | ThickPolygon (Maybe SrcLoc) [Point] !Double + | Rectangle (Maybe SrcLoc) !Double !Double + | SolidRectangle (Maybe SrcLoc) !Double !Double + | ThickRectangle (Maybe SrcLoc) !Double !Double !Double + | ClosedCurve (Maybe SrcLoc) [Point] + | ThickClosedCurve (Maybe SrcLoc) [Point] !Double + | Polyline (Maybe SrcLoc) [Point] + | ThickPolyline (Maybe SrcLoc) [Point] !Double + | Curve (Maybe SrcLoc) [Point] + | ThickCurve (Maybe SrcLoc) [Point] !Double + | Circle (Maybe SrcLoc) !Double + | SolidCircle (Maybe SrcLoc) !Double + | ThickCircle (Maybe SrcLoc) !Double !Double + | Sector (Maybe SrcLoc) !Double !Double !Double + | Arc (Maybe SrcLoc) !Double !Double !Double + | ThickArc (Maybe SrcLoc) !Double !Double !Double !Double + | StyledLettering (Maybe SrcLoc) !TextStyle !Font !Text + | Lettering (Maybe SrcLoc) !Text + | Color (Maybe SrcLoc) !Color !Picture + | Translate (Maybe SrcLoc) !Double !Double !Picture + | Scale (Maybe SrcLoc) !Double !Double !Picture + | Dilate (Maybe SrcLoc) !Double !Picture + | Rotate (Maybe SrcLoc) !Double !Picture | CoordinatePlane (Maybe SrcLoc) - | Logo (Maybe SrcLoc) + | Sketch (Maybe SrcLoc) !Text !Text !Double !Double | Pictures (Maybe SrcLoc) [Picture] | PictureAnd (Maybe SrcLoc) [Picture] | Blank (Maybe SrcLoc) + deriving (Generic) +instance NFData Picture + data TextStyle = Plain | Bold - | Italic deriving (Show) + | Italic + deriving (Generic, Show) +instance NFData TextStyle + data Font = SansSerif | Serif | Monospace | Handwriting | Fancy - | NamedFont !Text deriving (Show) + | NamedFont !Text + deriving (Generic, Show) +instance NFData Font + -- | A blank picture blank :: HasCallStack => Picture blank = Blank (getDebugSrcLoc callStack) @@ -172,7 +156,7 @@ path ps = Polyline (getDebugSrcLoc callStack) ps {-# WARNING path ["Please use polyline instead of path.", - "path may be removed July 2019."] #-} + "path may be removed July 2020."] #-} -- | A thick sequence of line segments, with given line width and endpoints thickPolyline :: HasCallStack => Double -> [Point] -> Picture @@ -183,7 +167,7 @@ thickPath n ps = ThickPolyline (getDebugSrcLoc callStack) ps n {-# WARNING thickPath ["Please used thickPolyline instead of thickPath.", - "thickPath may be removed July 2019."] #-} + "thickPath may be removed July 2020."] #-} -- | A thin polygon with these points as vertices polygon :: HasCallStack => [Point] -> Picture @@ -235,7 +219,7 @@ -- | A thin circle, with this radius circle :: HasCallStack => Double -> Picture -circle = Circle (getDebugSrcLoc callStack) +circle = Circle (getDebugSrcLoc callStack) -- | A thick circle, with this line width and radius thickCircle :: HasCallStack => Double -> Double -> Picture @@ -256,7 +240,7 @@ -- | A solid circle, with this radius solidCircle :: HasCallStack => Double -> Picture -solidCircle = SolidCircle (getDebugSrcLoc callStack) +solidCircle = SolidCircle (getDebugSrcLoc callStack) -- | A solid sector of a circle (i.e., a pie slice) starting and ending at these -- angles, with this radius @@ -270,7 +254,7 @@ text = Lettering (getDebugSrcLoc callStack) {-# WARNING text ["Please used lettering instead of text.", - "text may be removed July 2019."] #-} + "text may be removed July 2020."] #-} -- | A rendering of text characters. lettering :: HasCallStack => Text -> Picture @@ -281,7 +265,7 @@ styledText = StyledLettering (getDebugSrcLoc callStack) {-# WARNING styledText ["Please used styledLettering instead of styledText.", - "styledText may be removed July 2019."] #-} + "styledText may be removed July 2020."] #-} -- | A rendering of text characters onto a Picture, with a specific -- choice of font and style. @@ -300,11 +284,11 @@ translated :: HasCallStack => Double -> Double -> Picture -> Picture translated = Translate (getDebugSrcLoc callStack) --- | A picture scaled by these factors. +-- | A picture scaled by these factors in the x and y directions. scaled :: HasCallStack => Double -> Double -> Picture -> Picture scaled = Scale (getDebugSrcLoc callStack) --- | A picture scaled by these factors. +-- | A picture scaled uniformly in all directions by this scale factor. dilated :: HasCallStack => Double -> Picture -> Picture dilated = Dilate (getDebugSrcLoc callStack) @@ -322,7 +306,7 @@ (&) :: HasCallStack => Picture -> Picture -> Picture infixr 0 & -a & b@(PictureAnd loc2 bs) +a & PictureAnd loc2 bs | srcContains loc1 loc2 = PictureAnd loc1 (a:bs) where loc1 = getDebugSrcLoc callStack a & b = PictureAnd (getDebugSrcLoc callStack) [a, b] @@ -343,15 +327,21 @@ -- more accurately. -- -- Example: --- --- main = drawingOf (myPicture <> coordinatePlane) --- myPicture = ... +-- @ +-- main = drawingOf (myPicture <> coordinatePlane) +-- myPicture = ... +-- @ coordinatePlane :: HasCallStack => Picture coordinatePlane = CoordinatePlane (getDebugSrcLoc callStack) -- | The CodeWorld logo. codeWorldLogo :: HasCallStack => Picture -codeWorldLogo = Logo (getDebugSrcLoc callStack) +codeWorldLogo = + Sketch + (getDebugSrcLoc callStack) + "codeWorldLogo" + $(embedAsUrl "image/svg+xml" "data/codeworld.svg") + 17.68 7.28 getDebugSrcLoc :: CallStack -> Maybe SrcLoc getDebugSrcLoc cs = Data.List.find ((== "main") . srcLocPackage) locs diff --git a/src/CodeWorld/Reflex.hs b/src/CodeWorld/Reflex.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/Reflex.hs @@ -0,0 +1,620 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +{- + Copyright 2019 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 for using CodeWorld pictures in Reflex-based FRP applications. +module CodeWorld.Reflex + ( -- $intro + -- $old + reflexOf, + ReactiveInput, + keyPress, + keyRelease, + textEntry, + pointerPress, + pointerRelease, + pointerPosition, + pointerDown, + timePassing, + + -- * New Entry Point + -- $new + reactiveOf, + debugReactiveOf, + ReflexCodeWorld, + getKeyPress, + getKeyRelease, + getTextEntry, + getPointerClick, + getPointerPosition, + isPointerDown, + getTimePassing, + draw, + + -- * Pictures + Picture, + blank, + polyline, + thickPolyline, + polygon, + thickPolygon, + solidPolygon, + curve, + thickCurve, + closedCurve, + thickClosedCurve, + solidClosedCurve, + rectangle, + solidRectangle, + thickRectangle, + circle, + solidCircle, + thickCircle, + arc, + sector, + thickArc, + lettering, + TextStyle (..), + Font (..), + styledLettering, + colored, + coloured, + translated, + scaled, + dilated, + rotated, + pictures, + (<>), + (&), + coordinatePlane, + codeWorldLogo, + Point, + translatedPoint, + rotatedPoint, + scaledPoint, + dilatedPoint, + Vector, + vectorLength, + vectorDirection, + vectorSum, + vectorDifference, + scaledVector, + rotatedVector, + dotProduct, + + -- * Colors + Color (..), + Colour, + pattern RGB, + pattern HSL, + black, + white, + red, + green, + blue, + yellow, + orange, + brown, + pink, + purple, + gray, + grey, + mixed, + lighter, + light, + darker, + dark, + brighter, + bright, + duller, + dull, + translucent, + assortedColors, + hue, + saturation, + luminosity, + alpha, + ) +where + +import CodeWorld.Color +import CodeWorld.Driver +import CodeWorld.Picture +import Control.Monad.Fix +import Control.Monad.Trans +import Data.Bool +import qualified Data.Text as T +import Numeric (showFFloatAlt) +import Reflex + +-- $intro +-- = Using Reflex with CodeWorld +-- +-- This is an alternative to the standard CodeWorld API, which is based on +-- the Reflex library. You should import this __instead__ of 'CodeWorld', since +-- the 'CodeWorld' module exports conflict with Reflex names. +-- +-- You'll provide a function whose input can be used to access the user's +-- actions with keys, the mouse pointer, and time, and whose output is a +-- 'Picture'. The 'Picture' value is built with the same combinators as the +-- main 'CodeWorld' library. +-- +-- The Reflex API is documented in many places, but a great reference is +-- available in the . + +-- $old +-- +-- The old API consists of the function `reflexOf`. WARNING: This API will soon +-- be deleted in favor of the newer API described below. +-- +-- A simple example: +-- +-- @ +-- import CodeWorld.Reflex +-- import Reflex +-- +-- main :: IO () +-- main = reflexOf $ \\input -> do +-- angle <- foldDyn (+) 0 (gate (current (pointerDown input)) (timePassing input)) +-- return $ (uncurry translated \<$> pointerPosition input \<*>) +-- $ (colored \<$> bool red green \<$> pointerDown input \<*>) +-- $ (rotated \<$> angle \<*>) +-- $ constDyn (solidRectangle 2 2) +-- @ + +-- | The entry point for running Reflex-based CodeWorld programs. +reflexOf :: + ( forall t m. + ( Reflex t, + MonadHold t m, + MonadFix m, + PerformEvent t m, + MonadIO (Performable m), + Adjustable t m, + PostBuild t m + ) => + ReactiveInput t -> + m (Dynamic t Picture) + ) -> + IO () +reflexOf program = runReactive $ \input -> do + pic <- program input + return (pic, pic) +{-# WARNING + reflexOf + [ "Please use reactiveOf instead of reflexOf.", + "reflexOf will be removed and replaced soon." + ] + #-} + +reactiveOf :: (forall t m. ReflexCodeWorld t m => m ()) -> IO () +reactiveOf program = runReactive $ \input -> runReactiveProgram program input +{-# WARNING + reactiveOf + [ "After the current migration is complete,", + "reactiveOf will probably be renamed to reflexOf." + ] + #-} + +debugReactiveOf :: (forall t m. ReflexCodeWorld t m => m ()) -> IO () +debugReactiveOf program = runReactive $ \input -> flip runReactiveProgram input $ do + hoverAlpha <- getHoverAlpha + controlState <- reactiveDebugControls hoverAlpha + logicalInputs <- makeLogicalInputs controlState =<< getReactiveInput + withReactiveInput logicalInputs program + +data ControlState t + = ControlState + { csRunning :: Dynamic t Bool, + csTimeDilation :: Dynamic t Double, + csPointTransform :: Dynamic t (Point -> Point), + csSyntheticStep :: Event t () + } + +makeLogicalInputs :: (Reflex t, MonadHold t m) => ControlState t -> ReactiveInput t -> m (ReactiveInput t) +makeLogicalInputs ControlState {..} input = do + keyPress <- return $ gateDyn csRunning $ keyPress input + keyRelease <- return $ gateDyn csRunning $ keyRelease input + textEntry <- return $ gateDyn csRunning $ textEntry input + pointerPress <- return $ gateDyn csRunning $ attachWith ($) (current csPointTransform) (pointerPress input) + pointerRelease <- return $ gateDyn csRunning $ attachWith ($) (current csPointTransform) (pointerRelease input) + pointerPosition <- freezeDyn csRunning $ csPointTransform <*> pointerPosition input + pointerDown <- freezeDyn csRunning $ pointerDown input + timePassing <- + return $ + mergeWith + (+) + [ gateDyn csRunning $ attachWith (*) (current csTimeDilation) (timePassing input), + 0.1 <$ csSyntheticStep + ] + return ReactiveInput {..} + +freezeDyn :: (Reflex t, MonadHold t m) => Dynamic t Bool -> Dynamic t a -> m (Dynamic t a) +freezeDyn predicate dyn = do + initial <- sample (current dyn) + holdDyn initial (gateDyn predicate (updated dyn)) + +reactiveDebugControls :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + ReactiveProgram t m (ControlState t) +reactiveDebugControls hoverAlpha = do + fastForwardClick <- fastForwardButton hoverAlpha (-4, -9) + rec speedDragged <- speedSlider hoverAlpha (-6, -9) speedFactor + playPauseClick <- playPauseButton hoverAlpha running (-8, -9) + speedFactor <- + foldDyn ($) 1 $ + mergeWith + (.) + [ (\s -> if s == 0 then 1 else 0) <$ playPauseClick, + (\s -> max 2.0 (s + 1)) <$ fastForwardClick, + const <$> speedDragged + ] + let running = (> 0) <$> speedFactor + rec resetViewClick <- resetViewButton hoverAlpha (9, -3) needsReset + zoomFactor <- zoomControls hoverAlpha (9, -6) resetViewClick + panOffset <- panControls running resetViewClick + let needsReset = + (||) <$> ((/= 1) <$> zoomFactor) + <*> ((/= (0, 0)) <$> panOffset) + stepClick <- stepButton hoverAlpha (-2, -9) running + transformUserPicture $ uncurry translated <$> panOffset + transformUserPicture $ dilated <$> zoomFactor + return $ ControlState + { csRunning = running, + csTimeDilation = speedFactor, + csPointTransform = transformPoint <$> zoomFactor <*> panOffset, + csSyntheticStep = stepClick + } + where + transformPoint z (dx, dy) (x, y) = ((x - dx) / z, (y - dy) / z) + +{-# WARNING + debugReactiveOf + [ "After the current migration is complete,", + "debugReactiveOf will probably be renamed to debugReflexOf." + ] + #-} + +getHoverAlpha :: ReflexCodeWorld t m => m (Dynamic t Double) +getHoverAlpha = do + time <- getTimePassing + move <- updated <$> getPointerPosition + rec timeSinceMove <- + foldDyn ($) 999 $ + mergeWith + (.) + [ (+) <$> gateDyn ((< 5) <$> timeSinceMove) time, + const 0 <$ move + ] + return (alphaFromTime <$> timeSinceMove) + where + alphaFromTime t + | t < 4.5 = 1 + | t > 5.0 = 0 + | otherwise = 10 - 2 * t + +playPauseButton :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + Dynamic t Bool -> + Point -> + ReactiveProgram t m (Event t ()) +playPauseButton hoverAlpha running pos = do + systemDraw $ + uncurry translated pos + <$> (bool (playButton <$> hoverAlpha) (pauseButton <$> hoverAlpha) =<< running) + click <- ffilter (onRect 0.8 0.8 pos) <$> getPointerClick + return $ () <$ click + where + playButton a = + colored + (RGBA 0 0 0 a) + (solidPolygon [(-0.2, 0.25), (-0.2, -0.25), (0.2, 0)]) + <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 0.8) + pauseButton a = + colored + (RGBA 0 0 0 a) + ( translated (-0.15) 0 (solidRectangle 0.2 0.6) + <> translated 0.15 0 (solidRectangle 0.2 0.6) + ) + <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 0.8) + +stepButton :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + Point -> + Dynamic t Bool -> + ReactiveProgram t m (Event t ()) +stepButton hoverAlpha pos running = do + systemDraw $ + uncurry translated pos + <$> (bool (button <$> hoverAlpha) (constDyn blank) =<< running) + click <- gateDyn (not <$> running) <$> ffilter (onRect 0.8 0.8 pos) <$> getPointerClick + return $ () <$ click + where + button a = + colored + (RGBA 0 0 0 a) + ( 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 a) (rectangle 0.8 0.8) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 0.8) + +fastForwardButton :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + Point -> + ReactiveProgram t m (Event t ()) +fastForwardButton hoverAlpha pos = do + systemDraw $ uncurry translated pos <$> button <$> hoverAlpha + click <- ffilter (onRect 0.8 0.8 pos) <$> getPointerClick + return $ () <$ click + where + button a = + colored + (RGBA 0 0 0 a) + ( solidPolygon [(-0.3, 0.25), (-0.3, -0.25), (-0.05, 0)] + <> solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)] + ) + <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 0.8) + +speedSlider :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + Point -> + Dynamic t Double -> + ReactiveProgram t m (Event t Double) +speedSlider hoverAlpha pos speedFactor = do + systemDraw $ uncurry translated pos <$> (slider <$> hoverAlpha <*> speedFactor) + click <- ffilter (onRect 3.0 0.8 pos) <$> getPointerClick + release <- ffilter not <$> updated <$> isPointerDown + dragging <- holdDyn False $ mergeWith (&&) [True <$ click, False <$ release] + pointer <- getPointerPosition + return $ speedFromPoint <$> mergeWith const [gateDyn dragging (updated pointer), click] + where + speedFromPoint (x, _y) = scaleRange (-1.4, 1.4) (0, 5) (x - fst pos) + xFromSpeed speed = scaleRange (0, 5) (-1.4, 1.4) speed + slider a speed = + let xoff = xFromSpeed speed + in colored + (RGBA 0 0 0 a) + ( translated xoff 0.75 $ scaled 0.5 0.5 $ + lettering (T.pack (showFFloatAlt (Just 2) speed "x")) + ) + <> colored (RGBA 0 0 0 a) (translated xoff 0 (solidRectangle 0.2 0.8)) + <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 2.8 0.25) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 2.8 0.25) + +resetViewButton :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + Point -> + Dynamic t Bool -> + ReactiveProgram t m (Event t ()) +resetViewButton hoverAlpha pos needsReset = do + click <- gateDyn needsReset . ffilter (onRect 0.8 0.8 pos) <$> getPointerClick + systemDraw $ uncurry translated pos <$> (bool (constDyn blank) (button <$> hoverAlpha) =<< needsReset) + return $ () <$ click + where + button a = + colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.7 0.2) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.2 0.7) + <> colored (RGBA 0.0 0.0 0.0 a) (thickRectangle 0.1 0.5 0.5) + <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 0.8) + +panControls :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Bool -> + Event t () -> + ReactiveProgram t m (Dynamic t (Double, Double)) +panControls running resetClick = do + click <- gateDyn (not <$> running) <$> getPointerClick + release <- ffilter not <$> updated <$> isPointerDown + dragging <- holdDyn False $ mergeWith (&&) [True <$ click, False <$ release] + pos <- getPointerPosition + let dragPos = bool (const Nothing) Just <$> dragging <*> pos + diffPairs <- foldDyn (\x (y, _) -> (x, y)) (Nothing, Nothing) (updated dragPos) + let drags = fmapMaybe toMovement (updated diffPairs) + foldDyn ($) (0, 0) $ + mergeWith + (.) + [ vectorSum <$> drags, + const (0, 0) <$ resetClick + ] + where + toMovement (Just (x1, y1), Just (x2, y2)) = Just (x1 - x2, y1 - y2) + toMovement _ = Nothing + +zoomControls :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + Point -> + Event t () -> + ReactiveProgram t m (Dynamic t Double) +zoomControls hoverAlpha (x, y) resetClick = do + zoomInClick <- zoomInButton hoverAlpha (x, y + 2) + zoomOutClick <- zoomOutButton hoverAlpha (x, y - 2) + rec zoomDrag <- zoomSlider hoverAlpha (x, y) zoomFactor + zoomFactor <- + foldDyn ($) 1 $ + mergeWith + (.) + [ (* zoomIncrement) <$ zoomInClick, + (/ zoomIncrement) <$ zoomOutClick, + const <$> zoomDrag, + const 1 <$ resetClick + ] + return zoomFactor + +zoomInButton :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + Point -> + ReactiveProgram t m (Event t ()) +zoomInButton hoverAlpha pos = do + systemDraw $ uncurry translated pos <$> button <$> hoverAlpha + (() <$) <$> ffilter (onRect 0.8 0.8 pos) <$> getPointerClick + where + button a = + colored + (RGBA 0 0 0 a) + ( translated + (-0.05) + (0.05) + ( thickCircle 0.1 0.22 + <> solidRectangle 0.06 0.25 + <> solidRectangle 0.25 0.06 + <> rotated (- pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1)) + ) + ) + <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 0.8) + +zoomOutButton :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + Point -> + ReactiveProgram t m (Event t ()) +zoomOutButton hoverAlpha pos = do + systemDraw $ uncurry translated pos <$> button <$> hoverAlpha + (() <$) <$> ffilter (onRect 0.8 0.8 pos) <$> getPointerClick + where + button a = + colored + (RGBA 0 0 0 a) + ( translated + (-0.05) + (0.05) + ( thickCircle 0.1 0.22 + <> solidRectangle 0.25 0.06 + <> rotated (- pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1)) + ) + ) + <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 0.8) + +zoomSlider :: + ( PerformEvent t m, + Adjustable t m, + MonadIO (Performable m), + PostBuild t m, + MonadHold t m, + MonadFix m + ) => + Dynamic t Double -> + Point -> + Dynamic t Double -> + ReactiveProgram t m (Event t Double) +zoomSlider hoverAlpha pos factor = do + systemDraw $ uncurry translated pos <$> (slider <$> hoverAlpha <*> factor) + click <- ffilter (onRect 0.8 3.0 pos) <$> getPointerClick + release <- ffilter not <$> updated <$> isPointerDown + dragging <- holdDyn False $ mergeWith (&&) [True <$ click, False <$ release] + pointer <- getPointerPosition + return $ zoomFromPoint <$> mergeWith const [gateDyn dragging (updated pointer), click] + where + zoomFromPoint (_x, y) = zoomIncrement ** (scaleRange (-1.4, 1.4) (-10, 10) (y - snd pos)) + yFromZoom z = scaleRange (-10, 10) (-1.4, 1.4) (logBase zoomIncrement z) + slider a z = + let yoff = yFromZoom z + in colored + (RGBA 0 0 0 a) + ( translated (-1.1) yoff $ scaled 0.5 0.5 $ + lettering (T.pack (show (round (z * 100) :: Int) ++ "%")) + ) + <> colored (RGBA 0 0 0 a) (translated 0 yoff (solidRectangle 0.8 0.2)) + <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.25 2.8) + <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.25 2.8) + +zoomIncrement :: Double +zoomIncrement = 8 ** (1 / 10) + +onRect :: Double -> Double -> Point -> Point -> Bool +onRect w h (x1, y1) (x2, y2) = abs (x1 - x2) < w / 2 && abs (y1 - y2) < h / 2 + +scaleRange :: (Double, Double) -> (Double, Double) -> Double -> Double +scaleRange (a1, b1) (a2, b2) x = min b2 $ max a2 $ (x - a1) / (b1 - a1) * (b2 - a2) + a2 diff --git a/src/CodeWorld/Sketches.hs b/src/CodeWorld/Sketches.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/Sketches.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{- + Copyright 2019 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.Sketches where + +import CodeWorld.Picture +import GHC.Stack +import Util.EmbedAsUrl + +sketchedAirplane :: HasCallStack => Picture +sketchedAirplane = + Sketch + (getDebugSrcLoc callStack) + "sketchedAirplane" + $(embedAsUrl "image/svg+xml" "data/AirplaneTransparency70.svg") + 10 + 10 + +sketchedClock :: HasCallStack => Picture +sketchedClock = + Sketch + (getDebugSrcLoc callStack) + "sketchedClock" + $(embedAsUrl "image/svg+xml" "data/AlarmTransparency70.svg") + 10 + 10 + +sketchedAlien :: HasCallStack => Picture +sketchedAlien = + Sketch + (getDebugSrcLoc callStack) + "sketchedAlien" + $(embedAsUrl "image/svg+xml" "data/AlienTransparency70.svg") + 10 + 10 + +sketchedApple :: HasCallStack => Picture +sketchedApple = + Sketch + (getDebugSrcLoc callStack) + "sketchedApple" + $(embedAsUrl "image/svg+xml" "data/AppleTransparency70.svg") + 10 + 10 + +sketchedAstronaut :: HasCallStack => Picture +sketchedAstronaut = + Sketch + (getDebugSrcLoc callStack) + "sketchedAstronaut" + $(embedAsUrl "image/svg+xml" "data/AustronautTransparency70.svg") + 10 + 10 + +sketchedBaby :: HasCallStack => Picture +sketchedBaby = + Sketch + (getDebugSrcLoc callStack) + "sketchedBaby" + $(embedAsUrl "image/svg+xml" "data/BabyTransparency70.svg") + 10 + 10 + +sketchedBalloon :: HasCallStack => Picture +sketchedBalloon = + Sketch + (getDebugSrcLoc callStack) + "sketchedBalloon" + $(embedAsUrl "image/svg+xml" "data/BalloonTransparency70.svg") + 10 + 10 + +sketchedBall :: HasCallStack => Picture +sketchedBall = + Sketch + (getDebugSrcLoc callStack) + "sketchedBall" + $(embedAsUrl "image/svg+xml" "data/BallTransparency70.svg") + 10 + 10 + +sketchedBell :: HasCallStack => Picture +sketchedBell = + Sketch + (getDebugSrcLoc callStack) + "sketchedBell" + $(embedAsUrl "image/svg+xml" "data/BellTransparency70.svg") + 10 + 10 + +sketchedBird :: HasCallStack => Picture +sketchedBird = + Sketch + (getDebugSrcLoc callStack) + "sketchedBird" + $(embedAsUrl "image/svg+xml" "data/BirdTransparency70.svg") + 10 + 10 + +sketchedBoat :: HasCallStack => Picture +sketchedBoat = + Sketch + (getDebugSrcLoc callStack) + "sketchedBoat" + $(embedAsUrl "image/svg+xml" "data/BoatTransparency70.svg") + 10 + 10 + +sketchedBook :: HasCallStack => Picture +sketchedBook = + Sketch + (getDebugSrcLoc callStack) + "sketchedBook" + $(embedAsUrl "image/svg+xml" "data/BookTransparency70.svg") + 10 + 10 + +sketchedBoy :: HasCallStack => Picture +sketchedBoy = + Sketch + (getDebugSrcLoc callStack) + "sketchedBoy" + $(embedAsUrl "image/svg+xml" "data/BoyTransparency70.svg") + 10 + 10 + +sketchedBubble :: HasCallStack => Picture +sketchedBubble = + Sketch + (getDebugSrcLoc callStack) + "sketchedBubble" + $(embedAsUrl "image/svg+xml" "data/BubbleTransparency70.svg") + 10 + 10 + +sketchedBug :: HasCallStack => Picture +sketchedBug = + Sketch + (getDebugSrcLoc callStack) + "sketchedBug" + $(embedAsUrl "image/svg+xml" "data/BugTransparency70.svg") + 10 + 10 + +sketchedCar :: HasCallStack => Picture +sketchedCar = + Sketch + (getDebugSrcLoc callStack) + "sketchedCar" + $(embedAsUrl "image/svg+xml" "data/CarTransparency70.svg") + 10 + 10 + +sketchedChatBubble :: HasCallStack => Picture +sketchedChatBubble = + Sketch + (getDebugSrcLoc callStack) + "sketchedChatBubble" + $(embedAsUrl "image/svg+xml" "data/ChatBubbleTransparency70.svg") + 10 + 10 + +sketchedChest :: HasCallStack => Picture +sketchedChest = + Sketch + (getDebugSrcLoc callStack) + "sketchedChest" + $(embedAsUrl "image/svg+xml" "data/ChestTransparency70.svg") + 10 + 10 + +sketchedCloud :: HasCallStack => Picture +sketchedCloud = + Sketch + (getDebugSrcLoc callStack) + "sketchedCloud" + $(embedAsUrl "image/svg+xml" "data/CloudTransparency70.svg") + 10 + 10 + +sketchedCoin :: HasCallStack => Picture +sketchedCoin = + Sketch + (getDebugSrcLoc callStack) + "sketchedCoin" + $(embedAsUrl "image/svg+xml" "data/CoinTransparency70.svg") + 10 + 10 + +sketchedDog :: HasCallStack => Picture +sketchedDog = + Sketch + (getDebugSrcLoc callStack) + "sketchedDog" + $(embedAsUrl "image/svg+xml" "data/DogTransparency70.svg") + 10 + 10 + +sketchedDragon :: HasCallStack => Picture +sketchedDragon = + Sketch + (getDebugSrcLoc callStack) + "sketchedDragon" + $(embedAsUrl "image/svg+xml" "data/DragonTransparency70.svg") + 10 + 10 + +sketchedExplosion :: HasCallStack => Picture +sketchedExplosion = + Sketch + (getDebugSrcLoc callStack) + "sketchedExplosion" + $(embedAsUrl "image/svg+xml" "data/ExplosionTransparency70.svg") + 10 + 10 + +sketchedFish :: HasCallStack => Picture +sketchedFish = + Sketch + (getDebugSrcLoc callStack) + "sketchedFish" + $(embedAsUrl "image/svg+xml" "data/FishTransparency70.svg") + 10 + 10 + +sketchedFlag :: HasCallStack => Picture +sketchedFlag = + Sketch + (getDebugSrcLoc callStack) + "sketchedFlag" + $(embedAsUrl "image/svg+xml" "data/FlagTransparency70.svg") + 10 + 10 + +sketchedFlame :: HasCallStack => Picture +sketchedFlame = + Sketch + (getDebugSrcLoc callStack) + "sketchedFlame" + $(embedAsUrl "image/svg+xml" "data/FlameTransparency70.svg") + 10 + 10 + +sketchedFlower :: HasCallStack => Picture +sketchedFlower = + Sketch + (getDebugSrcLoc callStack) + "sketchedFlower" + $(embedAsUrl "image/svg+xml" "data/FlowerTransparency70.svg") + 10 + 10 + +sketchedGear :: HasCallStack => Picture +sketchedGear = + Sketch + (getDebugSrcLoc callStack) + "sketchedGear" + $(embedAsUrl "image/svg+xml" "data/GearTransparency70.svg") + 10 + 10 + +sketchedGhost :: HasCallStack => Picture +sketchedGhost = + Sketch + (getDebugSrcLoc callStack) + "sketchedGhost" + $(embedAsUrl "image/svg+xml" "data/GhostTransparency70.svg") + 10 + 10 + +sketchedGirl :: HasCallStack => Picture +sketchedGirl = + Sketch + (getDebugSrcLoc callStack) + "sketchedGirl" + $(embedAsUrl "image/svg+xml" "data/GirlTransparency70.svg") + 10 + 10 + +sketchedGrass :: HasCallStack => Picture +sketchedGrass = + Sketch + (getDebugSrcLoc callStack) + "sketchedGrass" + $(embedAsUrl "image/svg+xml" "data/GrassTransparency70.svg") + 10 + 10 + +sketchedHeart :: HasCallStack => Picture +sketchedHeart = + Sketch + (getDebugSrcLoc callStack) + "sketchedHeart" + $(embedAsUrl "image/svg+xml" "data/HeartTransparency70.svg") + 10 + 10 + +sketchedHotAirBalloon :: HasCallStack => Picture +sketchedHotAirBalloon = + Sketch + (getDebugSrcLoc callStack) + "sketchedHotAirBalloon" + $(embedAsUrl "image/svg+xml" "data/HotAirBalloonTransparency70.svg") + 10 + 10 + +sketchedHouse :: HasCallStack => Picture +sketchedHouse = + Sketch + (getDebugSrcLoc callStack) + "sketchedHouse" + $(embedAsUrl "image/svg+xml" "data/HouseTransparency70.svg") + 10 + 10 + +sketchedJewel :: HasCallStack => Picture +sketchedJewel = + Sketch + (getDebugSrcLoc callStack) + "sketchedJewel" + $(embedAsUrl "image/svg+xml" "data/JewelTransparency70.svg") + 10 + 10 + +sketchedKey :: HasCallStack => Picture +sketchedKey = + Sketch + (getDebugSrcLoc callStack) + "sketchedKey" + $(embedAsUrl "image/svg+xml" "data/KeyTransparency70.svg") + 10 + 10 + +sketchedCat :: HasCallStack => Picture +sketchedCat = + Sketch + (getDebugSrcLoc callStack) + "sketchedCat" + $(embedAsUrl "image/svg+xml" "data/KittenTransparency70.svg") + 10 + 10 + +sketchedLightBulb :: HasCallStack => Picture +sketchedLightBulb = + Sketch + (getDebugSrcLoc callStack) + "sketchedLightBulb" + $(embedAsUrl "image/svg+xml" "data/LightbulbTransparency70.svg") + 10 + 10 + +sketchedLightning :: HasCallStack => Picture +sketchedLightning = + Sketch + (getDebugSrcLoc callStack) + "sketchedLightning" + $(embedAsUrl "image/svg+xml" "data/LightningTransparency70.svg") + 10 + 10 + +sketchedMonster :: HasCallStack => Picture +sketchedMonster = + Sketch + (getDebugSrcLoc callStack) + "sketchedMonster" + $(embedAsUrl "image/svg+xml" "data/MonsterTransparency70.svg") + 10 + 10 + +sketchedMoon :: HasCallStack => Picture +sketchedMoon = + Sketch + (getDebugSrcLoc callStack) + "sketchedMoon" + $(embedAsUrl "image/svg+xml" "data/MoonTransparency70.svg") + 10 + 10 + +sketchedNote :: HasCallStack => Picture +sketchedNote = + Sketch + (getDebugSrcLoc callStack) + "sketchedNote" + $(embedAsUrl "image/svg+xml" "data/NoteTransparency70.svg") + 10 + 10 + +sketchedPawnBlack :: HasCallStack => Picture +sketchedPawnBlack = + Sketch + (getDebugSrcLoc callStack) + "sketchedPawnBlack" + $(embedAsUrl "image/svg+xml" "data/PawnBlackTransparency70.svg") + 10 + 10 + +sketchedPawnBlue :: HasCallStack => Picture +sketchedPawnBlue = + Sketch + (getDebugSrcLoc callStack) + "sketchedPawnBlue" + $(embedAsUrl "image/svg+xml" "data/PawnBlueTransparency70.svg") + 10 + 10 + +sketchedPawnGreen :: HasCallStack => Picture +sketchedPawnGreen = + Sketch + (getDebugSrcLoc callStack) + "sketchedPawnGreen" + $(embedAsUrl "image/svg+xml" "data/PawnGreenTransparency70.svg") + 10 + 10 + +sketchedPawnRed :: HasCallStack => Picture +sketchedPawnRed = + Sketch + (getDebugSrcLoc callStack) + "sketchedPawnRed" + $(embedAsUrl "image/svg+xml" "data/PawnRedTransparency70.svg") + 10 + 10 + +sketchedPawnWhite :: HasCallStack => Picture +sketchedPawnWhite = + Sketch + (getDebugSrcLoc callStack) + "sketchedPawnWhite" + $(embedAsUrl "image/svg+xml" "data/PawnWhiteTransparency70.svg") + 10 + 10 + +sketchedRaindrop :: HasCallStack => Picture +sketchedRaindrop = + Sketch + (getDebugSrcLoc callStack) + "sketchedRaindrop" + $(embedAsUrl "image/svg+xml" "data/RaindropTransparency70.svg") + 10 + 10 + +sketchedRobot :: HasCallStack => Picture +sketchedRobot = + Sketch + (getDebugSrcLoc callStack) + "sketchedRobot" + $(embedAsUrl "image/svg+xml" "data/RobotTransparency70.svg") + 10 + 10 + +sketchedRocket :: HasCallStack => Picture +sketchedRocket = + Sketch + (getDebugSrcLoc callStack) + "sketchedRocket" + $(embedAsUrl "image/svg+xml" "data/RocketShipTransparency70.svg") + 10 + 10 + +sketchedScroll :: HasCallStack => Picture +sketchedScroll = + Sketch + (getDebugSrcLoc callStack) + "sketchedScroll" + $(embedAsUrl "image/svg+xml" "data/ScrollTransparency70.svg") + 10 + 10 + +sketchedSign :: HasCallStack => Picture +sketchedSign = + Sketch + (getDebugSrcLoc callStack) + "sketchedSign" + $(embedAsUrl "image/svg+xml" "data/SignTransparency70.svg") + 10 + 10 + +sketchedSparkle :: HasCallStack => Picture +sketchedSparkle = + Sketch + (getDebugSrcLoc callStack) + "sketchedSparkle" + $(embedAsUrl "image/svg+xml" "data/SparklesTransparency70.svg") + 10 + 10 + +sketchedStar :: HasCallStack => Picture +sketchedStar = + Sketch + (getDebugSrcLoc callStack) + "sketchedStar" + $(embedAsUrl "image/svg+xml" "data/StarTransparency70.svg") + 10 + 10 + +sketchedSun :: HasCallStack => Picture +sketchedSun = + Sketch + (getDebugSrcLoc callStack) + "sketchedSun" + $(embedAsUrl "image/svg+xml" "data/SunTransparency70.svg") + 10 + 10 + +sketchedThoughtBubble :: HasCallStack => Picture +sketchedThoughtBubble = + Sketch + (getDebugSrcLoc callStack) + "sketchedThoughtBubble" + $(embedAsUrl "image/svg+xml" "data/ThoughtBubbleTransparency70.svg") + 10 + 10 + +sketchedBlock :: HasCallStack => Picture +sketchedBlock = + Sketch + (getDebugSrcLoc callStack) + "sketchedBlock" + $(embedAsUrl "image/svg+xml" "data/ToyCubeTransparency70.svg") + 10 + 10 + +sketchedTree :: HasCallStack => Picture +sketchedTree = + Sketch + (getDebugSrcLoc callStack) + "sketchedTree" + $(embedAsUrl "image/svg+xml" "data/TreeTransparency70.svg") + 10 + 10 diff --git a/src/Util/EmbedAsUrl.hs b/src/Util/EmbedAsUrl.hs new file mode 100644 --- /dev/null +++ b/src/Util/EmbedAsUrl.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{- + Copyright 2019 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 Util.EmbedAsUrl + ( embedAsUrl, + ) +where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Unsafe as B +import qualified Data.Text.Encoding as T +import Language.Haskell.TH.Syntax +import System.IO.Unsafe + +embedAsUrl :: String -> FilePath -> Q Exp +embedAsUrl contentType f = do + qAddDependentFile f + payload <- runIO $ B64.encode <$> B.readFile f + let uri = "data:" <> BC.pack contentType <> ";base64," <> payload + [e| + T.decodeUtf8 $ unsafePerformIO $ + B.unsafePackAddressLen + $(return $ LitE $ IntegerL $ fromIntegral $ B.length uri) + $(return $ LitE $ StringPrimL $ B.unpack uri) + |] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE BangPatterns #-} + +{- + Copyright 2019 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. +-} + +import CodeWorld +import CodeWorld.EntryPoints +import Test.Framework (defaultMain, Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit hiding (Test) + +main :: IO () +main = defaultMain [wrapperIdentityTests] + +checkWrappedIdentity :: (Wrapped a -> Wrapped a) -> Wrapped a -> Assertion +checkWrappedIdentity f x = assertBool "identity" (identical x (f x)) + +wrapperIdentityTests :: Test +wrapperIdentityTests = testGroup "wrapperIdentityTests" + [ testCase "toState preserves identity" $ + checkWrappedIdentity (toState id) (wrappedInitial (42 :: Int)) + , testCase "wrappedStep preserves identity" $ + checkWrappedIdentity (wrappedStep (const id) 1) (wrappedInitial (42 :: Int)) + , testCase "wrapping of shared identity is shared (events)" $ + checkWrappedIdentity (wrappedEvent (const []) + (const id) + (const id) + (TimePassing 1)) + (wrappedInitial (42 :: Int)) + ]