1 a95f0ac6 2022-01-17 falsifian module Main
  2 a95f0ac6 2022-01-17 falsifian 
  3 a95f0ac6 2022-01-17 falsifian import Data.IORef
  4 a95f0ac6 2022-01-17 falsifian import Data.Vect
  5 a95f0ac6 2022-01-17 falsifian import JS
  6 a95f0ac6 2022-01-17 falsifian import S3D.AnimationFrame
  7 a95f0ac6 2022-01-17 falsifian import S3D.ArrayBuffer
  8 a95f0ac6 2022-01-17 falsifian import S3D.Draw
  9 a95f0ac6 2022-01-17 falsifian import S3D.Figure
 10 a95f0ac6 2022-01-17 falsifian import S3D.GLProgram
 11 a95f0ac6 2022-01-17 falsifian import S3D.GLProgram.ColourTexture
 12 a95f0ac6 2022-01-17 falsifian import S3D.GLProgram.SimpleColour
 13 a95f0ac6 2022-01-17 falsifian import S3D.Drawable
 14 a95f0ac6 2022-01-17 falsifian import Math.LinearAlgebra
 15 a95f0ac6 2022-01-17 falsifian import S3D.Obstacles
 16 a95f0ac6 2022-01-17 falsifian import S3D.PhysicalObject
 17 a95f0ac6 2022-01-17 falsifian import S3D.PhysicalState
 18 a95f0ac6 2022-01-17 falsifian import S3D.Scenes.House
 19 a95f0ac6 2022-01-17 falsifian import S3D.Transformable
 20 a95f0ac6 2022-01-17 falsifian import S3D.WebUI
 21 a95f0ac6 2022-01-17 falsifian import System.Clock
 22 a95f0ac6 2022-01-17 falsifian import Web.Dom
 23 a95f0ac6 2022-01-17 falsifian import Web.Html
 24 a95f0ac6 2022-01-17 falsifian import Web.Raw.Html
 25 a95f0ac6 2022-01-17 falsifian import Web.Raw.Webgl
 26 a95f0ac6 2022-01-17 falsifian 
 27 a95f0ac6 2022-01-17 falsifian %default total
 28 a95f0ac6 2022-01-17 falsifian 
 29 a95f0ac6 2022-01-17 falsifian -- Everything the main loop needs to operate.
 30 a95f0ac6 2022-01-17 falsifian record Context where
 31 a95f0ac6 2022-01-17 falsifian   constructor MkContext
 32 a95f0ac6 2022-01-17 falsifian   ui : UIContext
 33 a95f0ac6 2022-01-17 falsifian   drawables : List Drawable
 34 a95f0ac6 2022-01-17 falsifian   obstacles : Obstacles
 35 a95f0ac6 2022-01-17 falsifian 
 36 a95f0ac6 2022-01-17 falsifian -- The compiler seems to have trouble if I just directly say makeProgram.
 37 a95f0ac6 2022-01-17 falsifian 
 38 a95f0ac6 2022-01-17 falsifian makeColourTextureProgram : WebGL2RenderingContext -> JSIO S3D.GLProgram.ColourTexture.Program
 39 a95f0ac6 2022-01-17 falsifian makeColourTextureProgram = makeProgram
 40 a95f0ac6 2022-01-17 falsifian 
 41 a95f0ac6 2022-01-17 falsifian makeSimpleColourProgram : WebGL2RenderingContext -> JSIO S3D.GLProgram.SimpleColour.Program
 42 a95f0ac6 2022-01-17 falsifian makeSimpleColourProgram = makeProgram
 43 a95f0ac6 2022-01-17 falsifian 
 44 a95f0ac6 2022-01-17 falsifian theTexturePixels : List Bits8
 45 a95f0ac6 2022-01-17 falsifian theTexturePixels =
 46 a95f0ac6 2022-01-17 falsifian            concat
 47 a95f0ac6 2022-01-17 falsifian            [ (if mod u 2 == mod v 2 then [255, 255, 255, 255] else [128, 128, 128, 255])
 48 a95f0ac6 2022-01-17 falsifian            | u <- [0 .. 7]
 49 a95f0ac6 2022-01-17 falsifian            , v <- [0 .. 7]
 50 a95f0ac6 2022-01-17 falsifian            ]
 51 a95f0ac6 2022-01-17 falsifian 
 52 a95f0ac6 2022-01-17 falsifian makeTheTexture : WebGL2RenderingContext -> Bits32 -> JSIO ()
 53 a95f0ac6 2022-01-17 falsifian makeTheTexture gl textureUnit =
 54 a95f0ac6 2022-01-17 falsifian   do texture <- unMaybe "createTexture" $ createTexture gl
 55 a95f0ac6 2022-01-17 falsifian      activeTexture gl textureUnit
 56 a95f0ac6 2022-01-17 falsifian      bindTexture gl TEXTURE_2D (Just texture)
 57 a95f0ac6 2022-01-17 falsifian      texParameteri gl TEXTURE_2D TEXTURE_WRAP_S (cast CLAMP_TO_EDGE)
 58 a95f0ac6 2022-01-17 falsifian      texParameteri gl TEXTURE_2D TEXTURE_WRAP_T (cast CLAMP_TO_EDGE)
 59 a95f0ac6 2022-01-17 falsifian      texParameteri gl TEXTURE_2D TEXTURE_MIN_FILTER (cast NEAREST)
 60 a95f0ac6 2022-01-17 falsifian      texParameteri gl TEXTURE_2D TEXTURE_MAG_FILTER (cast NEAREST)
 61 a95f0ac6 2022-01-17 falsifian      pixels <- makeUInt8Array !(fromListIO theTexturePixels)
 62 a95f0ac6 2022-01-17 falsifian      let detailLevel = 0
 63 a95f0ac6 2022-01-17 falsifian      let internalFormat = RGBA
 64 a95f0ac6 2022-01-17 falsifian      let sourceFormat = RGBA
 65 a95f0ac6 2022-01-17 falsifian      let imageDataType = UNSIGNED_BYTE
 66 a95f0ac6 2022-01-17 falsifian      let border = 0
 67 a95f0ac6 2022-01-17 falsifian      texImage2D gl TEXTURE_2D detailLevel (cast internalFormat)
 68 a95f0ac6 2022-01-17 falsifian        8 8 border sourceFormat imageDataType
 69 a95f0ac6 2022-01-17 falsifian        (Just (S (S (S (Z pixels)))))
 70 a95f0ac6 2022-01-17 falsifian 
 71 a95f0ac6 2022-01-17 falsifian swapXZ : Matrix 4 4 Double
 72 a95f0ac6 2022-01-17 falsifian swapXZ =
 73 a95f0ac6 2022-01-17 falsifian   [ [0, 0, 1, 0]
 74 a95f0ac6 2022-01-17 falsifian   , [0, 1, 0, 0]
 75 a95f0ac6 2022-01-17 falsifian   , [1, 0, 0, 0]
 76 a95f0ac6 2022-01-17 falsifian   , [0, 0, 0, 1]
 77 a95f0ac6 2022-01-17 falsifian   ]
 78 a95f0ac6 2022-01-17 falsifian 
 79 a95f0ac6 2022-01-17 falsifian covering
 80 a95f0ac6 2022-01-17 falsifian mainLoop : Context -> PhysicalState -> Clock Monotonic -> JSIO ()
 81 a95f0ac6 2022-01-17 falsifian mainLoop context physicalState time =
 82 a95f0ac6 2022-01-17 falsifian   do let gl = context.ui.gl
 83 a95f0ac6 2022-01-17 falsifian      (physicalState', viewMatrix) <-
 84 a95f0ac6 2022-01-17 falsifian        stepState context.obstacles time context.ui.state physicalState
 85 a95f0ac6 2022-01-17 falsifian      drawUniverse gl viewMatrix context.drawables
 86 a95f0ac6 2022-01-17 falsifian      requestAnimationFrame (runJS . mainLoop context physicalState')
 87 a95f0ac6 2022-01-17 falsifian 
 88 a95f0ac6 2022-01-17 falsifian partial
 89 a95f0ac6 2022-01-17 falsifian mainAfterLoad : JSIO ()
 90 a95f0ac6 2022-01-17 falsifian mainAfterLoad =
 91 a95f0ac6 2022-01-17 falsifian   do ui <- S3D.WebUI.init
 92 a95f0ac6 2022-01-17 falsifian      let gl = ui.gl
 93 a95f0ac6 2022-01-17 falsifian      enable gl DEPTH_TEST
 94 a95f0ac6 2022-01-17 falsifian      colourTextureProgram <- makeColourTextureProgram gl
 95 a95f0ac6 2022-01-17 falsifian      simpleColourProgram <- makeSimpleColourProgram gl
 96 a95f0ac6 2022-01-17 falsifian      scene <- theHouse
 97 a95f0ac6 2022-01-17 falsifian      drawables <- compileFigure gl colourTextureProgram simpleColourProgram
 98 a95f0ac6 2022-01-17 falsifian                   scene.figure
 99 a95f0ac6 2022-01-17 falsifian 
100 a95f0ac6 2022-01-17 falsifian      makeTheTexture gl TEXTURE0
101 a95f0ac6 2022-01-17 falsifian      useProgram gl (Just colourTextureProgram.program)
102 a95f0ac6 2022-01-17 falsifian      uniform1i gl (Just colourTextureProgram.textureLocation) 0
103 a95f0ac6 2022-01-17 falsifian 
104 a95f0ac6 2022-01-17 falsifian      let context =
105 a95f0ac6 2022-01-17 falsifian            MkContext
106 a95f0ac6 2022-01-17 falsifian            { ui = ui
107 a95f0ac6 2022-01-17 falsifian            , drawables = drawables
108 a95f0ac6 2022-01-17 falsifian            , obstacles = scene.obstacles
109 a95f0ac6 2022-01-17 falsifian            }
110 a95f0ac6 2022-01-17 falsifian      requestAnimationFrame (runJS . mainLoop context initialState)
111 a95f0ac6 2022-01-17 falsifian 
112 a95f0ac6 2022-01-17 falsifian partial
113 a95f0ac6 2022-01-17 falsifian main : IO ()
114 a95f0ac6 2022-01-17 falsifian main = runJS $
115 a95f0ac6 2022-01-17 falsifian   do Web.Raw.Html.GlobalEventHandlers.onload !window ?> mainAfterLoad