Refactor, try to limit dependencies

2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
@@ -1,12 +1,12 @@
-module Dodge.Prop.Draw
-    where
-import Geometry.Polygon
-import Geometry.Data
+module Dodge.Prop.Draw where
+
 import Dodge.Data.Prop
-import ShapePicture
-import Shape
+import Geometry.Data
+import Geometry.Polygon
 import Picture
 import qualified Quaternion as Q
+import Shape
+import ShapePicture

 drawProp' :: Prop -> SPic
 drawProp' pr = drawProp (_prDraw pr) pr
@@ -21,18 +21,20 @@ drawProp pd = case pd of
    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
+    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
+    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
@@ -40,48 +42,53 @@ propDrawToggle pd pr
    | 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)]
-    ]
+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
-        ]
+    ( 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))
+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)
+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)]
-        ]
+    ( 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,119 +1,136 @@
 module Dodge.Prop.Gib where
-import Dodge.Base
-import Dodge.Data
-import Dodge.Damage
-import Geometry
+
 import Color
+import Data.Foldable
+import Data.List (zip4)
+import Dodge.Base
+import Dodge.Damage
+import Dodge.Data.World
+import Geometry
 import LensHelp
+import qualified Quaternion as Q
 import RandomHelp

-import qualified Quaternion as Q
-import Data.List (zip4)
-import Data.Foldable
-
 aGib :: Prop
-aGib = PropZ
-    {_prPos = 0
-    ,_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
-    }
+aGib =
+    PropZ
+        { _prPos = 0
+        , _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
+        }

 addCrGibs :: Creature -> World -> World
 addCrGibs cr w = case damageDirection $ _csDamage $ _crState cr of
-    Nothing -> w
-        & addGibAt 25 (_skinHead skin) cpos
-        & addGibsAt 3 7 (_skinLower skin) cpos
-        & addGibsAt 13 20 (_skinUpper skin) cpos
-    Just d -> w
-        & addGibsAtDir d 3 7 (_skinLower skin) cpos
-        & addGibsAtDir d 13 20 (_skinUpper skin) cpos
-        & addGibAtDir d 25 (_skinHead skin) cpos
+    Nothing ->
+        w
+            & addGibAt 25 (_skinHead skin) cpos
+            & addGibsAt 3 7 (_skinLower skin) cpos
+            & addGibsAt 13 20 (_skinUpper skin) cpos
+    Just d ->
+        w
+            & addGibsAtDir d 3 7 (_skinLower skin) cpos
+            & addGibsAtDir d 13 20 (_skinUpper skin) cpos
+            & addGibAtDir d 25 (_skinHead skin) cpos
  where
    skin = _crType cr -- this should be cleaned up
    cpos = _crPos cr

 addGibsAt :: Float -> Float -> Color -> Point2 -> World -> World
-addGibsAt minh maxh col p w = foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs)
-    & randGen .~ newg
+addGibsAt minh maxh col p w =
+    foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs)
+        & randGen .~ newg
  where
-    (speeds,newg) = replicateM 4 (state (randomR (1,4))) & runState $ _randGen w
-    hs = replicateM 4 (state (randomR (minh,maxh))) & evalState $ _randGen w
+    (speeds, newg) = replicateM 4 (state (randomR (1, 4))) & runState $ _randGen w
+    hs = replicateM 4 (state (randomR (minh, maxh))) & evalState $ _randGen w
    dirs = unitVectorAtAngle <$> (randsOnCirc 4 & evalState $ _randGen w)
    vels = zipWith (*.*) speeds dirs
-    zspeeds = replicateM 4 (state (randomR (-8,8))) & evalState $ _randGen w
+    zspeeds = replicateM 4 (state (randomR (-8, 8))) & evalState $ _randGen w
    quats :: [Q.Quaternion Float]
    quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w

 -- this is ugly because it is mostly copy-paste from addGibsAt
 addGibsAtDir :: Float -> Float -> Float -> Color -> Point2 -> World -> World
-addGibsAtDir dir minh maxh col p w = foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs)
-    & randGen .~ newg
+addGibsAtDir dir minh maxh col p w =
+    foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs)
+        & randGen .~ newg
  where
