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