From f19e16557154e32a194996e8eef5bc5f9a71ce1f Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 10 Apr 2026 11:19:16 +0100 Subject: [PATCH] Fix terminal shape --- src/Dodge/Creature/Picture.hs | 2 +- src/Dodge/Creature/State/WalkCycle.hs | 6 +++--- src/Dodge/Creature/Update.hs | 7 +++--- src/Dodge/Data/Creature/Stance.hs | 4 ++-- src/Dodge/Machine/Draw.hs | 6 ++++-- src/Dodge/Render/ShapePicture.hs | 4 ++-- src/Dodge/Room/Tutorial.hs | 7 +++--- src/Shape.hs | 31 ++++++++++++++++----------- 8 files changed, 36 insertions(+), 31 deletions(-) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index ea796eead..dd72171fa 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -187,7 +187,7 @@ crabFeet _ cr = f p q = q + 2 *^ (p - q) cdir = -cr ^. crDir cxy = cr ^. crPos . _xy - afoot = upperPrismPolyST 10 $ polyCirc 3 2 + afoot = upperPrismPolyHalfST 10 $ polyCirc 3 2 (r1,r2) = spiderJoint (0 & _xy .~ rpos) (V3 0 2 5) rpos' = f (V2 0 10) rpos (r1',r2') = spiderJoint (0 & _xy .~ rpos') (V3 0 2 5) diff --git a/src/Dodge/Creature/State/WalkCycle.hs b/src/Dodge/Creature/State/WalkCycle.hs index 8f0e3e2be..3711cdb85 100644 --- a/src/Dodge/Creature/State/WalkCycle.hs +++ b/src/Dodge/Creature/State/WalkCycle.hs @@ -33,16 +33,16 @@ updateCarriage' cid cr w = \case & tocr . crStance . carriage . zSpeed %~ if cr ^. crPos . _z < 17 then min 0.05 . (+0.001) else max (-0.05) . subtract 0.001 Boosting {} -> w - Falling {_fallRot = q} -> + Falling {_fallRot = q, _carDir = q'} -> let v = 0.95 *^ (cr ^. crOldPos - oop & _z -~ 0.5) ep = cr ^. crPos + v in if ep ^. _z < 0 && cr ^. crOldPos . _z >= 0 && (not (any (pointInPoly (ep ^. _xy)) (w ^. cWorld . chasms)) || any (uncurry $ crOnSeg cr) (w ^. cWorld . cliffs)) then w & tocr . crPos .~ (ep & _z .~ 0) - & cWorld . lWorld . creatures . ix cid . crStance . carriage .~ OnGround + & cWorld . lWorld . creatures . ix cid . crStance . carriage .~ OnGround q' else w & cWorld . lWorld . creatures . ix cid . crPos .~ ep - & cWorld . lWorld . creatures . ix cid . crStance . carriage . fallDir *~ q + & cWorld . lWorld . creatures . ix cid . crStance . carriage . carDir *~ q OnGround {} -> w & tocr . crPos . _xy +~ 0.8 *^ (cr ^. crOldPos . _xy - oop ^. _xy) diff --git a/src/Dodge/Creature/Update.hs b/src/Dodge/Creature/Update.hs index 9406d8620..5f7923022 100644 --- a/src/Dodge/Creature/Update.hs +++ b/src/Dodge/Creature/Update.hs @@ -55,9 +55,8 @@ updateLivingCreature cr = ChaseCrit{} -> \w -> crUpdate cid . performActions cid $ over (cWorld . lWorld . creatures . ix cid) (chaseCritInternal w) w - CrabCrit{} -> \w -> - crUpdate cid . performActions cid $ - crabCritInternal cid w + CrabCrit{} -> + crUpdate cid . performActions cid . crabCritInternal cid AutoCrit {} -> crUpdate cid SwarmCrit {} -> crUpdate cid HoverCrit {} -> \w -> @@ -129,7 +128,7 @@ startDeathTimer cr = cr toDeathCarriage :: Carriage -> Carriage toDeathCarriage = \case Flying {} -> Falling Q.qid Q.qid - Walking -> OnGround + Walking -> OnGround Q.qid _ -> Falling Q.qid Q.qid -- could look at the amount of damage here (given by maxDamage) too diff --git a/src/Dodge/Data/Creature/Stance.hs b/src/Dodge/Data/Creature/Stance.hs index 9a2001e62..624c31f61 100644 --- a/src/Dodge/Data/Creature/Stance.hs +++ b/src/Dodge/Data/Creature/Stance.hs @@ -25,8 +25,8 @@ data Carriage | Floating | Flying {_zSpeed :: Float, _flyInertia :: Float} | Boosting Point2 - | Falling {_fallRot :: Quaternion Float, _fallDir :: Quaternion Float} - | OnGround + | Falling {_fallRot :: Quaternion Float, _carDir :: Quaternion Float} + | OnGround {_carDir :: Quaternion Float} deriving (Eq, Ord, Show, Read) --Generic, Flat) data FootForward = LeftForward | RightForward diff --git a/src/Dodge/Machine/Draw.hs b/src/Dodge/Machine/Draw.hs index 757ae58b0..68595ef54 100644 --- a/src/Dodge/Machine/Draw.hs +++ b/src/Dodge/Machine/Draw.hs @@ -1,5 +1,6 @@ module Dodge.Machine.Draw (drawMachine,mcColor) where +import Linear import Control.Lens import qualified Data.Map.Strict as M import Data.Maybe @@ -56,11 +57,12 @@ terminalShape lw mc = fromMaybe mempty $ do ( prismBox Medium Typical - [V3 10 10 20, V3 (-10) 10 20, V3 (-10) (-10) 10, V3 10 (-10) 10] - (addZ 0 `map` rectWH 10 10) + tps + (tps & each . _z .~ 0) ) <> screenbackground (getcol term) where + tps = [V3 10 10 20, V3 (-10) 10 20, V3 (-10) (-10) 10, V3 10 (-10) 10] getcol term = fromMaybe black $ termScreenColor term screenbackground col = colorSH diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index d11552349..bf86ba92e 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -123,8 +123,8 @@ drawCreature w m cr = translateSP (_crPos cr) . fallrot . rotateSP (_crDir cr) $ CrabCrit {} -> noPic $ drawCrabCrit w cr HoverCrit{} -> noPic $ drawHoverCrit cr where - fallrot = case cr ^. crStance . carriage of - Falling {_fallDir = q} -> _1 . each . sfVs . each %~ Q.rotate q + fallrot = case cr ^? crStance . carriage . carDir of + Just q -> _1 . each . sfVs . each %~ Q.rotate q _ -> id barrelShape :: SPic diff --git a/src/Dodge/Room/Tutorial.hs b/src/Dodge/Room/Tutorial.hs index eecf4410a..55fa3405e 100644 --- a/src/Dodge/Room/Tutorial.hs +++ b/src/Dodge/Room/Tutorial.hs @@ -339,14 +339,13 @@ chasmSpitTerminal = do , [sps0 $ putShape $ gird (V2 0 20) (V2 300 20), sps0 $ putShape $ gird (V2 0 280) (V2 300 280)] ] let y' = y & rmPmnts <>~ ls <> dec + cr = PutCrit chaseCrit return $ tToBTree "chasmTerm" $ Node (addDoorToggleTerminal' i1 (PS 150 0) y') - [ treePost [triggerDoorRoom i1, deadEndPSType (PutCrit crabCrit)] - --[ treePost [triggerDoorRoom i1, deadEndPSType (PutCrit hoverCrit)] - --[ treePost [triggerDoorRoom i1, deadEndRoom] - , treePost [triggerDoorRoom i1, deadEndPSType (PutCrit crabCrit)] + [ treePost [triggerDoorRoom i1, deadEndPSType cr] + , treePost [triggerDoorRoom i1, deadEndPSType cr] , return $ cleatOnward $ triggerDoorRoom i1 ] where diff --git a/src/Shape.hs b/src/Shape.hs index ac5fcbc70..34330018b 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -17,6 +17,7 @@ module Shape ( upperPrismPolyHalf, upperPrismPolyHalfMI, upperPrismPolyHalfST, + upperPrismPolyScale, xCylinderST, prismPoly, prismBox, @@ -57,12 +58,7 @@ polyCircx n = map (vNormaly . addZ 0) . polyCirc n -- points should be correctly ordered so that -- polys form a prism-like object with quad faces between them -- each layer of points must be arranged anticlockwise -prismPoly :: - Size -> - Importance -> - [Point3] -> - [Point3] -> - Shape +prismPoly :: Size -> Importance -> [Point3] -> [Point3] -> Shape {-# INLINE prismPoly #-} prismPoly size shads upps downps = [Surface (RoundedFaces n) (cp : cp : f upps downps) white shads size] where @@ -201,13 +197,7 @@ upperPrismPolyHalfMI = upperPrismPolyHalf Medium Important upperPrismPolyHalfST :: Float -> [Point2] -> Shape upperPrismPolyHalfST = upperPrismPolyHalf Small Typical -upperPrismPolyHalf :: - -- | height, expected to be strictly positive - Size -> - Importance -> - Float -> - [Point2] -> - Shape +upperPrismPolyHalf :: Size -> Importance -> Float -> [Point2] -> Shape {-# INLINE upperPrismPolyHalf #-} upperPrismPolyHalf size shad h ps = prismPoly size shad upps downps where @@ -216,6 +206,21 @@ upperPrismPolyHalf size shad h ps = prismPoly size shad upps downps f (V2 x y) = V3 (0.5 * x) (0.5 * y) h g (V2 x y) = V3 x y 0 +upperPrismPolyScale :: + Float -> + Size -> + Importance -> + Float -> + [Point2] -> + Shape +{-# INLINE upperPrismPolyScale #-} +upperPrismPolyScale s size shad h ps = prismPoly size shad upps downps + where + upps = map f ps + downps = map g ps + f (V2 x y) = V3 (s * x) (s * y) h + g (V2 x y) = V3 x y 0 + upperBoxHalf :: -- | height, expected to be strictly positive Size ->