Prop reification/splitting

2022-07-24 13:45:05 +01:00
parent 5a2f529182
commit ac069d08f6
31 changed files with 585 additions and 458 deletions
@@ -0,0 +1,87 @@
+module Dodge.Prop.Draw
+    where
+import Geometry.Polygon
+import Geometry.Data
+import Dodge.Data.Prop
+import ShapePicture
+import Shape
+import Picture
+import qualified Quaternion as Q
+
+drawProp' :: Prop -> SPic
+drawProp' pr = drawProp (_prDraw pr) pr
+
+drawProp :: PropDraw -> Prop -> SPic
+drawProp pd = case pd of
+    PropDrawSPic spic -> const spic
+    PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (fst $ drawProp pd' pr)
+    PropDrawMovingShapeCol sh -> \pr -> drawMovingShapeCol pr sh
+    PropDoubleLampCover h -> drawDoubleLampCover h
+    PropVerticalLampCover h -> drawVerticalLampCover h
+    PropLampCover h -> drawLampCover h
+    PropDrawToggle pd' -> propDrawToggle pd'
+    PropDrawGib x -> noPic . drawGib x
+    PropDrawFlatTranslate x -> \pr 
+        -> uncurryV translateSPf (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr
+
+drawGib :: Float -> Prop -> Shape
+drawGib x pr = flesh <> skin
+  where
+    flesh = colorSH (dark $ dark red)
+        . translateSHz (negate x)
+        $ upperPrismPoly (2*x) $ square x
+    skin = colorSH (_prColor pr)
+        . translateSH (V3 1 1 (1 - x))
+        $ upperPrismPoly (2*x) $ square x
+
+propDrawToggle :: PropDraw -> Prop -> SPic
+propDrawToggle pd pr
+    | not (_prToggle pr) = mempty
+    | otherwise = drawProp pd pr
+
+drawLampCover :: Float -> Prop -> SPic
+drawLampCover h pr = ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
+    $ rotateSH (_prRot pr) $ mconcat
+    [ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2    (-1) 3 
+    , translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2    3 
+    , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2    (-1) 3 
+    , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2    3 
+    , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
+    ]
+    , mempty
+    )
+
+drawVerticalLampCover :: Float -> Prop -> SPic
+drawVerticalLampCover h pr =
+    ( translateSHz h . uncurryV translateSHf (_prPos pr) 
+        $ rotateSHx (_prRot pr) $ mconcat
+        [ 
+        translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
+        ]
+    , mempty
+    )
+
+drawMovingShape :: Prop -> Shape -> SPic
+drawMovingShape pr = noPic
+    . translateSHz (_prPosZ pr)
+    . uncurryV translateSHf (_prPos pr) 
+    . overPosSH (Q.rotate (_prQuat pr))
+
+drawMovingShapeCol :: Prop -> Shape -> SPic
+drawMovingShapeCol pr = noPic
+    . translateSHz (_prPosZ pr)
+    . uncurryV translateSHf (_prPos pr) 
+    . overPosSH (Q.rotate (_prQuat pr))
+    . colorSH (_prColor pr)
+
+drawDoubleLampCover :: Float -> Prop -> SPic
+drawDoubleLampCover h pr =
+    ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr) 
+        $ rotateSH (_prRot pr) $ mconcat
+        [ upperPrismPoly 5 $ reverse $ rectNSWE 6 5       (-6) 6
+        , upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6
+        , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
+        , upperPrismPoly 1 [V2 0   1 ,V2 (-6) (-5),V2 6 (-5)]
+        ]
+    , mempty
+    )
@@ -1,16 +1,11 @@
 module Dodge.Prop.Gib where
-import Dodge.Prop.Moving
--import Dodge.Zone
 import Dodge.Base
 import Dodge.Data
 import Dodge.Damage
--import ShapePicture
-import Shape
 import Geometry
 import Color
 import LensHelp
 import RandomHelp
--import Dodge.Base.NewID

 import qualified Quaternion as Q
 import Data.List (zip4)
@@ -19,28 +14,18 @@ import Data.Foldable
 aGib :: Prop
 aGib = PropZ
    {_prPos = 0
-    ,_pjStartPos = 0
-    ,_pjVel = 0
-    ,_prDraw = \pr -> drawMovingShape pr (drawGib 3 pr)
-    ,_pjID = 0
-    ,_pjUpdate = fallSmallBounce
-    ,_pjPosZ = 10
-    ,_pjVelZ = 5
-    ,_pjTimer = 20
-    ,_pjQuat = Q.axisAngle (V3 1 0 0) 0
-    ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
-    ,_pjColor = white
+    ,_prStartPos = 0
+    ,_prVel = 0
+    ,_prDraw = PropDrawMovingShape (PropDrawGib 3)
+    ,_prID = 0
+    ,_prUpdate = PropFallSmallBounce
+    ,_prPosZ = 10
+    ,_prVelZ = 5
+    ,_prTimer = 20
+    ,_prQuat = Q.axisAngle (V3 1 0 0) 0
+    ,_prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
+    ,_prColor = white
    }
