diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for reflex-dom-fragment-shader-canvas + +## 0.1 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 Joachim Breitner + +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 conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Reflex/Dom/FragmentShaderCanvas.hs b/Reflex/Dom/FragmentShaderCanvas.hs new file mode 100644 --- /dev/null +++ b/Reflex/Dom/FragmentShaderCanvas.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} +module Reflex.Dom.FragmentShaderCanvas (fragmentShaderCanvas, trivialFragmentShader) where + +import Data.Map (Map) +import Data.Text as Text (Text, unlines) +import Control.Lens ((^.)) +import Control.Monad.IO.Class + +import Reflex.Dom + +import GHCJS.DOM.Types hiding (Text) +import Language.Javascript.JSaddle.String +import Language.Javascript.JSaddle.Object (js1, js2, jsf, js, js0, new, jsg) + +vertexShaderSource :: Text +vertexShaderSource = + "attribute vec2 a_position;\ + \void main() {\ + \ gl_Position = vec4(a_position, 0, 1);\ + \}" + +trivialFragmentShader :: Text +trivialFragmentShader = Text.unlines + [ "precision mediump float;" + , "uniform vec2 u_windowSize;" + , "void main() {" + , " float s = 2.0 / min(u_windowSize.x, u_windowSize.y);" + , " vec2 pos0 = s * (gl_FragCoord.xy - 0.5 * u_windowSize);" + , " if (length(pos0) > 1.0) { gl_FragColor = vec4(0,0,0,0); return; }" + , " vec3 col0 = vec3(1.0,0.0,0.0);" + , " gl_FragColor = vec4(col0, 1.0);" + , "}" + ] + + +paintGL :: (MonadJSM m) => JSVal -> (Maybe Text -> m ()) -> Text -> m () +paintGL canvas printErr fragmentShaderSource = do + -- adaption of + -- https://blog.mayflower.de/4584-Playing-around-with-pixel-shaders-in-WebGL.html + gl <- liftJSM $ canvas ^. js1 ("getContext"::Text) ("experimental-webgl"::Text) + liftJSM $ gl ^. jsf ("viewport"::Text) (0::Int, 0::Int, gl ^. js ("drawingBufferWidth"::Text), gl ^. js ("drawingBufferHeight"::Text)) + + -- gl ^. jsf "clearColor" [1.0, 0.0, 0.0, 1.0 :: Double] + -- gl ^. js1 "clear" (gl^. js "COLOR_BUFFER_BIT") + + buffer <- liftJSM $ gl ^. js0 ("createBuffer"::Text) + liftJSM $ gl ^. jsf ("bindBuffer"::Text) (gl ^. js ("ARRAY_BUFFER"::Text), buffer) + liftJSM $ gl ^. jsf ("bufferData"::Text) + ( gl ^. js ("ARRAY_BUFFER"::Text) + , new (jsg ("Float32Array"::Text)) [[ + -1.0, -1.0, + 1.0, -1.0, + -1.0, 1.0, + -1.0, 1.0, + 1.0, -1.0, + 1.0, 1.0 :: Double]] + , gl ^. js ("STATIC_DRAW"::Text) + ) + -- jsg "console" ^. js1 "log" (gl ^. js0 "getError") + + vertexShader <- liftJSM $ gl ^. js1 ("createShader"::Text) (gl ^. js ("VERTEX_SHADER"::Text)) + liftJSM $ gl ^. js2 ("shaderSource"::Text) vertexShader vertexShaderSource + liftJSM $ gl ^. js1 ("compileShader"::Text) vertexShader + -- jsg "console" ^. js1 "log" (gl ^. js1 "getShaderInfoLog" vertexShader) + + fragmentShader <- liftJSM $ gl ^. js1 ("createShader"::Text) (gl ^. js ("FRAGMENT_SHADER"::Text)) + liftJSM $ gl ^. js2 ("shaderSource"::Text) fragmentShader fragmentShaderSource + liftJSM $ gl ^. js1 ("compileShader"::Text) fragmentShader + -- jsg "console" ^. js1 "log" (gl ^. js1 "getShaderInfoLog" fragmentShader) + err <- liftJSM $ gl ^. js1 ("getShaderInfoLog"::Text) fragmentShader + -- liftJSM $ jsg ("console"::Text) ^. js1 ("log"::Text) err + printErr . fmap textFromJSString =<< liftJSM (fromJSVal err) + + program <- liftJSM $ gl ^. js0 ("createProgram"::Text) + liftJSM $ gl ^. js2 ("attachShader"::Text) program vertexShader + liftJSM $ gl ^. js2 ("attachShader"::Text) program fragmentShader + liftJSM $ gl ^. js1 ("linkProgram"::Text) program + liftJSM $ gl ^. js1 ("useProgram"::Text) program + -- jsg "console" ^. js1 "log" (gl ^. js1 "getProgramInfoLog" program) + + positionLocation <- liftJSM $ gl ^. js2 ("getAttribLocation"::Text) program ("a_position"::Text) + liftJSM $ gl ^. js1 ("enableVertexAttribArray"::Text) positionLocation + liftJSM $ gl ^. jsf ("vertexAttribPointer"::Text) (positionLocation, 2::Int, gl ^. js ("FLOAT"::Text), False, 0::Int, 0::Int) + liftJSM $ jsg ("console"::Text) ^. js1 ("log"::Text) program + + windowSizeLocation <- liftJSM $ gl ^. js2 ("getUniformLocation"::Text) program ("u_windowSize"::Text) + liftJSM $ gl ^. jsf ("uniform2f"::Text) (windowSizeLocation, gl ^. js ("drawingBufferWidth"::Text), gl ^. js ("drawingBufferHeight"::Text)) + + liftJSM $ gl ^. jsf ("drawArrays"::Text) (gl ^. js ("TRIANGLES"::Text), 0::Int, 6::Int); + return () + +fragmentShaderCanvas :: + (MonadWidget t m) => + (Map Text Text) -> + Dynamic t Text -> + m (Dynamic t (Maybe Text)) +fragmentShaderCanvas attrs fragmentShaderSource = do + (canvasEl, _) <- elAttr' "canvas" attrs $ blank + (eError, reportError) <- newTriggerEvent + pb <- getPostBuild + performEvent $ (<$ pb) $ do + e <- liftJSM $ fromJSValUnchecked =<< toJSVal (_element_raw canvasEl) + src0 <- sample (current fragmentShaderSource) + paintGL e (liftIO . reportError) src0 + performEvent $ (<$> updated fragmentShaderSource) $ \src -> do + e <- liftJSM $ fromJSValUnchecked =<< toJSVal (_element_raw canvasEl) + paintGL e (liftIO . reportError) src + holdDyn Nothing eError diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RecursiveDo #-} +import Reflex.Dom +import Reflex.Dom.FragmentShaderCanvas +import qualified Data.Text as T + +main :: IO () +main = mainWidgetWithHead + (el "style" (text css) >> el "title" (text "Fragment Shader Demo")) $ mdo + inp <- divClass "left" $ do + inp <- textArea $ def + & textAreaConfig_initialValue .~ trivialFragmentShader + divClass "error" $ dynText (maybe "" id <$> dError) + return inp + + dError <- divClass "right" $ fragmentShaderCanvas + (mconcat [ "width" =: "1000" , "height" =: "1000" ]) + (_textArea_value inp) + return () + +css :: T.Text +css = T.unlines + [ "document {" + , " margin: 0;" + , " padding: 0;" + , " width: 100vw;" + , " height: 100vh;" + , "}" + , "body {" + , " margin: 0;" + , " padding: 0;" + , " display: flex;" + , " align-items: stretch;" + , " width: 100vw;" + , " height: 100vh;" + , "}" + , "textarea {" + , " width: 50vw;" + , " height: 50vh;" + , "}" + , ".error {" + , " width: 100%;" + , " text-align: left;" + , " white-space:pre;" + , " font-family:mono;" + , " padding-top: 2em;" + , " overflow: scrolll" + , "}" + , ".left {" + , " width:50%;" + , " padding:2em;" + , "}" + , ".right {" + , " width:50%;" + , " display: flex;" + , "}" + , "canvas {" + , " border: 1px solid black;" + , " max-width: 80%;" + , " max-height: 80%;" + , " margin:auto;" + , "}" + ] diff --git a/reflex-dom-fragment-shader-canvas.cabal b/reflex-dom-fragment-shader-canvas.cabal new file mode 100644 --- /dev/null +++ b/reflex-dom-fragment-shader-canvas.cabal @@ -0,0 +1,47 @@ +name: reflex-dom-fragment-shader-canvas +version: 0.1 +synopsis: A reflex-dom widget to draw on a canvas with a fragment shader program +description: + This simple reflex-dom widget takes a `Dynamic t Text` value representing + the source code of a WebGL fragment shader, and renders it to + a HTML canvas element. + . + It also provides possible compiler errors in another `Dynamic t Text`. +homepage: https://github.com/nomeata/reflex-dom-fragment-shader-canvas +license: MIT +license-file: LICENSE +author: Joachim Breitner +maintainer: mail@joachim-breitner.de +copyright: 2018 Joachim Breitner +category: Web +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 +tested-with: GHC ==8.2 + +source-repository head + type: git + location: https://github.com/nomeata/reflex-dom-fragment-shader-canvas + +library + exposed-modules: Reflex.Dom.FragmentShaderCanvas + build-depends: base >=4.2 && <5 + build-depends: jsaddle >=0.9.5.0 && <0.10 + build-depends: reflex-dom >= 0.4 + build-depends: lens >=4.0.7 && <5.0 + build-depends: ghcjs-dom + build-depends: transformers + build-depends: containers + build-depends: text + default-language: Haskell2010 + +executable demo + main-is: Main.hs + build-depends: base >=4.2 && <5 + build-depends: text + build-depends: reflex-dom >= 0.4 + build-depends: reflex-dom-fragment-shader-canvas + hs-source-dirs: demo + default-language: Haskell2010 + ghc-options: -threaded -rtsopts +