-    (speeds,newg) = replicateM 4 (state (randomR (1,4))) & runState $ _randGen w
-    hs = replicateM 4 (state (randomR (minh,maxh))) & evalState $ _randGen w
-    dirs = unitVectorAtAngle <$> (randsSpread (dir-pi/4,dir+pi/4) 4 & evalState $ _randGen w)
+    (speeds, newg) = replicateM 4 (state (randomR (1, 4))) & runState $ _randGen w
+    hs = replicateM 4 (state (randomR (minh, maxh))) & evalState $ _randGen w
+    dirs = unitVectorAtAngle <$> (randsSpread (dir - pi / 4, dir + pi / 4) 4 & evalState $ _randGen w)
    vels = zipWith (*.*) speeds dirs
-    zspeeds = replicateM 4 (state (randomR (-8,8))) & evalState $ _randGen w
+    zspeeds = replicateM 4 (state (randomR (-8, 8))) & evalState $ _randGen w
    quats :: [Q.Quaternion Float]
    quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w
-  
-addGib4 :: Point2 -> Color -> (Point2, Float, Q.Quaternion Float, Float)
-    -> World -> World
-addGib4 p col (v,zs,q,h) = plNew (cWorld . 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
-    )
+
+addGib4 ::
+    Point2 ->
+    Color ->
+    (Point2, Float, Q.Quaternion Float, Float) ->
+    World ->
+    World
+addGib4 p col (v, zs, q, h) =
+    plNew
+        (cWorld . 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 (cWorld . props) prID gib
-    & randGen .~ newg
+addGibAt h col p w =
+    w
+        & plNew (cWorld . props) prID gib
+        & randGen .~ newg
  where
-    (gib,newg) = runState f $ _randGen w
+    (gib, newg) = runState f $ _randGen w
    f = do
-        s   <- state $ randomR (1,4)
-        dir <- unitVectorAtAngle <$> state (randomR (0,2*pi))
-        zs  <- state $ randomR (-8,8)
+        s <- state $ randomR (1, 4)
+        dir <- unitVectorAtAngle <$> state (randomR (0, 2 * pi))
+        zs <- state $ randomR (-8, 8)
        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
        let v = s *.* dir
-        return $ aGib
-            & prPos .~ p
-            & prColor .~ col
-            & prVel .~ v
-            & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-            & prQuat .~ q
-            & prVelZ .~ zs
-            & prPosZ .~ h
+        return $
+            aGib
+                & prPos .~ p
+                & 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 (cWorld . props) prID gib
-    & randGen .~ newg
+addGibAtDir dir h col p w =
+    w
+        & plNew (cWorld . props) prID gib
+        & randGen .~ newg
  where
-    (gib,newg) = runState f $ _randGen w
+    (gib, newg) = runState f $ _randGen w
    f = do
-        s   <- state $ randomR (1,4)
-        zs  <- state $ randomR (-8,8)
+        s <- state $ randomR (1, 4)
+        zs <- state $ randomR (-8, 8)
        q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
        let v = s *.* unitVectorAtAngle dir
-        return $ aGib
-            & prPos .~ p
-            & prColor .~ col
-            & prVel .~ v
-            & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
-            & prQuat .~ q
-            & prVelZ .~ zs
-            & prPosZ .~ h
+        return $
+            aGib
+                & prPos .~ p
+                & prColor .~ col
+                & prVel .~ v
+                & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
+                & prQuat .~ q
+                & prVelZ .~ zs
+                & prPosZ .~ h
@@ -1,15 +1,18 @@
-module Dodge.Prop.Moving 
-    ( fallSmallBounceDamage
-    , fallSmallBounce
-    ) where
+module Dodge.Prop.Moving (
+    fallSmallBounceDamage,
+    fallSmallBounce,
+) where
+
 import Dodge.Base
-import Dodge.Data
+import Dodge.Data.World
 import Geometry
 import LensHelp
+
 fallSmallBounceDamage :: Prop -> World -> World
-fallSmallBounceDamage pr w = w 
-    & dodamage
-    & cWorld . props . ix (_prID pr) %~ fallSmallBounce' w
+fallSmallBounceDamage pr w =
+    w
+        & dodamage
+        & cWorld . props . ix (_prID pr) %~ fallSmallBounce' w
  where
    p = _prPos pr
    v = _prVel pr
@@ -17,36 +20,40 @@ fallSmallBounceDamage pr w = w
        | _prPosZ pr < 25 = cWorld . 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 $ _prVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect
+        | dist (_crPos cr) p < _crRad cr + 5 =
+            cr & crState . csDamage
+                .:~ 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 
-    & cWorld . props . ix (_prID pr) %~ fallSmallBounce' w
+fallSmallBounce pr w =
+    w
+        & cWorld . props . ix (_prID pr) %~ fallSmallBounce' w

 fallSmallBounce' :: World -> Prop -> Prop
 fallSmallBounce' w pr
-    | newposz < 0 && velz < (-2) = pr 
-        & prVelZ %~ ((*0.5) . negate)
--        & pjPos +~ (0.5*.* vel)
-        & updateWithVel (0.5 *.* vel)
-        & prVel %~ (0.5 *.*)
--        & pjPos +~ (0.5*.* vel)
-    | newposz < 0 = pr & prUpdate .~ PropUpdateId
-        & prPosZ .~ 0
--        & pjQuat *~ (_pjQuatSpin pr)
-    | otherwise = pr
-        & prVelZ -~ 1
-        & prPosZ +~ velz
-        & updateWithVel vel
-        & prQuat *~ _prQuatSpin pr
+    | newposz < 0 && velz < (-2) =
+        pr
+            & prVelZ %~ ((* 0.5) . negate)
+            --        & pjPos +~ (0.5*.* vel)
+            & updateWithVel (0.5 *.* vel)
+            & prVel %~ (0.5 *.*)
+    --        & pjPos +~ (0.5*.* vel)
+    | newposz < 0 =
+        pr & prUpdate .~ PropUpdateId
+            & prPosZ .~ 0
+    --        & pjQuat *~ (_pjQuatSpin pr)
+    | otherwise =
+        pr
+            & prVelZ -~ 1
+            & prPosZ +~ velz
+            & updateWithVel vel
+            & prQuat *~ _prQuatSpin pr
  where
    newposz = _prPosZ pr + velz
    velz = _prVelZ pr
-    vel  = _prVel pr
-    pos  = _prPos 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) . (prVel .~ v')
-
+        Just (p, v') -> (prPos .~ p) . (prVel .~ v')
@@ -1,13 +1,12 @@
-module Dodge.Prop.Update
-    where
-import Dodge.WdP2f
-import Dodge.PrWdLsLs
-import Dodge.WorldBool
-import Dodge.Data
-import Dodge.Prop.Moving
+module Dodge.Prop.Update where

-import Data.Foldable
 import Control.Lens
+import Data.Foldable
+import Dodge.Data.World
+import Dodge.PrWdLsLs
+import Dodge.Prop.Moving
+import Dodge.WdP2f
+import Dodge.WorldBool

 updateProp :: Prop -> World -> World
 updateProp pr = case _prUpdate pr of
@@ -20,20 +19,19 @@ updateProp pr = case _prUpdate pr of
    PropUpdateLS lsid x -> \w -> w & cWorld . 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]