-drawGib :: Float -> Prop -> Shape
-drawGib x pr = flesh <> skin
-  where
-    flesh = colorSH (dark $ dark red)
-        . translateSHz (negate x)
-        $ upperPrismPoly (2*x) $ square x
-    skin = colorSH (_pjColor pr)
-        . translateSH (V3 1 1 (1 - x))
-        $ upperPrismPoly (2*x) $ square x
-

 addCrGibs :: Creature -> World -> World
 addCrGibs cr w = case damageDirection $ _csDamage $ _crState cr of
@@ -83,18 +68,18 @@ addGibsAtDir dir minh maxh col p w = foldl' (flip $ addGib4 p col) w (zip4 vels
  
 addGib4 :: Point2 -> Color -> (Point2, Float, Q.Quaternion Float, Float)
    -> World -> World
-addGib4 p col (v,zs,q,h) = plNew props pjID (aGib & prPos .~ p +.+ (5 *.* normalizeV v)
-    & pjColor .~ col
-    & pjVel .~ v
-    & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-    & pjQuat .~ q
-    & pjVelZ .~ zs
-    & pjPosZ .~ h
+addGib4 p col (v,zs,q,h) = plNew props prID (aGib & prPos .~ p +.+ (5 *.* normalizeV v)
+    & prColor .~ col
+    & prVel .~ v
+    & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+    & prQuat .~ q
+    & prVelZ .~ zs
+    & prPosZ .~ h
    )

 addGibAt :: Float -> Color -> Point2 -> World -> World
 addGibAt h col p w = w
-    & plNew props pjID gib
+    & plNew props prID gib
    & randGen .~ newg
  where
    (gib,newg) = runState f $ _randGen w
@@ -106,16 +91,16 @@ addGibAt h col p w = w
        let v = s *.* dir
        return $ aGib
            & prPos .~ p
-            & pjColor .~ col
-            & pjVel .~ v
-            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-            & pjQuat .~ q
-            & pjVelZ .~ zs
-            & pjPosZ .~ h
+            & prColor .~ col
+            & prVel .~ v
+            & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            & prQuat .~ q
+            & prVelZ .~ zs
+            & prPosZ .~ h

 addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World
 addGibAtDir dir h col p w = w
-    & plNew props pjID gib
+    & plNew props prID gib
    & randGen .~ newg
  where
    (gib,newg) = runState f $ _randGen w
@@ -126,9 +111,9 @@ addGibAtDir dir h col p w = w
        let v = s *.* unitVectorAtAngle dir
        return $ aGib
            & prPos .~ p
-            & pjColor .~ col
-            & pjVel .~ v
-            & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-            & pjQuat .~ q
-            & pjVelZ .~ zs
-            & pjPosZ .~ h
+            & prColor .~ col
+            & prVel .~ v
+            & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+            & prQuat .~ q
+            & prVelZ .~ zs
+            & prPosZ .~ h
@@ -1,77 +1,52 @@
 module Dodge.Prop.Moving 
-    ( drawMovingShape
-    , drawMovingShapeCol
-    , fallSmallBounceDamage
+    ( fallSmallBounceDamage
    , fallSmallBounce
    ) where
--import Dodge.Zone
 import Dodge.Base
 import Dodge.Data
--import Dodge.Damage
-import ShapePicture
-import Shape
 import Geometry
--import Color
 import LensHelp
--import RandomHelp
--import Dodge.Base.NewID
-
-import qualified Quaternion as Q
--import Data.List (zip4)
--
 fallSmallBounceDamage :: Prop -> World -> World
 fallSmallBounceDamage pr w = w 
    & dodamage
-    & props . ix (_pjID pr) %~ fallSmallBounce' w
+    & props . ix (_prID pr) %~ fallSmallBounce' w
  where
    p = _prPos pr
-    v = _pjVel pr
+    v = _prVel pr
    dodamage
-        | _pjPosZ pr < 25 = creatures %~ fmap dodamage'
+        | _prPosZ pr < 25 = creatures %~ fmap dodamage'
        | otherwise = id
    dodamage' cr
        | dist (_crPos cr) p < _crRad cr + 5 = cr & crState . csDamage 
-            .:~ Damage CRUSHING (floor . (*10) . max 0 . subtract 5 . abs $ _pjVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect
+            .:~ Damage CRUSHING (floor . (*10) . max 0 . subtract 5 . abs $ _prVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect
        | otherwise = cr

 fallSmallBounce :: Prop -> World -> World
 fallSmallBounce pr w = w 
-    & props . ix (_pjID pr) %~ fallSmallBounce' w
+    & props . ix (_prID pr) %~ fallSmallBounce' w

 fallSmallBounce' :: World -> Prop -> Prop
 fallSmallBounce' w pr
    | newposz < 0 && velz < (-2) = pr 
-        & pjVelZ %~ ((*0.5) . negate)
+        & prVelZ %~ ((*0.5) . negate)
 --        & pjPos +~ (0.5*.* vel)
        & updateWithVel (0.5 *.* vel)
-        & pjVel %~ (0.5 *.*)
+        & prVel %~ (0.5 *.*)
 --        & pjPos +~ (0.5*.* vel)
-    | newposz < 0 = pr & pjUpdate .~ const id
-        & pjZ .~ 0
+    | newposz < 0 = pr & prUpdate .~ PropUpdateId
+        & prPosZ .~ 0
 --        & pjQuat *~ (_pjQuatSpin pr)
    | otherwise = pr
-        & pjVelZ -~ 1
-        & pjPosZ +~ velz
+        & prVelZ -~ 1
+        & prPosZ +~ velz
        & updateWithVel vel
-        & pjQuat *~ _pjQuatSpin pr
+        & prQuat *~ _prQuatSpin pr
  where
-    newposz = _pjPosZ pr + velz
-    velz = _pjVelZ pr
-    vel  = _pjVel pr
+    newposz = _prPosZ pr + velz
+    velz = _prVelZ pr
+    vel  = _prVel pr
    pos  = _prPos pr
    updateWithVel v = case bouncePoint (const True) 0.5 pos (pos + v) w of
        Nothing -> prPos +~ v
-        Just (p,v') -> (prPos .~ p) . (pjVel .~ v')
+        Just (p,v') -> (prPos .~ p) . (prVel .~ v')

-drawMovingShape :: Prop -> Shape -> SPic
-drawMovingShape pr = noPic
-    . translateSHz (_pjPosZ pr)
-    . uncurryV translateSHf (_prPos pr) 
-    . overPosSH (Q.rotate (_pjQuat pr))
-
-drawMovingShapeCol :: Prop -> Shape -> SPic
-drawMovingShapeCol pr = noPic
-    . translateSHz (_pjPosZ pr)
-    . uncurryV translateSHf (_prPos pr) 
-    . overPosSH (Q.rotate (_pjQuat pr))
-    . colorSH (_pjColor pr)
@@ -0,0 +1,53 @@
+module Dodge.Prop.Update
+    where
+import Dodge.WdP2f
+import Dodge.PrWdLsLs
+import Dodge.WorldBool
+import Dodge.Data
+import Dodge.Prop.Moving
+
+import Data.Foldable
+import Control.Lens
+
+updateProp :: Prop -> World -> World
+updateProp pr = case _prUpdate pr of
+    PropFallSmallBounceDamage -> fallSmallBounceDamage pr
+    PropFallSmallBounce -> fallSmallBounce pr
+    PropUpdateId -> id
+    PropRotate x -> rotateProp x pr
+    PropSetToggleAnd wb pu -> propSetToggleAnd wb pu pr
+    PropUpdates pus -> doPropUpdates pr pus
+    PropUpdateLS lsid x -> \w -> w & lightSources . ix lsid %~ doPrWdLsLs x pr w
+    PropUpdatePosition x -> propUpdatePosition x pr
+    PropUpdateWhen t x -> propUpdateIf t x PropUpdateId pr
+    PropUpdateAnd x y -> doPropUpdates pr [x,y]
+    PropUpdateIf t x y -> propUpdateIf t x y pr
+
+propUpdateIf :: WdBl -> PropUpdate -> PropUpdate -> Prop -> World -> World
+propUpdateIf wb x y pr w
+    | doWdBl wb w   = updateProp (pr & prUpdate .~ x) w
+    | otherwise     = updateProp (pr & prUpdate .~ y) w
+
+
+
+propUpdatePosition :: WdP2f -> Prop -> World -> World
+propUpdatePosition x pr w = w
+    & props . ix (_prID pr) . prPos .~ fst (doWdP2f x w)
+    & props . ix (_prID pr) . prRot .~ snd (doWdP2f x w)
+
+doPropUpdates :: Prop -> [PropUpdate] -> World -> World
+doPropUpdates pr pus w = foldl' f w pus
+  where
+    f w' pu = updateProp (pr & prUpdate .~ pu) w'
+
+propSetToggleAnd :: WdBl -> PropUpdate -> Prop -> World -> World
+propSetToggleAnd wb pu pr = setToggle (doWdBl wb) pr . updateProp (pr & prUpdate .~ pu)
+    -- fugly
+
+setToggle :: (World -> Bool) -> Prop -> World -> World
+setToggle cond pr w = w & props . ix (_prID pr) . prToggle .~ cond w
+
+rotateProp :: Float -> Prop -> World -> World
+rotateProp rotAmount pr w = w
+    & props . ix (_prID pr) . prRot +~ rotAmount
+