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 388ebd57 2022-01-17 falsifian   ||| The floor
 35 388ebd57 2022-01-17 falsifian   floorDrawables : List Drawable
 36 a95f0ac6 2022-01-17 falsifian   obstacles : Obstacles
 37 a95f0ac6 2022-01-17 falsifian 
 38 a95f0ac6 2022-01-17 falsifian -- The compiler seems to have trouble if I just directly say makeProgram.
 39 a95f0ac6 2022-01-17 falsifian 
 40 a95f0ac6 2022-01-17 falsifian makeColourTextureProgram : WebGL2RenderingContext -> JSIO S3D.GLProgram.ColourTexture.Program
 41 a95f0ac6 2022-01-17 falsifian makeColourTextureProgram = makeProgram
 42 a95f0ac6 2022-01-17 falsifian 
 43 a95f0ac6 2022-01-17 falsifian makeSimpleColourProgram : WebGL2RenderingContext -> JSIO S3D.GLProgram.SimpleColour.Program
 44 a95f0ac6 2022-01-17 falsifian makeSimpleColourProgram = makeProgram
 45 a95f0ac6 2022-01-17 falsifian 
 46 a95f0ac6 2022-01-17 falsifian theTexturePixels : List Bits8
 47 a95f0ac6 2022-01-17 falsifian theTexturePixels =
 48 a95f0ac6 2022-01-17 falsifian            concat
 49 a95f0ac6 2022-01-17 falsifian            [ (if mod u 2 == mod v 2 then [255, 255, 255, 255] else [128, 128, 128, 255])
 50 a95f0ac6 2022-01-17 falsifian            | u <- [0 .. 7]
 51 a95f0ac6 2022-01-17 falsifian            , v <- [0 .. 7]
 52 a95f0ac6 2022-01-17 falsifian            ]
 53 a95f0ac6 2022-01-17 falsifian 
 54 a95f0ac6 2022-01-17 falsifian makeTheTexture : WebGL2RenderingContext -> Bits32 -> JSIO ()
 55 a95f0ac6 2022-01-17 falsifian makeTheTexture gl textureUnit =
 56 a95f0ac6 2022-01-17 falsifian   do texture <- unMaybe "createTexture" $ createTexture gl
 57 a95f0ac6 2022-01-17 falsifian      activeTexture gl textureUnit
 58 a95f0ac6 2022-01-17 falsifian      bindTexture gl TEXTURE_2D (Just texture)
 59 a95f0ac6 2022-01-17 falsifian      texParameteri gl TEXTURE_2D TEXTURE_WRAP_S (cast CLAMP_TO_EDGE)
 60 a95f0ac6 2022-01-17 falsifian      texParameteri gl TEXTURE_2D TEXTURE_WRAP_T (cast CLAMP_TO_EDGE)
 61 a95f0ac6 2022-01-17 falsifian      texParameteri gl TEXTURE_2D TEXTURE_MIN_FILTER (cast NEAREST)
 62 a95f0ac6 2022-01-17 falsifian      texParameteri gl TEXTURE_2D TEXTURE_MAG_FILTER (cast NEAREST)
 63 a95f0ac6 2022-01-17 falsifian      pixels <- makeUInt8Array !(fromListIO theTexturePixels)
 64 a95f0ac6 2022-01-17 falsifian      let detailLevel = 0
 65 a95f0ac6 2022-01-17 falsifian      let internalFormat = RGBA
 66 a95f0ac6 2022-01-17 falsifian      let sourceFormat = RGBA
 67 a95f0ac6 2022-01-17 falsifian      let imageDataType = UNSIGNED_BYTE
 68 a95f0ac6 2022-01-17 falsifian      let border = 0
 69 a95f0ac6 2022-01-17 falsifian      texImage2D gl TEXTURE_2D detailLevel (cast internalFormat)
 70 a95f0ac6 2022-01-17 falsifian        8 8 border sourceFormat imageDataType
 71 a95f0ac6 2022-01-17 falsifian        (Just (S (S (S (Z pixels)))))
 72 a95f0ac6 2022-01-17 falsifian 
 73 a95f0ac6 2022-01-17 falsifian swapXZ : Matrix 4 4 Double
 74 a95f0ac6 2022-01-17 falsifian swapXZ =
 75 a95f0ac6 2022-01-17 falsifian   [ [0, 0, 1, 0]
 76 a95f0ac6 2022-01-17 falsifian   , [0, 1, 0, 0]
 77 a95f0ac6 2022-01-17 falsifian   , [1, 0, 0, 0]
 78 a95f0ac6 2022-01-17 falsifian   , [0, 0, 0, 1]
 79 a95f0ac6 2022-01-17 falsifian   ]
 80 a95f0ac6 2022-01-17 falsifian 
 81 a95f0ac6 2022-01-17 falsifian covering
 82 a95f0ac6 2022-01-17 falsifian mainLoop : Context -> PhysicalState -> Clock Monotonic -> JSIO ()
 83 a95f0ac6 2022-01-17 falsifian mainLoop context physicalState time =
 84 a95f0ac6 2022-01-17 falsifian   do let gl = context.ui.gl
 85 a95f0ac6 2022-01-17 falsifian      (physicalState', viewMatrix) <-
 86 a95f0ac6 2022-01-17 falsifian        stepState context.obstacles time context.ui.state physicalState
 87 388ebd57 2022-01-17 falsifian      let drawables = if !(floorEnabled context.ui)
 88 388ebd57 2022-01-17 falsifian                      then context.drawables ++ context.floorDrawables
 89 388ebd57 2022-01-17 falsifian                      else context.drawables
 90 388ebd57 2022-01-17 falsifian      drawUniverse gl viewMatrix drawables
 91 a95f0ac6 2022-01-17 falsifian      requestAnimationFrame (runJS . mainLoop context physicalState')
 92 a95f0ac6 2022-01-17 falsifian 
 93 a95f0ac6 2022-01-17 falsifian partial
 94 a95f0ac6 2022-01-17 falsifian mainAfterLoad : JSIO ()
 95 a95f0ac6 2022-01-17 falsifian mainAfterLoad =
 96 a95f0ac6 2022-01-17 falsifian   do ui <- S3D.WebUI.init
 97 a95f0ac6 2022-01-17 falsifian      let gl = ui.gl
 98 a95f0ac6 2022-01-17 falsifian      enable gl DEPTH_TEST
 99 a95f0ac6 2022-01-17 falsifian      colourTextureProgram <- makeColourTextureProgram gl
100 a95f0ac6 2022-01-17 falsifian      simpleColourProgram <- makeSimpleColourProgram gl
101 a95f0ac6 2022-01-17 falsifian      scene <- theHouse
102 a95f0ac6 2022-01-17 falsifian      drawables <- compileFigure gl colourTextureProgram simpleColourProgram
103 a95f0ac6 2022-01-17 falsifian                   scene.figure
104 388ebd57 2022-01-17 falsifian      floorDrawables <-
105 388ebd57 2022-01-17 falsifian        compileFigure gl colourTextureProgram simpleColourProgram
106 388ebd57 2022-01-17 falsifian        theFloor
107 a95f0ac6 2022-01-17 falsifian 
108 a95f0ac6 2022-01-17 falsifian      makeTheTexture gl TEXTURE0
109 a95f0ac6 2022-01-17 falsifian      useProgram gl (Just colourTextureProgram.program)
110 a95f0ac6 2022-01-17 falsifian      uniform1i gl (Just colourTextureProgram.textureLocation) 0
111 a95f0ac6 2022-01-17 falsifian 
112 a95f0ac6 2022-01-17 falsifian      let context =
113 a95f0ac6 2022-01-17 falsifian            MkContext
114 a95f0ac6 2022-01-17 falsifian            { ui = ui
115 a95f0ac6 2022-01-17 falsifian            , drawables = drawables
116 388ebd57 2022-01-17 falsifian            , floorDrawables = floorDrawables
117 a95f0ac6 2022-01-17 falsifian            , obstacles = scene.obstacles
118 a95f0ac6 2022-01-17 falsifian            }
119 a95f0ac6 2022-01-17 falsifian      requestAnimationFrame (runJS . mainLoop context initialState)
120 a95f0ac6 2022-01-17 falsifian 
121 a95f0ac6 2022-01-17 falsifian partial
122 a95f0ac6 2022-01-17 falsifian main : IO ()
123 a95f0ac6 2022-01-17 falsifian main = runJS $
124 a95f0ac6 2022-01-17 falsifian   do Web.Raw.Html.GlobalEventHandlers.onload !window ?> mainAfterLoad