justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor, try to limit dependencies

Browse Source
This commit is contained in:
justin
2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Picture.hs
+121 -99
View File
@@ -1,56 +1,59 @@
--{-# LANGUAGE TupleSections #-}
{- |
Drawing of creatures.
Takes into account damage etc. -}
module Dodge.Creature.Picture
( basicCrPict
, drawCrEquipment
, circLine
, picAtCrPos
, shapeAtCrPos
, picAtCrPosNoRot
-- , basicCrCorpse
, deadScalp
, deadUpperBody
, deadFeet
) where
import Dodge.Data
import Dodge.Creature.HandPos (translateToRightHand,translateToLeftHand)
import Dodge.Creature.Test
import Dodge.Damage
import Dodge.Item.Draw
import Picture
import Geometry
import Shape
import ShapePicture
import qualified Quaternion as Q
Drawing of creatures.
Takes into account damage etc.
-}
module Dodge.Creature.Picture (
basicCrPict,
drawCrEquipment,
circLine,
picAtCrPos,
shapeAtCrPos,
picAtCrPosNoRot,
deadScalp,
deadUpperBody,
deadFeet,
) where
import Control.Lens
import Dodge.Creature.HandPos (translateToLeftHand, translateToRightHand)
import Dodge.Creature.Test
import Dodge.Damage
import Dodge.Data.Creature
import Dodge.Item.Draw
import Geometry
import Picture
import qualified Quaternion as Q
import Shape
import ShapePicture
basicCrPict :: Creature -> SPic
basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr , mempty)
basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr, mempty)
drawCrEquipment :: Creature -> SPic
drawCrEquipment cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
shapeAtCrPos :: Shape -> Creature -> SPic
shapeAtCrPos sh cr =
shapeAtCrPos sh cr =
( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh
, mempty
)
basicCrShape
:: Creature
-> Shape
basicCrShape cr
basicCrShape ::
Creature ->
Shape
basicCrShape cr
| _crCamouflage cr == Invisible = mempty
| otherwise = tr . scaleSH (V3 crsize crsize crsize) $ mconcat
[ --rotdir . _spShape $ drawEquipment cr
rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
, rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
, rotmdir $ colorSH (_skinLower cskin) $ feet cr
]
where
| otherwise =
tr . scaleSH (V3 crsize crsize crsize) $
mconcat
[ --rotdir . _spShape $ drawEquipment cr
rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
, rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
, rotmdir $ colorSH (_skinLower cskin) $ feet cr
]
where
cskin = _crType cr
crsize = 0.1 * _crRad cr
tr = uncurryV translateSHf (_crPos cr)
@@ -79,18 +82,21 @@ basicCrShape cr
feet :: Creature -> Shape
{-# INLINE feet #-}
feet cr = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> mconcat
[ translateSHf ( f sa) off aFoot
, translateSHf (-f sa) (-off) aFoot
]
Just (Walking sa RightForward) -> mconcat
[ translateSHf (-f sa) off aFoot
, translateSHf ( f sa) (-off) aFoot
]
_ -> mconcat
[ translateSHf 0 off aFoot
, translateSHf 0 (-off) aFoot
]
Just (Walking sa LeftForward) ->
mconcat
[ translateSHf (f sa) off aFoot
, translateSHf (- f sa) (- off) aFoot
]
Just (Walking sa RightForward) ->
mconcat
[ translateSHf (- f sa) off aFoot
, translateSHf (f sa) (- off) aFoot
]
_ ->
mconcat
[ translateSHf 0 off aFoot
, translateSHf 0 (- off) aFoot
]
where
aFoot :: Shape
aFoot = upperPrismPoly 10 $ polyCirc 3 4
@@ -101,18 +107,21 @@ feet cr = case cr ^? crStance . carriage of
deadFeet :: Creature -> Shape
{-# INLINE deadFeet #-}
deadFeet cr = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> mconcat
[ translateSHf ( f sa) off aFoot
, translateSHf (-f sa) (-off) aFoot
]
Just (Walking sa RightForward) -> mconcat
[ translateSHf (-f sa) off aFoot
, translateSHf ( f sa) (-off) aFoot
]
_ -> mconcat
[ translateSHf 0 off aFoot
, translateSHf 0 (-off) aFoot
]
Just (Walking sa LeftForward) ->
mconcat
[ translateSHf (f sa) off aFoot
, translateSHf (- f sa) (- off) aFoot
]
Just (Walking sa RightForward) ->
mconcat
[ translateSHf (- f sa) off aFoot
, translateSHf (f sa) (- off) aFoot
]
_ ->
mconcat
[ translateSHf 0 off aFoot
, translateSHf 0 (- off) aFoot
]
where
aFoot :: Shape
aFoot = upperPrismPoly 3 $ polyCirc 3 4
@@ -122,23 +131,27 @@ deadFeet cr = case cr ^? crStance . carriage of
arms :: Creature -> Shape
{-# INLINE arms #-}
arms cr = fst $ translateToRightHand cr aHand
<> translateToLeftHand cr aHand
--arms cr
-- | oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand
-- | twists cr = shoulderSH . translateSHf 0 5 . rotateSH (-1) $ mconcat
-- [ translateSHf 12 4 aHand
-- , translateSHf 4 (-10) aHand
-- ]
-- | twoFlat cr = waistSH $ translateSHf 4 8 aHand
-- <> translateSHf 4 (-8) aHand
-- | otherwise = case cr ^? crStance . carriage of
-- Just (Walking sa LeftForward) -> waistSH $ translateSHf (-f sa) (-off) aHand
-- Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off aHand
-- _ -> emptySH
arms cr =
fst $
translateToRightHand cr aHand
<> translateToLeftHand cr aHand
where
--arms cr
-- | oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand
-- | twists cr = shoulderSH . translateSHf 0 5 . rotateSH (-1) $ mconcat
-- [ translateSHf 12 4 aHand
-- , translateSHf 4 (-10) aHand
-- ]
-- | twoFlat cr = waistSH $ translateSHf 4 8 aHand
-- <> translateSHf 4 (-8) aHand
-- | otherwise = case cr ^? crStance . carriage of
-- Just (Walking sa LeftForward) -> waistSH $ translateSHf (-f sa) (-off) aHand
-- Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off aHand
-- _ -> emptySH
aHand :: SPic
aHand = noPic $ translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
-- off = 8
-- sLen = _strideLength $ _crStance cr
-- f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
@@ -149,14 +162,17 @@ deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr
deadRot :: Creature -> Shape -> Shape
deadRot cr = overPosSH (Q.rotateToZ d)
where
d = maybe (V3 1 0 0) (addZ 0 . unitVectorAtAngle . subtract (_crDir cr+pi))
(damageDirection . _csDamage $ _crState cr)
d =
maybe
(V3 1 0 0)
(addZ 0 . unitVectorAtAngle . subtract (_crDir cr + pi))
(damageDirection . _csDamage $ _crState cr)
scalp :: Creature -> Shape
{-# INLINE scalp #-}
scalp cr
| twists cr = translateSHf 0 5 . rotateSH (-1) $ translateSHf (negate 2.5) 0.25 fhead
| oneH cr = rotateSH 0.5 $ translateSHf 2.5 0 fhead
| oneH cr = rotateSH 0.5 $ translateSHf 2.5 0 fhead
| otherwise = translateSHf 2.5 0 fhead
where
fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 4 5
@@ -168,19 +184,24 @@ scalp cr
torso :: Creature -> Shape
{-# INLINE torso #-}
torso cr
| oneH cr = rotateSH 0.5 $ mconcat
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
| twists cr = translateSHf 0 5 . rotateSH (-1) $ mconcat
[ rotateSH (negate 0.2) . translateSHf 2 3 . rotateSH (negate 0.4) $ aShoulder
, rotateSH (negate 0.2) . translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
| otherwise = mconcat
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
torso cr
| oneH cr =
rotateSH 0.5 $
mconcat
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
| twists cr =
translateSHf 0 5 . rotateSH (-1) $
mconcat
[ rotateSH (negate 0.2) . translateSHf 2 3 . rotateSH (negate 0.4) $ aShoulder
, rotateSH (negate 0.2) . translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
| otherwise =
mconcat
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
where
--aShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 crad
aShoulder = scaleSH (V3 10 10 1) baseShoulder
@@ -195,17 +216,18 @@ baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalf 10
upperBody :: Creature -> Shape
{-# INLINE upperBody #-}
--upperBody col cr = colorSH (light4 col) $ mconcat
upperBody cr = mconcat
[ arms cr
, shoulderSH $ torso cr
]
upperBody cr =
mconcat
[ arms cr
, shoulderSH $ torso cr
]
shoulderSH :: Shape -> Shape
shoulderSH = translateSHz 20
--waistSH :: Shape -> Shape
--waistSH = translateSHz 10
--drawAwakeLevel
-- :: Creature
-- -> Picture
@@ -218,12 +240,13 @@ shoulderSH = translateSHz 20
drawEquipment :: Creature -> SPic
{-# INLINE drawEquipment #-}
drawEquipment cr = foldMap (itemEquipPict cr) (_crInv cr)
--drawEquipment cr = foldMap f (_crInv cr)
-- where
-- where
-- f itm = _itEquipPict itm cr itm
circLine :: Float -> Picture
circLine x = line [V2 0 0,V2 x 0]
circLine x = line [V2 0 0, V2 x 0]
picAtCrPos :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
@@ -232,4 +255,3 @@ picAtCrPos thePic cr = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
picAtCrPosNoRot :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
picAtCrPosNoRot thePic cr = (,) emptySH $ uncurryV translate (_crPos cr) thePic