diff --git a/FRP/Netwire/Input/JavaScript.hs b/FRP/Netwire/Input/JavaScript.hs new file mode 100644 --- /dev/null +++ b/FRP/Netwire/Input/JavaScript.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, + FlexibleInstances, MultiParamTypeClasses #-} + +module FRP.Netwire.Input.JavaScript ( + JSInputState, + JSInputControl, + JSInput, + JSInputT, + Key(..), + MouseButton(..), + mkInputControl, + initialInputState, + pollJavaScript, + cursorLocked, + lockCursor, + unlockCursor +) where + +import qualified Data.IntSet as S +import Control.Applicative +import Control.Monad (when) +import Control.Monad.Trans.State +import Control.Wire.Core +import Data.IORef +import FRP.Netwire.Input hiding (Key, MouseButton) +import FRP.Netwire.Input.JavaScript.Key + +import GHCJS.Foreign hiding (Object) +import GHCJS.Foreign.Callback +import GHCJS.Marshal +import GHCJS.Types +import JavaScript.Object.Internal + +data JSInputState = JSInputState { + keyPressedSet :: S.IntSet, + keyReleasedSet :: S.IntSet, + mbPressedSet :: S.IntSet, + mbReleasedSet :: S.IntSet, + cursorPos :: (Float, Float), + cursorMovement :: (Float, Float), + scrollAmount :: (Double, Double), + hiddenCursor :: Bool, + lockedCursor :: Bool, + newCursorMode :: Maybe CursorMode +} + +data Event = KeyDown Int | KeyUp Int | MouseDown Int | MouseUp Int + | MouseMove (Float, Float) (Float, Float) | Wheel (Int, Int) + | PointerLockChange Bool + +data JSInputControl = JSInputControl (IORef [Event]) (IORef Bool) JSVal + +type JSInput = State JSInputState +type JSInputT m = StateT JSInputState m + +-- | Create a 'JSInputControl' from a DOM element. +mkInputControl :: JSVal -> IO (Maybe JSInputControl) +mkInputControl element | isNull element = return Nothing +mkInputControl element = do eventsVar <- newIORef [] + ptrLockVar <- newIORef False + doc <- document + event element eventsVar "keydown" eventKeyDown + event element eventsVar "keyup" eventKeyUp + event element eventsVar "mousedown" eventMouseDown + event element eventsVar "mouseup" eventMouseUp + event element eventsVar "mousemove" $ + eventMouseMove element + event element eventsVar "wheel" eventWheel + event doc eventsVar "pointerlockchange" $ + const (eventPointerLockChange element) + event doc eventsVar "mozpointerlockchange" $ + const (eventPointerLockChange element) + ptrLockPerformer element ptrLockVar "mouseup" + ptrLockPerformer element ptrLockVar "keyup" + return . Just $ + JSInputControl eventsVar ptrLockVar element + + where event element eventsVar name getEvent = + do callback <- asyncCallback1 $ \rawEvent -> + do event <- getEvent $ Object rawEvent + modifyIORef' eventsVar (event :) + addEventListener element name callback + + ptrLockPerformer element ptrLockVar name = + do callback <- asyncCallback1 $ \_ -> do + lock <- atomicModifyIORef' ptrLockVar + (\x -> (False, x)) + when lock $ lockCursorRaw element + addEventListener element name callback + +-- | Use this with 'pollJavaScript' the first time. +initialInputState :: JSInputState +initialInputState = JSInputState { + keyPressedSet = S.empty, + keyReleasedSet = S.empty, + mbPressedSet = S.empty, + mbReleasedSet = S.empty, + cursorPos = (0, 0), + cursorMovement = (0, 0), + scrollAmount = (0, 0), + hiddenCursor = False, + lockedCursor = False, + newCursorMode = Nothing + } + +-- | Update the 'JSInputState' with the new events. +pollJavaScript :: JSInputState + -> JSInputControl + -> IO JSInputState +pollJavaScript is (JSInputControl eventsVar ptrLockVar element) = + do events <- atomicModifyIORef eventsVar $ \e -> ([], e) + + let is' = foldr compEvent + is { scrollAmount = (0, 0) + , cursorMovement = (0, 0) } + events + hidden = hiddenCursor is + locked = lockedCursor is' + + hidden' <- case newCursorMode is of + Just cm -> changeCursorMode hidden locked cm + element ptrLockVar + _ -> return hidden + + return is' { hiddenCursor = hidden', newCursorMode = Nothing } + +-- | In JavaScript, you can lock the pointer only after the user releases a +-- mouse button or a key. This means that 'cursorMode' (with 'CursorMode'Reset') +-- and 'mouseMickies' will not actually lock the pointer, but will schedule +-- the pointer lock request for the next interaction from the user. +-- In particular, 'mouseMickies' will behave like 'mouseCursor' if the pointer +-- is not locked. +-- +-- This wire, which inhibits if the pointer is not locked, is +-- useful if you want to know if you're still waiting for the user to lock the +-- pointer, and if the user manually unlocked it. +cursorLocked :: (Monoid e, Monad m) => Wire s e (JSInputT m) a a +cursorLocked = mkGen_ $ \x -> boolToEither x . lockedCursor <$> get + where boolToEither _ False = Left mempty + boolToEither x True = Right x + +-- | Manually schedule cursor lock. +lockCursor :: JSInputControl -> IO () +lockCursor (JSInputControl _ ptrLockVar _) = writeIORef ptrLockVar True + +-- | Manually unlock the cursor. +unlockCursor :: JSInputControl -> IO () +unlockCursor (JSInputControl _ ptrLockVar _) = writeIORef ptrLockVar False + >> unlockCursorRaw + +changeCursorMode :: Bool -> Bool -> CursorMode + -> JSVal -> IORef Bool -> IO Bool +changeCursorMode hidden locked cm element ptrLockVar = + do case (locked, cm == CursorMode'Reset || cm == CursorMode'Disabled) of + (True, False) -> writeIORef ptrLockVar False >> unlockCursorRaw + (False, True) -> writeIORef ptrLockVar True + _ -> return () + + case (hidden, cm == CursorMode'Hidden) of + (True, False) -> showCursor element >> return False + (False, True) -> hideCursor element >> return True + _ -> return hidden + +compEvent :: Event -> JSInputState -> JSInputState +compEvent (KeyDown k) is | S.member k $ keyReleasedSet is = is + | otherwise = is { keyPressedSet = + S.insert k $ keyPressedSet is } +compEvent (KeyUp k) is = + is { keyPressedSet = S.delete k $ keyPressedSet is + , keyReleasedSet = S.delete k $ keyReleasedSet is } +compEvent (MouseDown k) is | S.member k $ mbReleasedSet is = is + | otherwise = is { mbPressedSet = + S.insert k $ mbPressedSet is } +compEvent (MouseUp k) is = + is { mbPressedSet = S.delete k $ mbPressedSet is + , mbReleasedSet = S.delete k $ mbReleasedSet is } +compEvent (MouseMove (cx, cy) (dmx, dmy)) is = + let (mx0, my0) = cursorMovement is + in is { cursorPos = (cx, cy) + , cursorMovement = (mx0 + dmx, my0 + dmy) } +compEvent (Wheel (x, y)) is = + let (dx, dy) = (fromIntegral x, fromIntegral y) + (x0, y0) = scrollAmount is + in is { scrollAmount = (x0 + dx, y0 + dy) } +compEvent (PointerLockChange locked) is = is { lockedCursor = locked } + +instance Monad m => MonadMouse MouseButton (JSInputT m) where + setCursorMode cm = modify $ \is -> is { newCursorMode = Just cm } + mbIsPressed mb = S.member (fromMouseButton mb) . mbPressedSet <$> get + releaseButton mb = modify $ + \is -> is { mbReleasedSet = S.insert (fromMouseButton mb) $ + mbReleasedSet is + , mbPressedSet = S.delete (fromMouseButton mb) $ + mbPressedSet is } + cursor = (<$> get) $ \is -> if lockedCursor is + then cursorMovement is + else cursorPos is + scroll = scrollAmount <$> get + +instance Monad m => MonadKeyboard Key (JSInputT m) where + keyIsPressed k = do kp <- keyPressedSet <$> get + return $ any (flip S.member kp) (fromKey k) + releaseKey k = modify $ + \is -> is { keyReleasedSet = foldr S.insert + (keyReleasedSet is) + (fromKey k) + , keyPressedSet = foldr S.delete + (keyPressedSet is) + (fromKey k) + } + +eventKeyDown :: Object -> IO Event +eventKeyDown ev = KeyDown <$> prop "keyCode" ev + +eventKeyUp :: Object -> IO Event +eventKeyUp ev = KeyUp <$> prop "keyCode" ev + +eventMouseDown :: Object -> IO Event +eventMouseDown ev = MouseDown <$> prop "button" ev + +eventMouseUp :: Object -> IO Event +eventMouseUp ev = MouseUp <$> prop "button" ev + +eventMouseMove :: JSVal -> Object -> IO Event +eventMouseMove elem ev@(Object evVal) = + do width <- fi <$> prop "clientWidth" (Object elem) + height <- fi <$> prop "clientHeight" (Object elem) + clientX <- fi <$> prop "clientX" ev + clientY <- fi <$> prop "clientY" ev + movementX <- fi <$> movementX evVal + movementY <- fi <$> movementY evVal + return $ MouseMove ( clientX * 2 / width - 1 + , clientY * 2 / height - 1) + ( movementX * 2 / width + , movementY * 2 / height ) + where fi = fromIntegral :: Int -> Float + +eventWheel :: Object -> IO Event +eventWheel ev = Wheel <$> ((,) <$> prop "deltaX" ev + <*> prop "deltaY" ev) + +eventPointerLockChange :: JSVal -> IO Event +eventPointerLockChange elem = PointerLockChange <$> isPointerLockElement elem + +prop :: FromJSVal a => JSString -> Object -> IO a +prop s o = unsafeGetProp s o >>= fromJSValUnchecked + +foreign import javascript unsafe "$1.addEventListener($2, $3)" + addEventListener :: JSVal -> JSString -> Callback (JSVal -> IO ()) -> IO () + +foreign import javascript unsafe " if ($1.requestPointerLock)\ + \ $1.requestPointerLock()\ + \ else\ + \ $1.mozRequestPointerLock()" + lockCursorRaw :: JSVal -> IO () + +foreign import javascript unsafe " if (document.exitPointerLock)\ + \ document.exitPointerLock()\ + \ else\ + \ document.mozExitPointerLock()" + unlockCursorRaw :: IO () + +foreign import javascript unsafe "$1.style.cursor = 'none'" + hideCursor :: JSVal -> IO () + +foreign import javascript unsafe "$1.style.cursor = 'auto'" + showCursor :: JSVal -> IO () + +foreign import javascript unsafe " document.pointerLockElement === $1 ||\ + \ document.mozPointerLockElement === $1" + isPointerLockElement :: JSVal -> IO Bool + +foreign import javascript unsafe "$r = document" document :: IO JSVal + +foreign import javascript unsafe "$1.movementX || $1.mozMovementX || 0" + movementX :: JSVal -> IO Int + +foreign import javascript unsafe "$1.movementY || $1.mozMovementY || 0" + movementY :: JSVal -> IO Int diff --git a/FRP/Netwire/Input/JavaScript/Key.hs b/FRP/Netwire/Input/JavaScript/Key.hs new file mode 100644 --- /dev/null +++ b/FRP/Netwire/Input/JavaScript/Key.hs @@ -0,0 +1,131 @@ +module FRP.Netwire.Input.JavaScript.Key ( + Key(..), + MouseButton(..), + fromKey, + fromMouseButton +) where + +import qualified FRP.Netwire.Input + + +data Key = KeyA | KeyB | KeyC | KeyD | KeyE | KeyF | KeyG | KeyH | KeyI | KeyJ + | KeyK | KeyL | KeyM | KeyN | KeyO | KeyP | KeyQ | KeyR | KeyS | KeyT + | KeyU | KeyV | KeyW | KeyX | KeyY | KeyZ | Key0 | Key1 | Key2 | Key3 + | Key4 | Key5 | Key6 | Key7 | Key8 | Key9 | KeySpace | KeyEnter + | KeyTab | KeyEsc | KeyBackspace | KeyShift | KeyControl | KeyAlt + | KeyCapsLock | KeyNumLock | KeyArrowLeft | KeyArrowUp | KeyArrowRight + | KeyArrowDown | KeyIns | KeyDel | KeyHome | KeyEnd | KeyPgUp + | KeyPgDown | KeyF1 | KeyF2 | KeyF3 | KeyF4 | KeyF5 | KeyF6 | KeyF7 + | KeyF8 | KeyF9 | KeyF10 | KeyF11 | KeyF12 | KeyPadDel | KeyPadIns + | KeyPadEnd | KeyPadDown | KeyPadPgDown | KeyPadLeft | KeyPadRight + | KeyPadHome | KeyPadUp | KeyPadPgUp | KeyPadAdd | KeyPadSub + | KeyPadMul | KeyPadDiv | KeyPadEnter | KeyPadDot | KeyPad0 | KeyPad1 + | KeyPad2 | KeyPad3 | KeyPad4 | KeyPad5 | KeyPad6 | KeyPad7 | KeyPad8 + | KeyPad9 + deriving (Eq, Show) + +data MouseButton = MouseLeft | MouseMiddle | MouseRight deriving (Eq, Show) + +instance FRP.Netwire.Input.Key Key +instance FRP.Netwire.Input.MouseButton MouseButton + +fromKey :: Key -> [Int] +fromKey KeyA = [65, 97] +fromKey KeyB = [66, 98] +fromKey KeyC = [67, 99] +fromKey KeyD = [100, 68] +fromKey KeyE = [101, 69] +fromKey KeyF = [102, 70] +fromKey KeyG = [103, 71] +fromKey KeyH = [104, 72] +fromKey KeyI = [105, 73] +fromKey KeyJ = [106, 74] +fromKey KeyK = [107, 75] +fromKey KeyL = [108, 76] +fromKey KeyM = [109, 77] +fromKey KeyN = [110, 78] +fromKey KeyO = [111, 79] +fromKey KeyP = [112, 80] +fromKey KeyQ = [113, 81] +fromKey KeyR = [114, 82] +fromKey KeyS = [115, 83] +fromKey KeyT = [116, 84] +fromKey KeyU = [117, 85] +fromKey KeyV = [118, 86] +fromKey KeyW = [119, 87] +fromKey KeyX = [120, 88] +fromKey KeyY = [121, 89] +fromKey KeyZ = [122, 90] +fromKey Key0 = [48] +fromKey Key1 = [49] +fromKey Key2 = [50] +fromKey Key3 = [51] +fromKey Key4 = [52] +fromKey Key5 = [53] +fromKey Key6 = [54] +fromKey Key7 = [55] +fromKey Key8 = [56] +fromKey Key9 = [57] +fromKey KeySpace = [32] +fromKey KeyEnter = [13] +fromKey KeyTab = [9] +fromKey KeyEsc = [27] +fromKey KeyBackspace = [8] +fromKey KeyShift = [16] +fromKey KeyControl = [17] +fromKey KeyAlt = [18] +fromKey KeyCapsLock = [20] +fromKey KeyNumLock = [144] +fromKey KeyArrowLeft = [37] +fromKey KeyArrowUp = [38] +fromKey KeyArrowRight = [39] +fromKey KeyArrowDown = [40] +fromKey KeyIns = [45] +fromKey KeyDel = [46] +fromKey KeyHome = [36] +fromKey KeyEnd = [35] +fromKey KeyPgUp = [33] +fromKey KeyPgDown = [34] +fromKey KeyF1 = [112] +fromKey KeyF2 = [113] +fromKey KeyF3 = [114] +fromKey KeyF4 = [115] +fromKey KeyF5 = [116] +fromKey KeyF6 = [117] +fromKey KeyF7 = [118] +fromKey KeyF8 = [119] +fromKey KeyF9 = [120] +fromKey KeyF10 = [121] +fromKey KeyF11 = [122] +fromKey KeyF12 = [123] +fromKey KeyPadDel = [46] +fromKey KeyPadIns = [45] +fromKey KeyPadEnd = [35] +fromKey KeyPadDown = [40] +fromKey KeyPadPgDown = [34] +fromKey KeyPadLeft = [37] +fromKey KeyPadRight = [39] +fromKey KeyPadHome = [36] +fromKey KeyPadUp = [38] +fromKey KeyPadPgUp = [33] +fromKey KeyPadAdd = [107] +fromKey KeyPadSub = [109] +fromKey KeyPadMul = [106] +fromKey KeyPadDiv = [111] +fromKey KeyPadEnter = [13] +fromKey KeyPadDot = [46] +fromKey KeyPad0 = [48] +fromKey KeyPad1 = [49] +fromKey KeyPad2 = [50] +fromKey KeyPad3 = [51] +fromKey KeyPad4 = [52] +fromKey KeyPad5 = [53] +fromKey KeyPad6 = [54] +fromKey KeyPad7 = [55] +fromKey KeyPad8 = [56] +fromKey KeyPad9 = [57] + +fromMouseButton :: MouseButton -> Int +fromMouseButton MouseLeft = 0 +fromMouseButton MouseMiddle = 1 +fromMouseButton MouseRight = 2 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Luca "ziocroc" Prezzavento + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Luca "ziocroc" Prezzavento nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md 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/netwire-input-javascript.cabal b/netwire-input-javascript.cabal new file mode 100644 --- /dev/null +++ b/netwire-input-javascript.cabal @@ -0,0 +1,23 @@ +name: netwire-input-javascript +version: 0.0.1 +synopsis: JavaScript instance of netwire-input +description: GHCJS implementation of netwire-input. +homepage: https://github.com/ziocroc/netwire-input-javascript +license: BSD3 +license-file: LICENSE +author: Luca "ziocroc" Prezzavento +maintainer: ziocroc@gmail.com +category: Game +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/ziocroc/netwire-input-javascript + +library + exposed-modules: FRP.Netwire.Input.JavaScript, FRP.Netwire.Input.JavaScript.Key + other-extensions: OverloadedStrings, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses + build-depends: base >=4.9 && <4.10, ghcjs-base, transformers, netwire >=5.0 && <5.2, netwire-input >=0.0 && <0.1, containers + default-language: Haskell2010