commit - dd01367cf36ebeb53ee46fbb06b46dd39f7b5082
commit + 05e64a8553086b5f509ac1c9bc723708abbf963a
blob - 0ef58fc6f8d22efd3dab6800a48d0d18ecb1ac67
blob + 1d3d1d3d2777daf48c75429a8f262a47e008dc6b
--- Main.html
+++ Main.html
<body>
<canvas id="s3d_canvas" width=300 height=300></canvas>
<br>
+ <button id="go_up_button">Go up</button>
+ <button id="go_down_button">Go down</button>
<input type="checkbox" id="hide_floor"><label for="hide_floor">hide floor</label>
</body>
</html>
blob - d623c0c40ad7169342f6bdfc5dea7c1ff365cce9
blob + 723d9298b0556d3df418b5a498c12fbe11e20f33
--- src/S3D/Controls.idr
+++ src/S3D/Controls.idr
Obstacles -> PlayerPlacement -> IORef UIState -> io PlayerPlacement
stepPlacement obstacles oldPlacement uiStateRef =
do uiState <- readIORef uiStateRef
- modifyIORef uiStateRef { touchDeltas := replicate _ [0, 0] }
+ modifyIORef uiStateRef { touchDeltas := replicate _ [0, 0]
+ , stepsToGoUp := 0
+ }
pure $
let [ [touchTurnX, touchTurnY]
, [touchMoveX, touchMoveY]
touchStrafe (-touchMoveX') $
touchLookUp (-touchTurnY) $
touchTurn (-touchTurnX) $
+ moveUp uiState.stepsToGoUp $
placementFromKeyboard
- in if collision (position attemptedPlacement) obstacles
+ in -- Don't detect collisions when the player is below floor level.
+ if playerHeight attemptedPlacement > 0 &&
+ collision (position attemptedPlacement) obstacles
then oldPlacement
else attemptedPlacement
blob - 34c8cde0d11f7f527852eca497bf5cb0ccd096b6
blob + 79c7232e16769823d29101e473ed44b6e9727261
--- src/S3D/Player.idr
+++ src/S3D/Player.idr
||| The distance from the floor to the player's eyes, in radians.
export
-playerHeight : Double
-playerHeight = pi * 3 / 32
+initialPlayerHeight : Double
+initialPlayerHeight = pi * 3 / 32
blob - 0bf2a1fce63a1059a5f1e1d7fec8d4c44e1e897a
blob + 1bf5d83cf35ce149b7596f8eb4f1e66630defaf2
--- src/S3D/PlayerMovement.idr
+++ src/S3D/PlayerMovement.idr
-}
-moveStep, turnStepAngle, upDownLevelStep : Double
+moveStep, turnStepAngle : Double
-- How far the player moves in one frame, in radians.
moveStep = pi / 60
-- How much the player turns in one frame, in radians.
turnStepAngle = pi / 15
+-- How many radians the player goes up or down when they click the button
+heightStep = pi / 32
+
-- How much the player can turn their head up or down in one frame, in radians.
-upDownStep = pi / 20
+gazeHeightStep = pi / 20
-- The player's position and orientation.
-- To the player's right. Computed from position and forward in
-- normalizePlacement.
right : Vector 4 Double
+ -- How far above the ground the player is, in radians.
+ height : Double
-- pi/2 if the player is looking straight up, -pi/2 if they're looking stright
-- down.
- upDown : Double
+ gazeHeight : Double
+export
+playerHeight : PlayerPlacement -> Double
+playerHeight = (.height)
+
||| The player's position
export
position : PlayerPlacement -> Vector 4 Double
}
placement
--- Adjust the player's position so they are playerHeight radians above the ground.
+-- Adjust the player's position so they are height radians above the ground.
--
-- Input need not be normalized. Output will be normalized.
-adjustHeight : Vector 4 Double -> Vector 4 Double
-adjustHeight v =
+adjustHeight : (height : Double) -> Vector 4 Double -> Vector 4 Double
+adjustHeight height v =
let [x, y, z, w] = vectorToVect v
nonYNorm = norm $ the (Vector 3 Double) [x, z, w]
- nonYMult = cos playerHeight / nonYNorm
- in [x * nonYMult, sin playerHeight, z * nonYMult, w * nonYMult]
+ nonYMult = cos height / nonYNorm
+ in [x * nonYMult, sin height, z * nonYMult, w * nonYMult]
export
initialPlacement : PlayerPlacement
MkPlayerPlacement
{ -- We avoid setting coordinates to zero to avoid an edge case where points
-- end with w=0 in view coordinates.
- position = (adjustHeight [0.001, 0, -1, 0.0001])
+ position = (adjustHeight initialPlayerHeight [0.001, 0, -1, 0.0001])
, forward = [0, 0, 0, 1]
, right = [1, 0, 0, 0]
- , upDown = 0
+ , height = initialPlayerHeight
+ , gazeHeight = 0
}
-- Move the player the given distance (in radians) in the given direction.
move : Double -> Vector 4 Double -> PlayerPlacement -> PlayerPlacement
move distance direction placement =
normalizePlacement $
- { position := adjustHeight $
+ { position := adjustHeight placement.height $
cos distance *^ placement.position ^+^
sin distance *^ direction
}
touchTurn : Double -> PlayerPlacement -> PlayerPlacement
touchTurn = turn
+-- The player moves up or down.
+export
+moveUp : Double -> PlayerPlacement -> PlayerPlacement
+moveUp angle placement =
+ { height := min (pi/2) (max (-pi/2) (placement.height + angle * heightStep)) }
+ placement
+
-- The player looks up or down.
lookUp : Double -> PlayerPlacement -> PlayerPlacement
lookUp angle =
- { upDown $= \ ud => min (pi/2) (max (-pi/2) (ud + angle))
+ { gazeHeight $= \ ud => min (pi/2) (max (-pi/2) (ud + angle))
}
-- The player looks up (sign=1) or down (sign=-1).
export
oneFrameLookUp : Double -> PlayerPlacement -> PlayerPlacement
-oneFrameLookUp sign = lookUp (sign * upDownStep)
+oneFrameLookUp sign = lookUp (sign * gazeHeightStep)
-- Look up or down by an amount appropriate for a touch gesture.
export
-- The inverse of the matrix with columns (right, up, -position, forward).
-- Since everything's orthonormal, the transpose is the inverse.
let placementUp = up placement
- cosUpDown = cos placement.upDown
- sinUpDown = sin placement.upDown
+ cosGazeHeight = cos placement.gazeHeight
+ sinGazeHeight = sin placement.gazeHeight
in
transpose
[ placement.right
- , cosUpDown *^ placementUp ^-^ sinUpDown *^ placement.forward
+ , cosGazeHeight *^ placementUp ^-^ sinGazeHeight *^ placement.forward
, negateVector placement.position
- , cosUpDown *^ placement.forward ^+^ sinUpDown *^ placementUp
+ , cosGazeHeight *^ placement.forward ^+^ sinGazeHeight *^ placementUp
]
-
-export
-Show PlayerPlacement where
- show placement = "pos: " ++ show placement.position ++ "; fwd: " ++ show placement.forward ++ "; right: " ++ show placement.right ++ "; up: " ++ show (up placement) ++ "; ud: " ++ show placement.upDown
blob - 35dbb4ba3ff1ea66f8a156bf8a1e973a2589fa33
blob + 5633c7e04738be3621b0a09140f68bda2a9fe5ad
--- src/S3D/WebUI.idr
+++ src/S3D/WebUI.idr
||| index (numTouches-1) numDeltas is how much touchCentre has changed since
||| the last physics update while numTouches touches were active.
touchDeltas : Vect WebUI.maxTouches (Vector 2 Double)
+ ||| The number of times the user has pressed "Go up" minus "Go down" since
+ ||| the last update.
+ stepsToGoUp : Double
public export
record UIContext where
}
state
+handleGoUpDown : Double -> IORef UIState -> JSIO ()
+handleGoUpDown change stateRef =
+ modifyIORef stateRef $
+ { stepsToGoUp $= (+change) }
+
+addUpDownHandlers : Document -> IORef UIState -> JSIO ()
+addUpDownHandlers theDocument stateRef =
+ do Just goUpButton <- htmlElementById Button "go_up_button"
+ | Nothing => throwError $ Caught "go_up_button not found, or isn't a button"
+ Just goDownButton <- htmlElementById Button "go_down_button"
+ | Nothing => throwError $ Caught "go_down_button not found, or isn't a button"
+ onclick goUpButton ?> handleGoUpDown 1 stateRef
+ onclick goDownButton ?> handleGoUpDown (-1) stateRef
+
export
init : JSIO UIContext
init =
{ keysDown = empty
, touchCentre = [0, 0]
, touchDeltas = replicate _ [0, 0]
+ , stepsToGoUp = 0
}
-- Keyboard events
addEventListener' theDocument "keydown" (Just !(callback (handleKeyDown state)))
-- Uncheck the "hide floor" checkbox. Firefox persists checkbox states,
-- which could cause confusion if someone accidentally checks that.
checked hideFloorCheckbox .= False
+ addUpDownHandlers theDocument state
pure $
MkUIContext
{ canvas = canvas
