Files
loop/src/Dodge/Item/Draw/SPic.hs
T

482 lines
16 KiB
Haskell

{-# LANGUAGE LambdaCase #-}
module Dodge.Item.Draw.SPic (
itemSPic,
itemTreeSPic,
) where
import Color
import Data.Maybe
import Data.Strict.Tuple
import Dodge.Data.ComposedItem
import Dodge.Data.DoubleTree
import Dodge.Data.Item
import Dodge.Item.MaxAmmo
import Dodge.Item.Orientation
import Geometry
import LensHelp
import qualified Linear.Quaternion as Q
--import qualified Linear.Quaternion as Q
import Picture
import Shape
import ShapePicture
itemTreeSPic :: DTree CItem -> SPic
itemTreeSPic (DT (itm, _) l r) = itemSPic itm <> foldMap (itemRotTreeSPic itm) (l <> r)
itemRotTreeSPic :: Item -> DTree CItem -> SPic
itemRotTreeSPic par t = translateSP p . overPosSP (Q.rotate q) $ itemTreeSPic t
where
(p, q) = orientAttachment par itm
itm = t ^. dtValue
itemSPic :: Item -> SPic
itemSPic it = case it ^. itType of
CRAFT ct -> noPic $ craftItemSPic ct
HELD ht -> heldItemSPic ht it
EQUIP et -> equipItemSPic et it
ATTACH{} -> defSPic
AMMOMAG amt -> ammoMagSPic it amt
TARGETING{} -> defSPic
BULLETMOD{} -> defSPic
STICKYMOD -> defSPic
ITEMSCAN -> defSPic
MAPPER -> defSPic
ARHUD -> defSPic
INTROSCAN{} -> defSPic
DETECTOR dt -> noPic (colorSH (detectorColor dt) $ upperPrismPolySU 3 $ rectWH 2 2)
DROPPER{} -> defSPic
CLICKER{} -> defSPic
COPIER{} -> defSPic
BINGATE -> defSPic
UNIGATE -> defSPic
NULGATE -> defSPic
craftItemSPic :: CraftType -> Shape
craftItemSPic = \case
PIPE -> colorSH green $ xCylinderST 3 10
TUBE -> colorSH cyan $ xCylinderST 5 20
HARDWARE -> colorSH orange $ upperPrismPolyST 3 $ square 4
SPRING -> colorSH green $ xCylinderST 1 5
HOSE -> colorSH green $ xCylinderST 1 10
TAPE ->
colorSH (greyN 0.5)
. translateSH (V3 4 0 0)
. upperCylinder Small Typical 1
$ polyCirc 3 5
CAN ->
colorSH green
. translateSH (V3 4 0 0)
. upperCylinder Small Typical 1
$ polyCirc 3 4
TIN -> colorSH green . upperPrismPolyST 3 $ rectXH 2 2
STEELDRUM ->
colorSH green
. translateSH (V3 4 0 0)
. upperCylinder Small Typical 1
$ polyCirc 4 8
PLANK -> colorSH orange $ upperPrismPolyST 3 $ rectXH 8 2
GLASSSHARD -> colorSH azure $ upperPrismPolyST 1 [V2 0 (-1), V2 4 (-0.5), V2 0 1]
SCRAPMETAL -> colorSH (greyN 0.3) $ upperPrismPolyST 3 $ square 4
PUMP ->
colorSH yellow . translateSH (V3 4 0 0) $
upperCylinder Small Typical 1 (polyCirc 4 4)
<> upperPrismPolyST 1 (rectNSWE (-2) (-4) 4 0)
<> upperPrismPolyST 1 (rectNSWE 4 2 0 (-4))
MOTOR -> colorSH orange $ xCylinderST 5 3 <> xCylinderST 3 5
TRANSFORMER -> colorSH blue $ upperPrismPolyST 3 $ square 4
PRISM -> colorSH azure $ upperPrismPolyST 1 [V2 0 (-3), V2 4 0, V2 0 3]
LIGHTER -> colorSH yellow . upperPrismPolyST 3 $ rectXH 2 2
MAGNET ->
colorSH red (upperPrismPolyST 1 (rectNSWE 2 (-2) 2 0))
<> colorSH (greyN 0.5) (upperPrismPolyST 1 (rectNSWE 2 (-2) 4 2))
<> colorSH blue (upperPrismPolyST 1 (rectNSWE 2 (-2) 6 4))
ANTIMATTER -> colorSH violet $ upperPrismPolyST 3 $ square 4
PLATE -> colorSH green $ upperPrismPolyST 8 $ rectXH 2 5
TRANSMITTER ->
colorSH green $
xCylinderST 1 5 <> translateSH (V3 5 0 0) (upperPrismPolyHalfST 3 $ polyCirc 4 3)
MICROCHIP -> colorSH yellow $ upperPrismPolyST 1 $ square 4
HARDDRIVE -> colorSH green $ upperPrismPolyST 1 $ square 4
RAM -> colorSH orange $ upperPrismPolyST 1 $ square 4
AIUNIT -> colorSH blue $ upperPrismPolyST 1 $ square 4
CAMERA -> colorSH yellow $ xCylinderST 5 3 <> xCylinderST 3 5
MINIDISPLAY ->
colorSH green $
upperPrismPolyST 1 (square 4)
<> upperPrismPolyST 2 (rectNSWE 4 (-4) 3 4)
LED -> colorSH yellow $ upperPrismPolyST 1 (square 2)
NAILBOX -> colorSH green $ upperPrismPolyST 3 (rectXH 4 3)
IRONBAR -> colorSH (greyN 0.5) $ upperPrismPolyST 3 $ rectXH 8 2
LIGHTSENSOR ->
colorSH green (upperPrismPolyST 1 $ square 3)
<> colorSH yellow (upperPrismPolyHalfST 3 $ polyCirc 4 3)
SOUNDSENSOR ->
colorSH yellow (upperPrismPolyST 1 $ rectXH 4 1)
<> translateSH (V3 4 1 0) (colorSH yellow (upperPrismPolyHalfST 2 $ polyCirc 4 2))
<> translateSH (V3 4 (-1) 0) (colorSH yellow (upperPrismPolyHalfST 2 $ polyCirc 4 2))
MICROPHONE ->
colorSH yellow (upperPrismPolyST 1 $ rectXH 3 1)
<> translateSH (V3 3 0 0) (colorSH yellow (upperPrismPolyHalfST 2 $ polyCirc 4 2))
HEATSENSOR ->
colorSH red (upperPrismPolyST 1 $ rectXH 4 1)
<> translateSH (V3 4 1 0) (colorSH yellow (upperPrismPolyHalfST 2 $ polyCirc 4 2))
<> translateSH (V3 4 (-1) 0) (colorSH yellow (upperPrismPolyHalfST 2 $ polyCirc 4 2))
THERMOMETER ->
colorSH green (upperPrismPolyST 1 $ rectXH 3 1)
<> translateSH (V3 3 0 0) (colorSH yellow (upperPrismPolyHalfST 2 $ polyCirc 4 2))
CREATURESENSOR ->
colorSH azure (upperPrismPolyST 1 $ rectXH 4 1)
<> translateSH (V3 4 1 0) (colorSH yellow (upperPrismPolyHalfST 2 $ polyCirc 4 2))
<> translateSH (V3 4 (-1) 0) (colorSH yellow (upperPrismPolyHalfST 2 $ polyCirc 4 2))
WIRE -> colorSH blue $ xCylinderST 1 5
FUELCELL ->
colorSH blue
. translateSH (V3 4 0 0)
. upperCylinder Small Typical 1
$ polyCirc 3 4
PORTABLEFUSION ->
colorSH azure
. translateSH (V3 4 0 0)
. upperCylinder Small Typical 1
$ polyCirc 3 4
ammoMagSPic :: Item -> AmmoMagType -> SPic
ammoMagSPic it = \case
TINMAG -> noPic $ upperPrismPolyTS 1 (rectNSWE 0 (- (am * 5)) (-1) 1)
DRUMMAG -> noPic $ upperPrismPolyTS 1 (rectNSWE 0 (- (am * 15)) (-1) 1)
CHEMFUELPOUCH -> noPic $ colorSH yellow (upperPrismPolyST 3 $ polyCirc 3 5)
BATTERY ->
colorSH blue (upperBox Tiny Superfluous 1 (rectNSWE 0 (-2) (-2) 2))
:!: setLayer BloomNoZWrite (setDepth 2 . color (mixColorsFrac green red am) $ circleSolid 2)
_ -> noPic $ upperPrismPolyTS 1 (rectNSWE 0 (- y) (-1) 1)
where
y = fromIntegral y' * 0.3
y' = fromMaybe 0 $ it ^. itConsumables
am = fractionLoadedAmmo it -- (it ^?! itConsumables . magLoadStatus)
fractionLoadedAmmo :: Item -> Float
fractionLoadedAmmo itm = fromMaybe 0 $ do
m <- maxAmmo itm
return $
fromIntegral (itm ^?! itConsumables . _Just)
/ fromIntegral m
--
--fractionLoadedAmmo2 :: ReloadStatus -> Float
--fractionLoadedAmmo2 rs =
-- 1 - (1 - fromIntegral (_iaLoaded rs) / fromIntegral (_iaMax rs)) ** 2
equipItemSPic :: EquipItemType -> Item -> SPic
equipItemSPic et _ = case et of
WRIST_ECG -> defSPic
MAGSHIELD _ -> defSPic
FLAMESHIELD -> defSPic
FRONTARMOUR -> defSPic
-- ( mempty
-- , setDepth 20 $
-- fold
-- [ color yellow $ thickArc 0 (pi / 2) 10 5
-- , color yellow $ thickArc (3 * pi / 2) (2 * pi) 10 5
-- ]
-- )
WRISTARMOUR -> defSPic
INVISIBILITYEQUIPMENT _ -> noPic (colorSH chartreuse $ upperPrismPolySI 3 $ rectWH 2 2)
BRAINHAT -> noPic (colorSH yellow $ upperPrismPolySU 3 $ rectWH 4 4)
HAT -> noPic (colorSH yellow $ upperPrismPolySU 3 $ rectWH 4 4)
HEADLAMP -> noPic headLampShape
POWERLEGS -> legsSPic yellow
SPEEDLEGS -> legsSPic green
JUMPLEGS -> legsSPic red
BATTERYPACK -> noPic $ colorSH blue backpackShape
FUELPACK ->
noPic $ colorSH yellow $ upperPrismPolyMT 10 $ polyCirc 3 5
BULLETBELTPACK ->
noPic $ colorSH green backpackShape
BULLETBELTBRACER ->
noPic (colorSH green $ upperPrismPolySU 3 $ rectWH 2 2)
backpackShape :: Shape
backpackShape = upperPrismPolyMT 10 $ rectNSWE 5 (-5) (-4) 4
--ammoPosition :: Item -> HeldItemType -> AmmoPosition
--ammoPosition itm hit = case hit of
-- BANGSTICK i -> bangStickAmmoPos i itm
-- PISTOL -> Magazine (V3 5 2 0) lhs
-- MACHINEPISTOL -> Magazine (V3 5 2 0) lhs
-- AUTOPISTOL -> Magazine (V3 5 2 0) lhs
-- SMG -> Magazine (V3 7 (-2) 0) rhs
-- VOLLEYGUN i -> volleygunAmmoPos i
-- MULTIGUN i -> multigunAmmoPos i
-- RIFLE -> Bullets [(V3 5 0 3, Q.axisAngle (V3 1 0 0) 0)]
-- REPEATER -> Magazine (V3 10 (-2) 0) rhs
-- AUTORIFLE -> Magazine (V3 10 (-2) 0) rhs
-- BURSTRIFLE -> Magazine (V3 10 (-2) 0) rhs
-- BANGROD -> Bullets [(V3 5 0 3, Q.axisAngle (V3 1 0 0) 0)]
-- ELEPHANTGUN -> Bullets [(V3 5 0 3, Q.axisAngle (V3 1 0 0) 0)]
-- AMR -> Magazine (V3 10 (-2) 0) rhs
-- AUTOAMR -> Magazine (V3 10 (-2) 0) rhs
-- SNIPERRIFLE -> Bullets [(V3 5 0 3, Q.axisAngle (V3 1 0 0) 0)]
-- MACHINEGUN -> Magazine (V3 10 (-2) 0) rhs
-- --SONICGUN -> noPic baseSonicShape
-- where
-- lhs = Q.axisAngle (V3 1 0 0) pi
-- rhs = Q.axisAngle (V3 1 0 0) 0
--bangStickAmmoPos :: Int -> Item -> AmmoPosition
--bangStickAmmoPos _ itm =
-- Bullets
-- [(rotate3z a (V3 5 0 3), Q.axisAngle (V3 0 0 1) a)
-- | a <- map _mzRot (itm ^?! itUse . heldAim . aimMuzzles)]
--volleygunAmmoPos :: Int -> AmmoPosition
--volleygunAmmoPos i =
-- Bullets
-- [(V3 5 (f n) 3, Q.axisAngle (V3 1 0 0) 0) | n <- [0 .. i -1]]
-- where
-- f n = fromIntegral n * 5 - ((fromIntegral i - 1) * 2.5)
--
--multigunAmmoPos :: Int -> AmmoPosition
--multigunAmmoPos i =
-- Bullets
-- [(V3 5 (f n) 3, Q.axisAngle (V3 1 0 0) 0) | n <- [0 .. i -1]]
-- where
-- f n = fromIntegral n * 5 - ((fromIntegral i - 1) * 2.5)
heldItemSPic :: HeldItemType -> Item -> SPic
heldItemSPic ht it = case ht of
FLATSHIELD -> flatShieldEquipSPic
TORCH -> noPic torchShape
BANGSTICK i -> noPic $ baseStickShapeX it i -- <> addBullets it
PISTOL -> noPic baseStickShape
MACHINEPISTOL -> noPic baseStickShape
AUTOPISTOL -> noPic baseStickShape
SMG -> noPic baseSMGShape
BANGCONE -> noPic $ bangConeShape 5
BLUNDERBUSS -> noPic $ bangConeShape 20
GRAPECANNON _ -> noPic $ bangConeShape 20
MINIGUNX i -> miniGunXPictItem i it
VOLLEYGUN i -> noPic $ volleyGunShape i -- <> addBullets it
RIFLE -> noPic baseRifleShape -- <> addBullets it
ALTERIFLE -> noPic baseRifleShape -- <> addBullets it
AUTORIFLE -> noPic baseRifleShape
BURSTRIFLE -> noPic baseRifleShape
BANGROD -> noPic baseRodShape -- <> addBullets it
ELEPHANTGUN -> noPic baseAMRShape -- <> addBullets it
AMR -> noPic baseAMRShape
AUTOAMR -> noPic baseAMRShape
SNIPERRIFLE -> noPic baseAMRShape -- <> addBullets it
FLAMESPITTER -> flamerPic it
FLAMETHROWER -> flamerPic it
FLAMETORRENT -> flamerPic it
FLAMEWALL -> flamerPic it
BLOWTORCH -> flamerPic it
SPARKGUN -> teslaGunPic
TESLAGUN -> teslaGunPic
LASER -> lasGunPic it
TRACTORGUN -> tractorGunPic it
RLAUNCHER -> rlauncherPic it
RLAUNCHERX _ -> rlauncherPic it
GLAUNCHER -> glauncherPic it
POISONSPRAYER -> flamerPic it
BLINKER -> defSPic
BLINKERUNSAFE -> defSPic
REWINDER -> defSPic
TIMESTOPPER -> defSPic
TIMESCROLLER -> defSPic
SHATTERGUN -> shatterGunSPic
KEYCARD _ -> noShape (setDepth 0 $ translate (-5) (-5) $ rotate (pi / 2.5) keyPic)
torchShape :: Shape
torchShape =
colorSH blue $
translateSHxy 0 1.5 side
<> translateSHxy 0 (-1.5) side
<> translateSHz 2.5 top
<> translateSHz (-0.5) bot
<> back
where
side = upperPrismPolySE 3 $ rectXH 10 0.5
top = upperPrismPolySE 0.5 $ rectXH 10 2
bot = upperPrismPolySE 0.5 $ rectXH 9 2
back = upperPrismPolySE 3 $ rectXH 1 2
baseStickShapeX :: Item -> Int -> Shape
baseStickShapeX _ _ = mempty
--baseStickShapeX it _ = mempty
-- foldMap f (it ^?! itUse . heldMuzzles)
-- where
-- f brl = rotateSH (_mzRot brl) baseStickShape
baseStickShape :: Shape
baseStickShape = colorSH green $ xCylinderST 3 10
bangConeShape :: Float -> Shape
bangConeShape x =
colorSH cyan $
xCylinderST 3 x
<> upperPrismPolyST 6 (rectNSWE 4 (-4) x (10 + x))
defSPic :: SPic
defSPic = noPic $ colorSH green $ upperPrismPolyST 3 $ square 4
shatterGunSPic :: SPic
shatterGunSPic =
-- TODO cylinderize
noPic $
colorSH blue $
upperPrismPolyST 5 (rectNSWE xb xa 0 8)
<> upperPrismPolyST 5 (rectNSWE (- xa) (- xb) 0 8)
where
xa = 1
xb = 9
baseCaneShape :: Shape
baseCaneShape = colorSH red $ xCylinderST 3 15
baseRifleShape :: Shape
baseRifleShape = colorSH red $ xCylinderST 3 25
--bulletEffectColor :: BulletEffect -> Color
--bulletEffectColor x = case x of
-- DestroyBullet -> black
-- BounceBullet -> mixColors 0.5 0.5 black yellow
-- PenetrateBullet -> mixColors 0.5 0.5 black blue
--bulletTrajColor :: BulletTrajectory -> Color
--bulletTrajColor x = case x of
-- BasicBulletTrajectory -> black
-- BezierTrajectory{} -> chartreuse
-- FlechetteTrajectory{} -> white
-- MagnetTrajectory{} -> yellow
--bulletPayloadColor :: BulletSpawn -> Color
--bulletPayloadColor x = case x of
-- BulBall y -> energyBallColor y
-- BulSpark -> black
-- BulFlak -> chartreuse
-- BulFrag -> magenta
-- BulGas -> green
--energyBallColor :: EnergyBallType -> Color
--energyBallColor ebt = case ebt of
-- IncBall -> orange
-- TeslaBall -> cyan
-- ConcBall -> white
-- FlashBall -> yellow
volleyGunShape :: Int -> Shape
volleyGunShape i =
colorSH
red
( foldMap
( (\y -> translateSHxy 0 y $ xCylinderST 3 15)
. (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5))
)
[0 .. i -1]
)
-- to get this rotating should probably add extra state to the minigun
miniGunXPictItem :: Int -> Item -> SPic
miniGunXPictItem i it = miniGunXPict i (_wTime (_itParams it) - 10)
miniGunXPict :: Int -> Int -> SPic
miniGunXPict i spin =
noPic
( colorSH red (rotateSHx a barrels)
<> baseRifleShape
)
where
aBarrel = translateSH (V3 15 2 2) baseCaneShape
barrels = foldMap (\an -> aBarrel & rotateSHx (2 * pi * fromIntegral an / fromIntegral i)) [1 .. i]
a = fromIntegral spin / 100
--x = fromIntegral am / 10
-- clip y z = translateSH (V3 0 (-1) z) (rotateSHx (negate $ pi/4)
-- . upperPrismPoly 2
-- $ rectNESW (negate $ 3 + 0.25 * x) y 3 (y-5))
--baseSonicShape :: Shape
--baseSonicShape = colorSH rose $ upperPrismPoly 3 $ rectXH 25 2
baseSMGShape :: Shape
baseSMGShape = colorSH green $ xCylinderST 3 20
flamerPic :: Item -> SPic
flamerPic _ = noPic . colorSH yellow $ xCylinderST 5 18
rlauncherPic :: Item -> SPic
rlauncherPic _ = noPic . colorSH cyan $ xCylinderST 5 20
glauncherPic :: Item -> SPic
glauncherPic _ = noPic . colorSH green $ xCylinderST 5 20
baseRodShape :: Shape
baseRodShape = colorSH orange $ xCylinderST 3 20
baseAMRShape :: Shape
baseAMRShape = colorSH orange $ xCylinderST 3 30
teslaGunPic :: SPic
teslaGunPic = shatterGunSPic
lasGunPic :: Item -> SPic
lasGunPic _ = noPic $ colorSH blue $ upperPrismPolyST 3 $ square 4
-- colorSH
-- blue
-- ( upperBoxST 4 (rectNSWE 3 1 0 30)
-- <> upperBoxSU 4 (rectNSWE (-1) (-3) 0 30)
-- <> upperBoxSU 1 (rectNSWE 3 (-3) 0 30)
-- )
-- :!: mempty
--dualBeamPic :: Item -> SPic
--dualBeamPic it =
-- ( colorSH blue $
-- upperBoxST 4 (rectNESW gap 3 (- gap) 1)
-- <> upperBoxSU 4 (rectNESW gap (-1) (- gap) (-3))
-- <> upperBoxSU 1 (rectNESW gap 3 (- gap) (-3))
-- , setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW gap 1 (- gap) (-1)
-- )
-- where
-- --amFrac = fractionLoadedAmmo it
-- amFrac = 0.5
-- col = brightX 2 1.5 $ mixColors amFrac (1 - amFrac) green red
-- gap = _dbGap (_itParams it) - 3
tractorGunPic :: Item -> SPic
tractorGunPic = lasGunPic
flatShieldEquipSPic :: SPic
flatShieldEquipSPic = noPic . colorSH yellow $ upperBoxMT 10 (rectWH 2 10)
headLampShape :: Shape
headLampShape =
colorSH yellow $
oneside 5 2 4
<> oneside 5 2 0
<> oneside 5 (-2) 4
<> oneside 5 (-2) 0
where
oneside x y z = translateSH (V3 x y z) (upperPrismPolySE 4 $ rectWH 4 1)
detectorColor :: Detector -> Color
detectorColor dt = case dt of
ITEMDETECTOR -> blue
CREATUREDETECTOR -> green
WALLDETECTOR -> red
keyPic :: Picture
keyPic =
color green $
fold
[ translate (-4) 0 $ thickCircle 4 2
, thickLine 2 $ map toV2 [(0, 0), (8, 0), (8, -4)]
, thickLine 2 $ map toV2 [(4, 0), (4, -4)]
]
legsSPic :: Color -> SPic
legsSPic col = noPic $ translateSH (V3 0 4 0) $ colorSH col $ upperPrismPolyST 3 $ rectWH 2 2