canvhs (empty) → 0.2.0.0
raw patch · 8 files changed
+874/−0 lines, 8 filesdep +base
Dependencies added: base
Files
- LICENSE +218/−0
- README.md +3/−0
- canvhs.cabal +33/−0
- src/Audio/AudHs/FFI.hs +18/−0
- src/Graphics/CanvHs.hs +6/−0
- src/Graphics/CanvHs/Color.hs +38/−0
- src/Graphics/CanvHs/Demo.hs +271/−0
- src/Graphics/CanvHs/Picture.hs +287/−0
+ LICENSE view
@@ -0,0 +1,218 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ 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.++--------------------------------------------------------------------------++Copyright (c) 2010-2016 The Gloss Development Team++ Permission is hereby granted, free of charge, to any person+ obtaining a copy of this software and associated documentation+ files (the "Software"), to deal in the Software without+ restriction, including without limitation the rights to use,+ copy, modify, merge, publish, distribute, sublicense, and/or sell+ copies of the Software, and to permit persons to whom the+ Software is furnished to do so, subject to the following+ condition:++ The above copyright notice and this permission notice shall be+ included in all copies or substantial portions of the Software.
+ README.md view
@@ -0,0 +1,3 @@+# Simple Graphics for MicroHs++Inspired by Gloss and Shine.
+ canvhs.cabal view
@@ -0,0 +1,33 @@+cabal-version: 3.0+name: canvhs+version: 0.2.0.0+synopsis: Simple HTML5 graphics for MicroHs+description: Simple HTML5 graphics and sound for MicroHs+license: Apache-2.0+license-file: LICENSE+author: Lennart Augustsson+maintainer: lennart@augustsson.net+copyright: 2026 Lennart Augustsson+category: Web+build-type: Simple+stability: experimental++extra-source-files:+ LICENSE+ README.md++source-repository head+ type: git+ location: https://github.com/augustss/canvhs++library+ default-language: Haskell98+ exposed-modules: Graphics.CanvHs,+ Graphics.CanvHs.Color,+ Graphics.CanvHs.Picture,+ Graphics.CanvHs.Demo,+ Audio.AudHs.FFI+ -- other-modules:+ -- other-extensions:+ build-depends: base ^>=4.22.0.0+ hs-source-dirs: src
+ src/Audio/AudHs/FFI.hs view
@@ -0,0 +1,18 @@+module Audio.AudHs.FFI(module Audio.AudHs.FFI) where++newtype AudioNode = AudioNode Int+ deriving (Show, Eq, Ord)++masterOutput :: AudioNode+masterOutput = AudioNode 0++foreign import javascript unsafe "js_initAudio()" initAudio :: IO ()+foreign import javascript unsafe "return js_currentTime()" currentTime :: IO Double+foreign import javascript unsafe "return js_createOscillator($0)" createOscillator :: Int -> IO AudioNode+foreign import javascript unsafe "return js_createGain()" createGain :: IO AudioNode+foreign import javascript unsafe "js_connect($0, $1)" connectNodes :: AudioNode -> AudioNode -> IO ()+foreign import javascript unsafe "js_setFrequency($0, $1, $2)" setFrequency :: AudioNode -> Double -> Double -> IO ()+foreign import javascript unsafe "js_setGain($0, $1, $2)" setGain :: AudioNode -> Double -> Double -> IO ()+foreign import javascript unsafe "js_rampGain($0, $1, $2)" rampGain :: AudioNode -> Double -> Double -> IO ()+foreign import javascript unsafe "js_startNode($0, $1)" startNode :: AudioNode -> Double -> IO ()+foreign import javascript unsafe "js_stopNode($0, $1)" stopNode :: AudioNode -> Double -> IO ()
+ src/Graphics/CanvHs.hs view
@@ -0,0 +1,6 @@+module Graphics.CanvHs(+ module Graphics.CanvHs.Color,+ module Graphics.CanvHs.Picture,+ ) where+import Graphics.CanvHs.Color+import Graphics.CanvHs.Picture
+ src/Graphics/CanvHs/Color.hs view
@@ -0,0 +1,38 @@+module Graphics.CanvHs.Color(module Graphics.CanvHs.Color) where++-- | A basic RGBA color representation (values from 0.0 to 1.0)+data Color = RGBA Double Double Double Double++-- Grayscale+black, darkGray, gray, lightGray, white :: Color+black = RGBA 0.0 0.0 0.0 1.0+darkGray = RGBA 0.2 0.2 0.2 1.0+gray = RGBA 0.5 0.5 0.5 1.0+lightGray = RGBA 0.8 0.8 0.8 1.0+white = RGBA 1.0 1.0 1.0 1.0++-- Primary & Secondary+red, green, blue, yellow, cyan, magenta :: Color+red = RGBA 1.0 0.0 0.0 1.0+green = RGBA 0.0 1.0 0.0 1.0+blue = RGBA 0.0 0.0 1.0 1.0+yellow = RGBA 1.0 1.0 0.0 1.0+cyan = RGBA 0.0 1.0 1.0 1.0+magenta = RGBA 1.0 0.0 1.0 1.0++-- Extended Palette+orange, purple, pink, brown, lime, teal :: Color+orange = RGBA 1.0 0.5 0.0 1.0+purple = RGBA 0.5 0.0 0.5 1.0+pink = RGBA 1.0 0.4 0.7 1.0+brown = RGBA 0.6 0.3 0.1 1.0+lime = RGBA 0.5 1.0 0.0 1.0+teal = RGBA 0.0 0.5 0.5 1.0++-- Transparent/Utilities+transparent :: Color+transparent = RGBA 0.0 0.0 0.0 0.0++-- Helper function to quickly create colors with custom opacity (alpha)+withAlpha :: Double -> Color -> Color+withAlpha a (RGBA r g b _) = RGBA r g b a
+ src/Graphics/CanvHs/Demo.hs view
@@ -0,0 +1,271 @@+module Graphics.CanvHs.Demo where+import Data.Double+import Graphics.CanvHs+import Audio.AudHs.Sound++header :: String+header = "Source at https://github.com/augustss/canvhs"++headerINT :: String+headerINT = "Use CTRL-C to interrupt"++--------------------------------------------------------++demo1 :: IO ()+demo1 = do+ putStrLn header+ let scene = Pictures+ [ Color blue (SolidRectangle 200 200)+ , Color red (SolidCircle 50)+ ]+ display scene++--------------------------------------------------------++demo2 :: IO ()+demo2 = do+ putStrLn header+ let background = Color darkGray (SolidRectangle 800 800)+ display (Pictures [background, lotusMandala])++-- Draws a 12-petal lotus flower+lotusMandala :: Picture+lotusMandala = Pictures [ Rotate (angle * 30) (petal angle) | angle <- [0..11] ]+ where+ -- Alternates colors based on the angle index+ petal a+ | even (round a) = Color pink (Translate 0 80 (SolidCircle 40))+ | otherwise = Color magenta (Translate 0 80 (SolidCircle 40))+++--------------------------------------------------------++demo3 :: IO ()+demo3 = do+ putStrLn header+ putStrLn headerINT+ animate solarSystem++solarSystem :: Double -> Picture+solarSystem t =+ let+ -- Sun+ sun = Color yellow (SolidCircle 50)++ -- Earth+ earth = Rotate (t * 45.0) $ Translate 150 0 $ Pictures+ [ Color blue (SolidCircle 20)+ , moon+ ]++ -- Moon+ moon = Rotate (t * 180.0) $ Translate 40 0 $+ Color white (SolidCircle 8)++ -- Space+ background = Color black (SolidRectangle 2000 2000)++ in Pictures [background, sun, earth]++--------------------------------------------------------++data DemoState = DemoState+ { ball_X :: Double+ , ball_Y :: Double+ , totalTime :: Double+ } deriving (Show)++initialState :: DemoState+initialState = DemoState 0 0 0++-- The Step Function (Logic)+stepDemo :: Double -> MouseState -> DemoState -> DemoState+stepDemo dt mouse state =+ let+ -- Always accumulate time so the pulsation never stops+ newTime = totalTime state + dt++ -- Only update the ball's target coordinates if the mouse is down+ (newX, newY) = if mouseIsDown mouse+ then (mouseX mouse, mouseY mouse)+ else (ball_X state, ball_Y state)++ in DemoState newX newY newTime++-- The Draw Function (Rendering)+drawDemo :: DemoState -> Picture+drawDemo state =+ let+ pulse = 1.0 + 0.2 * sin (totalTime state * 5.0)++ ball = Translate (ball_X state) (ball_Y state) $+ Scale pulse pulse $+ Color red (SolidCircle 30)++ -- Create the coordinate text+ coordString = "X: " ++ show (doubleToInt $ ball_X state) ++ ", Y: " ++ show (doubleToInt $ ball_Y state)++ -- Position the text slightly above and to the right of the ball+ label = Translate (ball_X state + 40) (ball_Y state + 40) $+ Color white (Text coordString)++ background = Color black (SolidRectangle 2000 2000)++ in Pictures [background, ball, label]++demo4 :: IO ()+demo4 = do+ putStrLn header+ putStrLn headerINT+ putStrLn "Push the mouse button and drag it around in the animation window."+ play initialState drawDemo stepDemo++--------------------------------------------------------++-- 1. The Game State+data PongState = PongState+ { ballX :: Double+ , ballY :: Double+ , ballVX :: Double -- Velocity X+ , ballVY :: Double -- Velocity Y+ , paddle1Y :: Double -- Player (Left)+ , paddle2Y :: Double -- AI (Right)+ , score1 :: Int+ , score2 :: Int+ , sounds :: Sound+ } deriving (Show)++-- Start the ball moving to the left+initialPongState :: PongState+initialPongState = PongState 0 0 (-400) 250 0 0 0 0 silence++-- Game Constants+boardWidth, boardHeight, paddleW, paddleH, ballSize :: Double+boardWidth = 800+boardHeight = 600+paddleW = 50+paddleH = 100+ballSize = 15++-- 2. The Physics & Logic (Step Function)+stepPong :: Double -> MouseState -> PongState -> PongState+stepPong dt mouse state =+ let+ -- A. Player Paddle (Snaps directly to mouse Y)+ p1Y = mouseY mouse++ -- B. AI Paddle (Chases the ball with a maximum speed)+ aiSpeed = 350.0+ p2Diff = ballY state - paddle2Y state+ -- signum gives direction (1 or -1), min limits the speed per frame+ p2Move = signum p2Diff * min (abs p2Diff) (aiSpeed * dt)+ p2Y = paddle2Y state + p2Move++ -- C. Move the Ball+ nextX = ballX state + ballVX state * dt+ nextY = ballY state + ballVY state * dt++ -- D. Wall Collisions (Bounce off Top and Bottom)+ (nextY', vy')+ | nextY > (boardHeight / 2) = ( boardHeight / 2, -ballVY state)+ | nextY < -(boardHeight / 2) = (-boardHeight / 2, -ballVY state)+ | otherwise = (nextY, ballVY state)++ wallSnd = if vy' /= ballVY state then [wallBounce] else []++ -- E. Paddle Collisions+ -- Check if ball is intersecting the X-plane of the paddles, AND within their Y-height+ hitLeft = nextX < (-boardWidth/2 + paddleW) && abs (nextY' - p1Y) < (paddleH/2)+ hitRight = nextX > ( boardWidth/2 - paddleW) && abs (nextY' - p2Y) < (paddleH/2)++ vx'+ | hitLeft = abs (ballVX state) + 20 -- Bounce right, speed up slightly+ | hitRight = -(abs (ballVX state) + 20) -- Bounce left, speed up slightly+ | otherwise = ballVX state++ paddleSnd = if hitLeft || hitRight then [paddleBounce] else []++ -- F. Scoring+ p2Scored = nextX < -(boardWidth/2 + 50)+ p1Scored = nextX > (boardWidth/2 + 50)++ scoreSnd = if p1Scored || p2Scored then [scoreSound] else []++ (finalX, finalY, finalVX, finalVY, finalS1, finalS2)+ | p1Scored = (0, 0, -400, 250, score1 state + 1, score2 state)+ | p2Scored = (0, 0, 400, 250, score1 state, score2 state + 1)+ | otherwise = (nextX, nextY', vx', vy', score1 state, score2 state)++ in PongState finalX finalY finalVX finalVY p1Y p2Y finalS1 finalS2 (Sounds $ wallSnd ++ paddleSnd ++ scoreSnd)++-- 3. The Rendering (Draw Function)+drawPong :: PongState -> Picture+drawPong state =+ let+ bg = Color black (SolidRectangle 2000 2000)++ -- A thin center dividing line+ centerLine = Color white (SolidRectangle 2 boardHeight)++ -- The Paddles+ p1 = Translate (-boardWidth/2) (paddle1Y state) $ Color white (SolidRectangle paddleW paddleH)+ p2 = Translate ( boardWidth/2) (paddle2Y state) $ Color white (SolidRectangle paddleW paddleH)++ -- The Ball (Classic square shape)+ ball = Translate (ballX state) (ballY state) $ Color white (SolidRectangle ballSize ballSize)++ -- The Scores (Snapping to integers to avoid any lingering sub-pixel rendering issues)+ s1Text = Translate (-100) (boardHeight/2 - 40) $ Color white (Text (show $ score1 state))+ s2Text = Translate ( 100) (boardHeight/2 - 40) $ Color white (Text (show $ score2 state))++ in Pictures [bg, centerLine, p1, p2, ball, s1Text, s2Text]++paddleBounce :: Sound+paddleBounce = Sound Square 880 0.2 0.05++wallBounce :: Sound+wallBounce = Sound Square 440 0.2 0.05++scoreSound :: Sound+scoreSound = Sound Square 150 0.2 0.4++-- 4. Execute+demo5 :: IO ()+demo5 = do+ putStrLn header+ putStrLn headerINT+ playWithSound initialPongState drawPong sounds stepPong++--------------------------------------------------------++demo6 :: IO ()+demo6 = animate lotus+ where+ lotus :: Double -> Picture+ lotus t = Pictures [ petal t i | i <- [0..11] ]++ petal :: Double -> Double -> Picture+ petal t i =+ let+ -- 1. Space out 12 petals evenly (360/12 = 30 degrees), and rotate the whole thing over time+ angle = i * 30 + (t * 15)++ -- 2. Use sine waves to smoothly cycle RGB colors based on time and petal index+ r = 0.5 + 0.5 * sin (t + i)+ g = 0.5 + 0.5 * sin (t + i + 2)+ b = 0.5 + 0.5 * sin (t + i + 4)++ -- 3. Make the petals "breathe" in and out+ distance = 60 + 20 * sin (t * 2)++ in+ Rotate angle $+ Translate distance 0 $+ Color (RGBA r g b 0.7) (SolidCircle 25)++--------------------------------------------------------++demo7 :: IO ()+demo7 = do+ putStrLn "Playing a sound"+ playSound $ Sound Sine 440 0.5 1.5
+ src/Graphics/CanvHs/Picture.hs view
@@ -0,0 +1,287 @@+--+-- A lot of this code was written by Gemini+--+module Graphics.CanvHs.Picture(+ Picture(..),+ MouseState(..),+ display,+ animate,+ playWithSound,+ play,+ reset,+ ) where+import Control.Exception(bracket_)+import Foreign.C.String(withCAString, CString)+import Graphics.CanvHs.Color+import Audio.AudHs.Sound++-- | Standard Gloss/Shine Picture primitives+data Picture+ = Blank+ | Line [(Double, Double)] -- A stroked path+ | Polygon [(Double, Double)] -- A filled polygon+ | Circle Double -- A stroked circle+ | SolidCircle Double -- A filled circle+ | Rectangle Double Double -- Width, Height (centered)+ | SolidRectangle Double Double -- Width, Height (centered)+ | Color Color Picture -- Applies color to child+ | Translate Double Double Picture -- X, Y shift+ | Rotate Double Picture -- Angle in degrees (clockwise)+ | Scale Double Double Picture -- X, Y scaling+ | Pictures [Picture] -- Group of pictures+ | Text String -- text++data MouseState = MouseState+ { mouseX :: Double+ , mouseY :: Double+ , mouseIsDown :: Bool+ } deriving (Show, Eq)++------------------------------------------------------------+-- JavaScript FFI Bindings++foreign import javascript unsafe "window.ctx.save();"+ js_save :: IO ()++foreign import javascript unsafe "window.ctx.restore();"+ js_restore :: IO ()++foreign import javascript unsafe "window.ctx.translate($0, $1);"+ js_translate :: Double -> Double -> IO ()++foreign import javascript unsafe "window.ctx.rotate($0);"+ js_rotate :: Double -> IO ()++foreign import javascript unsafe "window.ctx.scale($0, $1);"+ js_scale :: Double -> Double -> IO ()++foreign import javascript unsafe "window.ctx.beginPath();"+ js_beginPath :: IO ()++foreign import javascript unsafe "window.ctx.closePath();"+ js_closePath :: IO ()++foreign import javascript unsafe "window.ctx.moveTo($0, $1);"+ js_moveTo :: Double -> Double -> IO ()++foreign import javascript unsafe "window.ctx.lineTo($0, $1);"+ js_lineTo :: Double -> Double -> IO ()++foreign import javascript unsafe "window.ctx.fill();"+ js_fill :: IO ()++foreign import javascript unsafe "window.ctx.stroke();"+ js_stroke :: IO ()++foreign import javascript unsafe "var c = window.ctx; c.arc(0, 0, $0, 0, 2 * Math.PI); c.stroke();"+ js_strokeCircle :: Double -> IO ()++foreign import javascript unsafe "var c = window.ctx; c.arc(0, 0, $0, 0, 2 * Math.PI); c.fill();"+ js_fillCircle :: Double -> IO ()++foreign import javascript unsafe "var c = window.ctx; c.rect(-($0/2), -($1/2), $0, $1); c.stroke();"+ js_strokeRect :: Double -> Double -> IO ()++foreign import javascript unsafe "var c = window.ctx; c.rect(-($0/2), -($1/2), $0, $1); c.fill();"+ js_fillRect :: Double -> Double -> IO ()++foreign import javascript unsafe "var col = 'rgba(' + Math.round($0*255) + ',' + Math.round($1*255) + ',' + Math.round($2*255) + ',' + $3 + ')'; var c = window.ctx; c.fillStyle = col; c.strokeStyle = col;"+ js_setColor :: Double -> Double -> Double -> Double -> IO ()++foreign import javascript unsafe "window.ctx.clearRect(0, 0, window.cvs.width, window.cvs.height);"+ js_clearCanvas :: IO ()++foreign import javascript unsafe "var c = window.ctx; c.translate(window.cvs.width / 2, window.cvs.height / 2); c.scale(1, -1);"+ js_setupCoordinates :: IO ()++foreign import javascript unsafe "window.showCanvas();"+ js_showCanvas :: IO ()++-- We save, flip Y back to normal, draw the text, and restore.+foreign import javascript unsafe "window.drawHaskellText($0);"+ js_fillText :: CString -> IO ()++foreign import javascript unsafe "window.ctx.resetTransform();"+ js_resetTransform :: IO ()++foreign import javascript unsafe "console.log('js_log=', $0);"+ js_log :: Double -> IO ()++foreign import javascript unsafe "return performance.now()"+ js_now :: IO Double++foreign import javascript unsafe "return window.mouseState.x;"+ js_mouseX :: IO Double++foreign import javascript unsafe "return window.mouseState.y;"+ js_mouseY :: IO Double++foreign import javascript unsafe "return window.mouseState.down;"+ js_mouseDown :: IO Int++foreign import ccall unsafe "emscripten_sleep"+ emscripten_sleep :: Int -> IO ()++foreign import capi "value extern void c_begin_draw(void); c_begin_draw()"+ c_begin_draw :: IO ()++foreign import capi "value extern void c_end_draw(void); c_end_draw()"+ c_end_draw :: IO ()++foreign import capi "value extern void c_waitForFrame(void); c_waitForFrame()"+ js_waitForFrame :: IO ()++----------------------------------------------------------------++{-+withSaved :: IO () -> IO ()+withSaved = bracket_ js_save js_restore++withDrawLock :: IO a -> IO a+withDrawLock = bracket_ c_begin_draw c_end_draw+-}++drawing :: IO a -> IO a+drawing = bracket_ (c_begin_draw >> js_save) (js_restore >> c_end_draw)++-- Reset in case the transform stack gets messed up.+reset :: IO ()+reset = do+ js_resetTransform+ js_clearCanvas++-- Rendering++drawPath :: [(Double, Double)] -> Bool -> IO ()+drawPath [] _ = return ()+drawPath ((startX, startY):pts) close = do+ js_beginPath+ js_moveTo startX startY+ mapM_ (\(x, y) -> js_lineTo x y) pts+ if close+ then do+ js_closePath+ js_fill+ else+ js_stroke++renderPicture :: Picture -> IO ()+renderPicture Blank = return ()+renderPicture (Pictures ps) = mapM_ renderPicture ps++renderPicture (Translate x y p) = do+ js_save+ js_translate x y+ renderPicture p+ js_restore++renderPicture (Scale x y p) = do+ js_save+ js_scale x y+ renderPicture p+ js_restore++renderPicture (Rotate deg p) = do+ js_save+ let radians = -(deg * pi / 180.0)+ js_rotate radians+ renderPicture p+ js_restore++renderPicture (Color (RGBA r g b a) p) = do+ js_save+ js_setColor r g b a+ renderPicture p+ js_restore++renderPicture (Line pts) = drawPath pts False+renderPicture (Polygon pts) = drawPath pts True++renderPicture (Circle r) = do+ js_beginPath+ js_strokeCircle r++renderPicture (SolidCircle r) = do+ js_beginPath+ js_fillCircle r++renderPicture (Rectangle w h) = do+ js_beginPath+ js_strokeRect w h++renderPicture (SolidRectangle w h) = do+ js_beginPath+ js_fillRect w h++renderPicture (Text str) =+ withCAString str js_fillText++display :: Picture -> IO ()+display pic = do+ js_showCanvas+ drawing $ do+ js_clearCanvas+ js_setupCoordinates+ renderPicture pic++--------------------------------++animate :: (Double -> Picture) -> IO ()+animate frameFunc = do+ js_showCanvas+ startTime <- js_now++ let loop = do+ currentTime <- js_now+ let dt = (currentTime - startTime) / 1000.0++ drawing $ do+ js_clearCanvas+ js_setupCoordinates+ renderPicture (frameFunc dt)++ js_waitForFrame++ loop++ loop++---------------------------------++playWithSound :: world+ -> (world -> Picture)+ -> (world -> Sound)+ -> (Double -> MouseState -> world -> world)+ -> IO ()+playWithSound initialWorld drawFunc soundFunc stepFunc = do+ js_showCanvas+ startTime <- js_now++ let loop lastTime world = do+ currentTime <- js_now+ let dt = (currentTime - lastTime) / 1000.0++ -- Get the mouse billboard+ mState <- MouseState <$> js_mouseX <*> js_mouseY <*> ((/= 0) <$> js_mouseDown)++ let newWorld = stepFunc dt mState world++ drawing $ do+ js_clearCanvas+ js_setupCoordinates+ renderPicture (drawFunc newWorld)++ js_waitForFrame++ playSound (soundFunc newWorld)++ loop currentTime newWorld++ loop startTime initialWorld++play :: world+ -> (world -> Picture)+ -> (Double -> MouseState -> world -> world)+ -> IO ()+play initialWorld drawFunc stepFunc = playWithSound initialWorld drawFunc (const silence) stepFunc+