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