+    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
-
-
+    | doWdBl wb w = updateProp (pr & prUpdate .~ x) w
+    | otherwise = updateProp (pr & prUpdate .~ y) w

 propUpdatePosition :: WdP2f -> Prop -> World -> World
-propUpdatePosition x pr w = w
-    & cWorld . props . ix (_prID pr) . prPos .~ fst (doWdP2f x w)
-    & cWorld . props . ix (_prID pr) . prRot .~ snd (doWdP2f x w)
+propUpdatePosition x pr w =
+    w
+        & cWorld . props . ix (_prID pr) . prPos .~ fst (doWdP2f x w)
+        & cWorld . props . ix (_prID pr) . prRot .~ snd (doWdP2f x w)

 doPropUpdates :: Prop -> [PropUpdate] -> World -> World
 doPropUpdates pr pus w = foldl' f w pus
@@ -42,12 +40,13 @@ doPropUpdates pr pus w = foldl' f w pus

 propSetToggleAnd :: WdBl -> PropUpdate -> Prop -> World -> World
 propSetToggleAnd wb pu pr = setToggle (doWdBl wb) pr . updateProp (pr & prUpdate .~ pu)
-    -- fugly
+
+-- fugly

 setToggle :: (World -> Bool) -> Prop -> World -> World
 setToggle cond pr w = w & cWorld . props . ix (_prID pr) . prToggle .~ cond w

 rotateProp :: Float -> Prop -> World -> World
-rotateProp rotAmount pr w = w
-    & cWorld . props . ix (_prID pr) . prRot +~ rotAmount
-
+rotateProp rotAmount pr w =
+    w
+        & cWorld . props . ix (_prID pr) . prRot +~ rotAmount