<commit_before>{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, FlexibleInstances,
        MultiParamTypeClasses, OverloadedStrings, Rank2Types, EmptyDataDecls,
        JavaScriptFFI, RecursiveDo #-}
module FRP.Sodium.GameEngine2D.WebGL where

import FRP.Sodium.GameEngine2D.Cache
import FRP.Sodium.GameEngine2D.Geometry
import FRP.Sodium.GameEngine2D.Platform

import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as C
import Data.IORef
import Data.Monoid
import Data.String
import qualified Data.Text as T
import Data.Time.Clock
import FRP.Sodium
import GHCJS.Foreign
import GHCJS.Types
import GHCJS.Marshal
import Numeric
import System.FilePath
import System.Random (newStdGen)


data WebGL

appendCache :: Maybe (ReaderT SpriteState IO ()) -> Maybe (ReaderT SpriteState IO ()) -> Maybe (ReaderT SpriteState IO ())
appendCache (Just a)    (Just b) = Just (a >> b)
appendCache ja@(Just _) _        = ja
appendCache _           mb       = mb

instance Monoid (Sprite WebGL) where
    mempty = Sprite NullKey ((0,0),(0,0)) Nothing $ return ()
    Sprite ka ra ca a `mappend` Sprite kb rb cb b =
        Sprite (ka `appendKey` kb) (ra `appendRect` rb) (ca `appendCache` cb) (a >> b)

data GL_
type GL = JSRef GL_

foreign import javascript unsafe "initGL($1,$2,$3,$4)"
    initGL :: Element
           -> JSFun (JSRef Float -> JSRef Float -> IO ())
           -> JSFun (JSRef Float -> JSRef Float -> IO ())
           -> JSFun (JSRef Float -> JSRef Float -> IO ())
           -> IO GL

data Element_
type Element = JSRef Element_

foreign import javascript unsafe "document.getElementById($1)"
    getElementById :: JSString -> IO Element

foreign import javascript unsafe "$1.clearColor($2, $3, $4, $5);"
    clearColor :: GL -> Float -> Float -> Float -> Float -> IO ()

foreign import javascript unsafe "$1.clear($1.COLOR_BUFFER_BIT | $1.DEPTH_BUFFER_BIT);"
    clear :: GL -> IO ()

foreign import javascript unsafe "requestAnimFrame($1)"
    requestAnimFrame :: JSFun (IO ()) -> IO ()

foreign import javascript unsafe "window.addEventListener('resize',$1);"
    onWindowResize :: JSFun (IO ()) -> IO ()

foreign import javascript unsafe "getWindowWidth()"
    windowWidth :: IO Float

foreign import javascript unsafe "getWindowHeight()"
    windowHeight :: IO Float

foreign import javascript unsafe "resizeViewport($1,$2,$3)"
    resizeViewport :: Element -> Float -> Float -> IO ()

data Texture_
type Texture = JSRef Texture_

foreign import javascript unsafe "loadImage"
    loadImage :: JSString -> IO Texture

foreign import javascript unsafe "drawImage"
    drawImage :: Texture -> Float -> Float -> Float -> Float -> IO ()

foreign import javascript unsafe "destroyImage"
    destroyImage :: Texture -> IO ()

framesPerSecond = 5

animate :: IO () -> IO ()
animate drawScene = do
    rec
        let tick = do
                drawScene
                --threadDelay (1000000 `div` framesPerSecond)
                requestAnimFrame tick'
        tick' <- syncCallback True True tick
    requestAnimFrame tick'

data SpriteState = SpriteState {
        ssInternals  :: Internals WebGL
    }

-- | Get system time in seconds since the start of the Unix epoch
-- (1 Jan 1970).
getTime :: UTCTime -> IO Double
getTime t0 = do
    t <- getCurrentTime
    return $ realToFrac (t `diffUTCTime` t0)

instance Platform WebGL where
    data Args WebGL = WebGLArgs FilePath
    data Internals WebGL = WebGLInternals {
            inResPath  :: FilePath,
            inCache    :: Cache Rect
        }
    data Sprite WebGL = Sprite {
            spKey   :: Key,
            spRect  :: Rect,  -- Bounding box
            spCache :: Maybe (ReaderT SpriteState IO ()),
            spDraw  :: ReaderT SpriteState IO ()
        }
    data Font WebGL = Font
    data Sound WebGL = Sound
    type Touch WebGL = ()

    engine (WebGLArgs resPath) game = do
        width0 <- windowWidth
        height0 <- windowHeight
        (viewport, sendViewport) <- sync $ newBehavior (width0, height0)
        let aspect = uncurry (/) <$> viewport

        (time, sendTime) <- sync $ newBehavior 0
        (realTime, sendRealTime) <- sync $ newBehavior 0
        rng <- newStdGen
        (eMouse, sendMouse) <- sync newEvent
        (bSprite, bMusic, eEffects) <- sync $ game aspect eMouse time rng
        spriteRef <- newIORef =<< sync (sample bSprite)
        kill <- sync $ listen (updates bSprite) (writeIORef spriteRef)

        canvas <- getElementById "mycanvas"

        let scaleClick (xx, yy) = do
                (width, height) <- sync $ sample viewport
                let xscale  = 2000 * width / height
                    x = xscale * (xx / width - 0.5)
                    y = (-2000) * (yy / height - 0.5)
                return (x, y)

        md <- syncCallback2 True True $ \jx jy -> do
            Just xx <- fromJSRef jx :: IO (Maybe Float)
            Just yy <- fromJSRef jy :: IO (Maybe Float)
            pt <- scaleClick (xx, yy)
            sync $ sendMouse $ MouseDown () pt
        mu <- syncCallback2 True True $ \jx jy -> do
            Just xx <- fromJSRef jx :: IO (Maybe Float)
            Just yy <- fromJSRef jy :: IO (Maybe Float)
            pt <- scaleClick (xx, yy)
            sync $ sendMouse $ MouseUp () pt
        mm <- syncCallback2 True True $ \jx jy -> do
            Just xx <- fromJSRef jx :: IO (Maybe Float)
            Just yy <- fromJSRef jy :: IO (Maybe Float)
            pt <- scaleClick (xx, yy)
            sync $ sendMouse $ MouseMove () pt

        or <- syncCallback True True $ do
            w <- windowWidth
            h <- windowHeight
            resizeViewport canvas w h
            sync $ sendViewport (w,h)
        onWindowResize or

        gl <- initGL canvas md mu mm

        t0 <- getCurrentTime
        tLastEndRef <- newIORef =<< getTime t0
        timeLostRef <- newIORef 0
        tLastGC <- newIORef 0

        cache <- newCache
        let internals = WebGLInternals {<commit_msg>syncCallback True False seems to be the best.<commit_after>{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, FlexibleInstances,
        MultiParamTypeClasses, OverloadedStrings, Rank2Types, EmptyDataDecls,
        JavaScriptFFI, RecursiveDo #-}
module FRP.Sodium.GameEngine2D.WebGL where

import FRP.Sodium.GameEngine2D.Cache
import FRP.Sodium.GameEngine2D.Geometry
import FRP.Sodium.GameEngine2D.Platform

import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad.Reader
import qualified Data.ByteString.Char8 as C
import Data.IORef
import Data.Monoid
import Data.String
import qualified Data.Text as T
import Data.Time.Clock
import FRP.Sodium
import GHCJS.Foreign
import GHCJS.Types
import GHCJS.Marshal
import Numeric
import System.FilePath
import System.Random (newStdGen)


data WebGL

appendCache :: Maybe (ReaderT SpriteState IO ()) -> Maybe (ReaderT SpriteState IO ()) -> Maybe (ReaderT SpriteState IO ())
appendCache (Just a)    (Just b) = Just (a >> b)
appendCache ja@(Just _) _        = ja
appendCache _           mb       = mb

instance Monoid (Sprite WebGL) where
    mempty = Sprite NullKey ((0,0),(0,0)) Nothing $ return ()
    Sprite ka ra ca a `mappend` Sprite kb rb cb b =
        Sprite (ka `appendKey` kb) (ra `appendRect` rb) (ca `appendCache` cb) (a >> b)

data GL_
type GL = JSRef GL_

foreign import javascript unsafe "initGL($1,$2,$3,$4)"
    initGL :: Element
           -> JSFun (JSRef Float -> JSRef Float -> IO ())
           -> JSFun (JSRef Float -> JSRef Float -> IO ())
           -> JSFun (JSRef Float -> JSRef Float -> IO ())
           -> IO GL

data Element_
type Element = JSRef Element_

foreign import javascript unsafe "document.getElementById($1)"
    getElementById :: JSString -> IO Element

foreign import javascript unsafe "$1.clearColor($2, $3, $4, $5);"
    clearColor :: GL -> Float -> Float -> Float -> Float -> IO ()

foreign import javascript unsafe "$1.clear($1.COLOR_BUFFER_BIT | $1.DEPTH_BUFFER_BIT);"
    clear :: GL -> IO ()

foreign import javascript unsafe "requestAnimFrame($1)"
    requestAnimFrame :: JSFun (IO ()) -> IO ()

foreign import javascript unsafe "window.addEventListener('resize',$1);"
    onWindowResize :: JSFun (IO ()) -> IO ()

foreign import javascript unsafe "getWindowWidth()"
    windowWidth :: IO Float

foreign import javascript unsafe "getWindowHeight()"
    windowHeight :: IO Float

foreign import javascript unsafe "resizeViewport($1,$2,$3)"
    resizeViewport :: Element -> Float -> Float -> IO ()

data Texture_
type Texture = JSRef Texture_

foreign import javascript unsafe "loadImage"
    loadImage :: JSString -> IO Texture

foreign import javascript unsafe "drawImage"
    drawImage :: Texture -> Float -> Float -> Float -> Float -> IO ()

foreign import javascript unsafe "destroyImage"
    destroyImage :: Texture -> IO ()

framesPerSecond = 5

animate :: IO () -> IO ()
animate drawScene = do
    rec
        let tick = do
                drawScene
                --threadDelay (1000000 `div` framesPerSecond)
                requestAnimFrame tick'
        tick' <- syncCallback True False tick
    requestAnimFrame tick'

data SpriteState = SpriteState {
        ssInternals  :: Internals WebGL
    }

-- | Get system time in seconds since the start of the Unix epoch
-- (1 Jan 1970).
getTime :: UTCTime -> IO Double
getTime t0 = do
    t <- getCurrentTime
    return $ realToFrac (t `diffUTCTime` t0)

instance Platform WebGL where
    data Args WebGL = WebGLArgs FilePath
    data Internals WebGL = WebGLInternals {
            inResPath  :: FilePath,
            inCache    :: Cache Rect
        }
    data Sprite WebGL = Sprite {
            spKey   :: Key,
            spRect  :: Rect,  -- Bounding box
            spCache :: Maybe (ReaderT SpriteState IO ()),
            spDraw  :: ReaderT SpriteState IO ()
        }
    data Font WebGL = Font
    data Sound WebGL = Sound
    type Touch WebGL = ()

    engine (WebGLArgs resPath) game = do
        width0 <- windowWidth
        height0 <- windowHeight
        (viewport, sendViewport) <- sync $ newBehavior (width0, height0)
        let aspect = uncurry (/) <$> viewport

        (time, sendTime) <- sync $ newBehavior 0
        (realTime, sendRealTime) <- sync $ newBehavior 0
        rng <- newStdGen
        (eMouse, sendMouse) <- sync newEvent
        (bSprite, bMusic, eEffects) <- sync $ game aspect eMouse time rng
        spriteRef <- newIORef =<< sync (sample bSprite)
        kill <- sync $ listen (updates bSprite) (writeIORef spriteRef)

        canvas <- getElementById "mycanvas"

        let scaleClick (xx, yy) = do
                (width, height) <- sync $ sample viewport
                let xscale  = 2000 * width / height
                    x = xscale * (xx / width - 0.5)
                    y = (-2000) * (yy / height - 0.5)
                return (x, y)

        md <- syncCallback2 True False $ \jx jy -> do
            Just xx <- fromJSRef jx :: IO (Maybe Float)
            Just yy <- fromJSRef jy :: IO (Maybe Float)
            pt <- scaleClick (xx, yy)
            sync $ sendMouse $ MouseDown () pt
        mu <- syncCallback2 True False $ \jx jy -> do
            Just xx <- fromJSRef jx :: IO (Maybe Float)
            Just yy <- fromJSRef jy :: IO (Maybe Float)
            pt <- scaleClick (xx, yy)
            sync $ sendMouse $ MouseUp () pt
        mm <- syncCallback2 True False $ \jx jy -> do
            Just xx <- fromJSRef jx :: IO (Maybe Float)
            Just yy <- fromJSRef jy :: IO (Maybe Float)
            pt <- scaleClick (xx, yy)
            sync $ sendMouse $ MouseMove () pt

        or <- syncCallback True False $ do
            w <- windowWidth
            h <- windowHeight
            resizeViewport canvas w h
            sync $ sendViewport (w,h)
        onWindowResize or

        gl <- initGL canvas md mu mm

        t0 <- getCurrentTime
        tLastEndRef <- newIORef =<< getTime t0
        timeLostRef <- newIORef 0
        tLastGC <- newIORef 0

        cache <- newCache
        let internals = WebGLInternals {
{'fraction_non_alphanumeric': 0.10033803281391705, 'fraction_numerical': 0.011212795778712177, 'mean_word_length': 2.3406774993114845, 'pattern_counts': {'":': 0, '<': 83, '<?xml version=': 0, '>': 85, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '796191', 'n_tokens_mistral': 3751, 'n_tokens_neox': 3526, 'n_words': 1205}