commit 05e64a8553086b5f509ac1c9bc723708abbf963a from: James Cook date: Tue Jan 18 00:13:10 2022 UTC Add buttons to move up and down. commit - dd01367cf36ebeb53ee46fbb06b46dd39f7b5082 commit + 05e64a8553086b5f509ac1c9bc723708abbf963a blob - 0ef58fc6f8d22efd3dab6800a48d0d18ecb1ac67 blob + 1d3d1d3d2777daf48c75429a8f262a47e008dc6b --- Main.html +++ Main.html @@ -7,6 +7,8 @@

+ + hide floor blob - d623c0c40ad7169342f6bdfc5dea7c1ff365cce9 blob + 723d9298b0556d3df418b5a498c12fbe11e20f33 --- src/S3D/Controls.idr +++ src/S3D/Controls.idr @@ -32,7 +32,9 @@ stepPlacement : HasIO io => 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] @@ -65,7 +67,10 @@ stepPlacement obstacles oldPlacement uiStateRef = 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 @@ -4,5 +4,5 @@ module S3D.Player ||| 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 @@ -26,7 +26,7 @@ Constants -} -moveStep, turnStepAngle, upDownLevelStep : Double +moveStep, turnStepAngle : Double -- How far the player moves in one frame, in radians. moveStep = pi / 60 @@ -34,8 +34,11 @@ 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. @@ -50,10 +53,16 @@ record PlayerPlacement where -- 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 @@ -71,15 +80,15 @@ normalizePlacement placement = } 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 @@ -87,10 +96,11 @@ initialPlacement = normalizePlacement $ 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. @@ -99,7 +109,7 @@ initialPlacement = normalizePlacement $ 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 } @@ -150,16 +160,23 @@ export 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 @@ -176,16 +193,12 @@ playerViewMatrix placement = -- 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 @@ -29,6 +29,9 @@ record UIState where ||| 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 @@ -109,6 +112,20 @@ handleTouchMove stateRef event = } 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 = @@ -121,6 +138,7 @@ init = { keysDown = empty , touchCentre = [0, 0] , touchDeltas = replicate _ [0, 0] + , stepsToGoUp = 0 } -- Keyboard events addEventListener' theDocument "keydown" (Just !(callback (handleKeyDown state))) @@ -136,6 +154,7 @@ init = -- 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