diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# Simple Graphics for MicroHs + +Inspired by Gloss and Shine. diff --git a/canvhs.cabal b/canvhs.cabal new file mode 100644 --- /dev/null +++ b/canvhs.cabal @@ -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 diff --git a/src/Audio/AudHs/FFI.hs b/src/Audio/AudHs/FFI.hs new file mode 100644 --- /dev/null +++ b/src/Audio/AudHs/FFI.hs @@ -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 () diff --git a/src/Graphics/CanvHs.hs b/src/Graphics/CanvHs.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/CanvHs.hs @@ -0,0 +1,6 @@ +module Graphics.CanvHs( + module Graphics.CanvHs.Color, + module Graphics.CanvHs.Picture, + ) where +import Graphics.CanvHs.Color +import Graphics.CanvHs.Picture diff --git a/src/Graphics/CanvHs/Color.hs b/src/Graphics/CanvHs/Color.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/CanvHs/Color.hs @@ -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 diff --git a/src/Graphics/CanvHs/Demo.hs b/src/Graphics/CanvHs/Demo.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/CanvHs/Demo.hs @@ -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 diff --git a/src/Graphics/CanvHs/Picture.hs b/src/Graphics/CanvHs/Picture.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/CanvHs/Picture.hs @@ -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 +