From d989acd6f2ab670746b3e6321b7399660c7b3fea Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 25 Mar 2023 17:22:58 +0000 Subject: [PATCH] Allow shadow fidelity option, fix bug in rendering box shadows --- src/Dodge/Block/Debris.hs | 4 +- src/Dodge/Block/Draw.hs | 2 +- src/Dodge/Button/Draw.hs | 9 +- src/Dodge/Creature/Impulse/UseItem.hs | 59 +++--- src/Dodge/Creature/Picture.hs | 53 ++--- src/Dodge/Creature/YourControl.hs | 2 +- src/Dodge/Data/Config.hs | 7 +- src/Dodge/Data/Item/Use.hs | 11 ++ src/Dodge/Default/Item/Use.hs | 1 + src/Dodge/Item/Draw/SPic.hs | 109 +++++------ src/Dodge/Item/Weapon/Drone.hs | 2 +- src/Dodge/Item/Weapon/Grenade.hs | 2 +- src/Dodge/LevelGen/Switch.hs | 6 +- src/Dodge/Machine/Draw.hs | 6 +- src/Dodge/Menu.hs | 3 +- src/Dodge/Placement/Instance/Pipe.hs | 2 +- src/Dodge/Placement/TopDecoration.hs | 4 +- src/Dodge/Projectile/Draw.hs | 2 +- src/Dodge/Prop/Draw.hs | 31 +-- src/Dodge/Render.hs | 5 +- src/Dodge/Render/ShapePicture.hs | 2 +- src/Dodge/Room/Foreground.hs | 5 +- src/Render.hs | 5 +- src/Shader/Poke.hs | 48 ++--- src/Shape.hs | 270 ++++++++++++++++++-------- src/Shape/Data.hs | 18 +- 26 files changed, 410 insertions(+), 258 deletions(-) diff --git a/src/Dodge/Block/Debris.hs b/src/Dodge/Block/Debris.hs index 3e2b55d4e..9ef4eb40a 100644 --- a/src/Dodge/Block/Debris.hs +++ b/src/Dodge/Block/Debris.hs @@ -181,7 +181,7 @@ crystalDebris = shardShape :: Float -> Shape shardShape size = translateSHz (- size) $ - upperPrismPoly + upperPrismPolySU size [ V2 size 0 , V2 (- size) 1 @@ -194,4 +194,4 @@ jaggedShape = do return $ shardShape s cubeShape :: Float -> Shape -cubeShape size = translateSHz (- size) $ upperPrismPoly (2 * size) $ square size +cubeShape size = translateSHz (- size) $ upperPrismPolySU (2 * size) $ square size diff --git a/src/Dodge/Block/Draw.hs b/src/Dodge/Block/Draw.hs index c506d8f08..d04f4f91f 100644 --- a/src/Dodge/Block/Draw.hs +++ b/src/Dodge/Block/Draw.hs @@ -8,7 +8,7 @@ drawBlock :: BlockDraw -> Block -> SPic drawBlock bd = case bd of BlockDrawMempty -> const mempty BlockDraws bds -> \bl -> foldMap (`drawBlock` bl) bds - BlockDrawColHeightPoss col h ps -> const $ noPic $ colorSH col (upperPrismPoly h ps) + BlockDrawColHeightPoss col h ps -> const $ noPic $ colorSH col (upperBox Medium Typical h ps) BlockDrawBlSh x -> noPic . doBlSh x doBlSh :: BlSh -> Block -> Shape diff --git a/src/Dodge/Button/Draw.hs b/src/Dodge/Button/Draw.hs index ad5e5308b..0f81963cb 100644 --- a/src/Dodge/Button/Draw.hs +++ b/src/Dodge/Button/Draw.hs @@ -14,14 +14,13 @@ drawButton bd = case bd of drawSwitch :: Color -> Color -> Button -> SPic drawSwitch col1 col2 bt - | _btState bt == BtOff = - flick $ pi / 4 + | _btState bt == BtOff = flick $ pi / 4 | otherwise = flick (negate (pi / 4)) where flick a = ( mconcat - [ colorSH col1 . upperPrismPoly 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10 - , colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperPrismPoly 2 $ + [ colorSH col1 . upperBox Small Typical 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10 + , colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperBox Small Typical 2 $ reverse $ rectNSWE 10 0 (-2) 2 ] @@ -30,7 +29,7 @@ drawSwitch col1 col2 bt defaultDrawButton :: Color -> Button -> SPic defaultDrawButton col bt = - ( translateSHz 15 . colorSH col $ upperPrismPoly 5 buttonGeometry + ( translateSHz 15 . colorSH col $ upperBox Small Typical 5 buttonGeometry , mempty ) where diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs index 90e6d04e8..a87d0e92f 100644 --- a/src/Dodge/Creature/Impulse/UseItem.hs +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -1,6 +1,6 @@ module Dodge.Creature.Impulse.UseItem ( useItem, - useLeftItem, + doTopInvLeftClick, itemEffect, ) where @@ -106,7 +106,7 @@ toggleEquipmentAt rbops invid cr w = case rbops ^? opAllocateEquipment of & crpoint . crEquipment . at oldp .~ Nothing & crpoint . crInvEquipped . at invid .~ Nothing & onremove itm cr - Nothing -> error "tried to toggle equipment whilst not prepared" + Nothing -> error "tried to toggle equipment when not prepared" where crpoint = cWorld . lWorld . creatures . ix (_crID cr) itmat i = _crInv cr IM.! i @@ -115,27 +115,40 @@ toggleEquipmentAt rbops invid cr w = case rbops ^? opAllocateEquipment of onequip itm' = useE ((_eeOnEquip . _equipEffect . _itUse) itm') itm' onremove itm' = useE ((_eeOnRemove . _equipEffect . _itUse) itm') itm' -useLeftItem :: Int -> World -> World -useLeftItem cid w = fromMaybe w $ do - cr <- w ^? cWorld . lWorld . creatures . ix cid +doTopInvLeftClick :: Creature -> World -> World +doTopInvLeftClick cr w = fromMaybe w $ do guard . not $ _crInvLock cr - let mitRef = cr ^? crManipulation . manObject . inInventory . ispItem - itmIsConsumable = isJust $ do - itRef <- mitRef - cr ^? crInv . ix itRef . itUse . cUse - itmIsEquipable = isJust $ do - itRef <- mitRef - guard $ cr ^. crLeftInvSel . lisMPos == Just itRef - cr ^? crInv . ix itRef . itUse . equipEffect . eeUse - if itmIsConsumable || itmIsEquipable - then return $ useItem cr w -- I believe this ONLY sets equipment options - else do - invid <- cr ^. crLeftInvSel . lisMPos - itm <- cr ^? crInv . ix invid - f <- cr ^? crInv . ix invid . itUse . leftUse - return - . (runIdentity . pointerToItemLocation (_itLocation itm) (return . (itUse . leftHammer .~ HammerDown))) - . useL f itm cr - $ w + return $ doTopInvLeftClick' cr w + +doTopInvLeftClick' :: Creature -> World -> World +doTopInvLeftClick' cr w = fromMaybe (doTopInvLeftClickSearch cr w) $ do + invid <- cr ^? crManipulation . manObject . inInventory . ispItem + ituse <- cr ^? crInv . ix invid . itUse + case ituse of + ConsumeUse{} -> return $ useItem cr w + EquipUse{} -> return $ useItem cr w + LeftUse{} -> return $ equipAndUse (_leftUseOnEquip ituse) invid cr w + _ -> Nothing + +equipAndUse :: Bool -> Int -> Creature -> World -> World +equipAndUse useonequip invid cr w = case cr ^? crInvEquipped . ix invid of + Nothing | useonequip -> tryUseL (_crID cr) invid $ useItem cr w + | otherwise -> useItem cr w + _ -> tryUseL (_crID cr) invid w + +doTopInvLeftClickSearch :: Creature -> World -> World +doTopInvLeftClickSearch cr w = fromMaybe w $ do + invid <- cr ^. crLeftInvSel . lisMPos + return $ tryUseL (_crID cr) invid w + +tryUseL :: Int -> Int -> World -> World +tryUseL crid invid w = fromMaybe w $ do + cr <- w ^? cWorld . lWorld . creatures . ix crid + itm <- cr ^? crInv . ix invid + luse <- itm ^? itUse . leftUse + return $ + w + & cWorld . lWorld . creatures . ix crid . crInv . ix invid . itUse . leftHammer .~ HammerDown + & useL luse itm cr -- TODO determine itmShouldBeUsed with reference to config options diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index 2b34fe00a..3815c420b 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -68,35 +68,36 @@ feet cr = case cr ^? crStance . carriage of ] where aFoot :: Shape - aFoot = upperPrismPoly 10 $ polyCirc 3 4 + aFoot = upperPrismPolyST 10 $ polyCirc 3 4 off = 5 sLen = _strideLength $ _crStance cr f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen deadFeet :: Creature -> Shape {-# INLINE deadFeet #-} -deadFeet cr = case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> - mconcat - [ translateSHxy (f sa) off aFoot - , translateSHxy (- f sa) (- off) aFoot - ] - Just (Walking sa RightForward) -> - mconcat - [ translateSHxy (- f sa) off aFoot - , translateSHxy (f sa) (- off) aFoot - ] - _ -> - mconcat - [ translateSHxy 0 off aFoot - , translateSHxy 0 (- off) aFoot - ] - where - aFoot :: Shape - aFoot = upperPrismPoly 3 $ polyCirc 3 4 - off = 5 - sLen = _strideLength $ _crStance cr - f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen +deadFeet = feet +--cr = case cr ^? crStance . carriage of +-- Just (Walking sa LeftForward) -> +-- mconcat +-- [ translateSHxy (f sa) off aFoot +-- , translateSHxy (- f sa) (- off) aFoot +-- ] +-- Just (Walking sa RightForward) -> +-- mconcat +-- [ translateSHxy (- f sa) off aFoot +-- , translateSHxy (f sa) (- off) aFoot +-- ] +-- _ -> +-- mconcat +-- [ translateSHxy 0 off aFoot +-- , translateSHxy 0 (- off) aFoot +-- ] +-- where +-- aFoot :: Shape +-- aFoot = upperPrismPolyT 3 $ polyCirc 3 4 +-- off = 5 +-- sLen = _strideLength $ _crStance cr +-- f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen arms :: Creature -> Shape {-# INLINE arms #-} @@ -105,7 +106,7 @@ arms cr = translateToRightHand cr aHand <> translateToLeftHand cr aHand where - aHand = noPic $ translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4 + aHand = noPic $ translateSHz (-4) . upperPrismPolyHalfST 4 $ polyCirc 3 4 deadScalp :: Creature -> Shape deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr @@ -126,7 +127,7 @@ scalp cr | oneH cr = rotateSH 0.5 $ translateSHxy 2.5 0 fhead | otherwise = translateSHxy 2.5 0 fhead where - fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 3 5 + fhead = colorSH (greyN 0.9) . upperPrismPolyHalfST 5 $ polyCirc 3 5 torso :: Creature -> Shape {-# INLINE torso #-} @@ -156,7 +157,7 @@ deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr baseShoulder :: Shape {-# INLINE baseShoulder #-} -baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalf 10 $ polyCirc 3 1 +baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1 upperBody :: Creature -> Shape {-# INLINE upperBody #-} diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index b8177f079..23e5daee9 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/src/Dodge/Creature/YourControl.hs @@ -118,7 +118,7 @@ mouseActionsCr pkeys cr pressedMBEffectsTopInventory :: M.Map SDL.MouseButton Bool -> World -> World pressedMBEffectsTopInventory pkeys w | isDown SDL.ButtonLeft && isDown SDL.ButtonRight && inTopInv = useItem (you w) w - | isDown SDL.ButtonLeft && inTopInv = useLeftItem 0 w + | isDown SDL.ButtonLeft && inTopInv = doTopInvLeftClick (you w) w | isDown SDL.ButtonMiddle = w & cWorld . cwCamPos . camRot -~ rotation & input . clickMousePos .~ _mousePos (_input w) diff --git a/src/Dodge/Data/Config.hs b/src/Dodge/Data/Config.hs index a07986b5e..759c7cab0 100644 --- a/src/Dodge/Data/Config.hs +++ b/src/Dodge/Data/Config.hs @@ -3,6 +3,7 @@ module Dodge.Data.Config where +import Shape.Data import Control.Lens import Data.Aeson import Data.Aeson.TH @@ -41,7 +42,8 @@ data Configuration = Configuration , _graphics_cloud_shadows :: Bool , _graphics_distortions :: Bool , _graphics_bloom :: Bool - , _graphics_object_shadows :: ShadowRendering + , _graphics_shadow_rendering :: ShadowRendering + , _graphics_shadow_size :: Importance , _graphics_downsize_resolution :: ResFactor , _graphics_world_resolution :: ResFactor , _graphics_overlay_resolution :: ResFactor @@ -129,7 +131,8 @@ defaultConfig = , _volume_music = 0 , _graphics_cloud_shadows = True , _graphics_bloom = True - , _graphics_object_shadows = GeoObjShads + , _graphics_shadow_rendering = GeoObjShads + , _graphics_shadow_size = Typical , _graphics_distortions = True , _graphics_downsize_resolution = SixteenthRes , _graphics_world_resolution = QuarterRes diff --git a/src/Dodge/Data/Item/Use.hs b/src/Dodge/Data/Item/Use.hs index 416683afa..9fd0b7dfa 100644 --- a/src/Dodge/Data/Item/Use.hs +++ b/src/Dodge/Data/Item/Use.hs @@ -42,6 +42,7 @@ data ItemUse , _leftHammer :: HammerPosition , _equipEffect :: EquipEffect , _leftConsumption :: LeftConsumption + , _leftUseOnEquip :: Bool } | ConsumeUse { _cUse :: Cuse @@ -55,6 +56,16 @@ data ItemUse {_useAmount :: ItAmount} --deriving (Eq, Show, Read) --Generic, Flat) +data ItemUse' + = ItemHeld HeldUse' + | ItemEquip EquipUse' + | ItemConsume ConsumeUse' + | ItemCraft Int + +data HeldUse' = HeldUse' +data EquipUse' = EquipUse' +data ConsumeUse' = ConsumeUse' + data AimParams = AimParams { _aimWeight :: Int , _aimTurnSpeed :: Float diff --git a/src/Dodge/Default/Item/Use.hs b/src/Dodge/Default/Item/Use.hs index af363c03e..9b2dacf6d 100644 --- a/src/Dodge/Default/Item/Use.hs +++ b/src/Dodge/Default/Item/Use.hs @@ -18,6 +18,7 @@ defaultLeftUse = , _leftHammer = HammerUp , _equipEffect = defaultEquip , _leftConsumption = defaultLeftLoadable + , _leftUseOnEquip = False } defaultEquipUse :: ItemUse diff --git a/src/Dodge/Item/Draw/SPic.hs b/src/Dodge/Item/Draw/SPic.hs index 5476b9ca7..789263680 100644 --- a/src/Dodge/Item/Draw/SPic.hs +++ b/src/Dodge/Item/Draw/SPic.hs @@ -38,10 +38,10 @@ equipItemSPic et _ = case et of ] ) WRISTARMOUR -> defSPic - INVISIBILITYEQUIPMENT _ -> noPic (colorSH chartreuse $ upperPrismPoly 3 $ rectWH 2 2) - BRAINHAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4) - HAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4) - TARGETINGHAT _ -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4) + 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) + TARGETINGHAT _ -> noPic (colorSH yellow $ upperPrismPolySU 3 $ rectWH 4 4) HEADLAMP -> noPic headLampShape POWERLEGS -> legsSPic yellow SPEEDLEGS -> legsSPic green @@ -49,11 +49,11 @@ equipItemSPic et _ = case et of JETPACK -> noPic $ colorSH yellow backpackShape BATTERYPACK -> noPic $ colorSH blue backpackShape FUELPACK -> - noPic $ colorSH yellow $ upperPrismPoly 10 $ polyCirc 3 5 - AUTODETECTOR dt -> noPic (colorSH (detectorColor dt) $ upperPrismPoly 3 $ rectWH 2 2) + noPic $ colorSH yellow $ upperPrismPolyMT 10 $ polyCirc 3 5 + AUTODETECTOR dt -> noPic (colorSH (detectorColor dt) $ upperPrismPolySU 3 $ rectWH 2 2) backpackShape :: Shape -backpackShape = upperPrismPoly 10 $ rectNSWE 5 (-5) (-4) 4 +backpackShape = upperPrismPolyMT 10 $ rectNSWE 5 (-5) (-4) 4 leftItemSPic :: LeftItemType -> Item -> SPic leftItemSPic lt _ = case lt of @@ -184,7 +184,7 @@ heldItemSPic ht it = case ht of POISONSPRAYER -> flamerPic it DRONELAUNCHER -> defSPic SHATTERGUN -> shatterGunSPic - HELDDETECTOR dt -> noPic (colorSH (detectorColor dt) $ upperPrismPoly 3 $ rectWH 2 2) + HELDDETECTOR dt -> noPic (colorSH (detectorColor dt) $ upperPrismPolySU 3 $ rectWH 2 2) KEYCARD _ -> noShape (setDepth 0 $ translate (-5) (-5) $ rotate (pi / 2.5) keyPic) BINOCULARS -> mempty -- TODO @@ -197,10 +197,10 @@ torchShape = <> translateSHz (-0.5) bot <> back where - side = upperPrismPoly 3 $ rectXH 10 0.5 - top = upperPrismPoly 0.5 $ rectXH 10 2 - bot = upperPrismPoly 0.5 $ rectXH 9 2 - back = upperPrismPoly 3 $ rectXH 1 2 + 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 modulesSPic :: Item -> ModuleSlot -> ItemModuleType -> SPic modulesSPic it _ imt = case imt of @@ -216,35 +216,36 @@ baseStickShapeX it i = foldMap f [0 .. i -1] barrelspread = it ^?! itParams . gunBarrels . brlSpread . spreadAngle baseStickShape :: Shape -baseStickShape = colorSH green $ upperPrismPoly 3 $ rectXH 10 2 +baseStickShape = colorSH green $ xCylinderST 3 10 bangConeShape :: Float -> Shape bangConeShape x = colorSH cyan $ - upperPrismPoly 3 (rectXH x 2) - <> upperPrismPoly 6 (reverse $ rectNSWE 4 (-4) x (10 + x)) + xCylinderST 3 x + <> upperPrismPolyST 6 (reverse $ rectNSWE 4 (-4) x (10 + x)) defSPic :: SPic -defSPic = noPic $ colorSH green $ upperPrismPoly 3 $ square 4 +defSPic = noPic $ colorSH green $ upperPrismPolyST 3 $ square 4 shatterGunSPic :: SPic shatterGunSPic = +-- TODO cylinderize noPic $ colorSH blue $ - upperPrismPoly 5 (rectNESW xb 8 xa 0) - <> upperPrismPoly 5 (rectNESW (- xa) 8 (- xb) 0) + upperPrismPolyST 5 (rectNESW xb 8 xa 0) + <> upperPrismPolyST 5 (rectNESW (- xa) 8 (- xb) 0) where xa = 1 xb = 9 baseCaneShape :: Shape -baseCaneShape = colorSH red $ upperPrismPoly 3 $ rectXH 15 1.5 +baseCaneShape = colorSH red $ xCylinderST 3 15 baseRifleShape :: Shape --baseRifleShape = colorSH red $ upperPrismPoly 3 $ rectXH 25 2 --baseRifleShape = colorSH red . rotateSHq (V3 0 1 0) (pi/2) . upperCylinder 25 $ polyCirc 3 2 --baseRifleShape = colorSH red $ xCylinder 4 2 25 -baseRifleShape = colorSH red $ xCylinder' 3 25 +baseRifleShape = colorSH red $ xCylinderST 3 25 addBullets :: Item -> Shape addBullets itm = fromMaybe mempty $ do @@ -253,13 +254,14 @@ addBullets itm = fromMaybe mempty $ do ps <- fmap (take x) $ ammoPosition itm hit ^? amPosDirs return $ foldMap (uncurry (drawBullet itm)) ps +-- why is this duplicated? drawBullet :: Item -> Point3 -> Q.Quaternion Float -> Shape drawBullet itm p q = translateSH p $ overPosSH (Q.rotate q) $ colorSH midcol - ( upperPrismPoly 0.2 $ + ( upperPrismPolyTS 0.2 $ reverse (rectNSWE 0.2 (- 0.2) (-1) 1) ) @@ -275,14 +277,14 @@ drawBullet itm p q = ebt <- itm ^? itUse . heldConsumption . laAmmoType . amBullet . buSpawn return $ colorSH (bulletPayloadColor ebt) $ - upperPrismPoly 0.2 $ + upperPrismPolyTS 0.2 $ reverse $ rectNSWE 0.2 (- 0.2) 1 2 foot = fromMaybe mempty $ do ebt <- itm ^? itUse . heldConsumption . laAmmoType . amBullet . buTrajectory return $ colorSH (bulletTrajColor ebt) $ - upperPrismPoly 0.2 $ + upperPrismPolyTS 0.2 $ reverse $ rectNSWE 0.2 (- 0.2) (-2) (-1) @@ -298,7 +300,7 @@ makeTinClip :: Item -> Shape makeTinClip it = colorSH midcol - ( upperPrismPoly + ( upperPrismPolyTS 1 ( reverse $ rectNSWE 0 (- y) (-1) 1 @@ -318,14 +320,14 @@ makeTinClip it = ebt <- it ^? itUse . heldConsumption . laAmmoType . amBullet . buSpawn return $ colorSH (bulletPayloadColor ebt) $ - upperPrismPoly 1.1 $ + upperPrismPolyTS 1.1 $ reverse $ rectNSWE 0 (- y) 1 2 tails = fromMaybe mempty $ do ebt <- it ^? itUse . heldConsumption . laAmmoType . amBullet . buTrajectory return $ colorSH (bulletTrajColor ebt) $ - upperPrismPoly 1.1 $ + upperPrismPolyTS 1.1 $ reverse $ rectNSWE 0 (- y) (-2) (-1) @@ -362,7 +364,7 @@ volleyGunShape i = colorSH red ( foldMap - ( (\y -> upperPrismPoly 3 $ map (+.+ V2 0 y) $ rectXH 15 2) + ( (\y -> translateSHxy 0 y $ xCylinderST 3 15) . (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5)) ) [0 .. i -1] @@ -395,13 +397,13 @@ miniGunXPict i spin _ = --baseSonicShape = colorSH rose $ upperPrismPoly 3 $ rectXH 25 2 baseSMGShape :: Shape -baseSMGShape = colorSH green $ upperPrismPoly 3 $ rectXH 20 2 +baseSMGShape = colorSH green $ xCylinderST 3 20 flamerPic :: Item -> SPic flamerPic it = ( colorSH yellow $ - translateSHxy tx ty (upperPrismPoly tz $ polyCirc 3 r) - <> upperPrismPoly 5 (rectNESW 2 18 (-2) 0) + translateSHxy tx ty (upperPrismPolyST tz $ polyCirc 3 r) + <> xCylinderST 5 18 , color black $ translate3 (V3 tx ty (tz + 0.01)) $ circleSolid (r * am) ) where @@ -412,7 +414,7 @@ flamerPic it = am = fractionLoadedAmmo2 it launcherPic :: Item -> SPic -launcherPic _ = noPic . colorSH cyan $ xCylinder' 5 20 +launcherPic _ = noPic . colorSH cyan $ xCylinderST 5 20 --launcherPic _ = noPic . colorSH cyan $ xCylinder 4 5 20 -- ( colorSH cyan $ -- prismPoly @@ -422,17 +424,17 @@ launcherPic _ = noPic . colorSH cyan $ xCylinder' 5 20 -- ) baseRodShape :: Shape -baseRodShape = colorSH orange $ upperPrismPoly 3 $ rectXH 20 2 +baseRodShape = colorSH orange $ xCylinderST 3 20 baseAMRShape :: Shape -baseAMRShape = colorSH orange $ upperPrismPoly 3 $ rectXH 30 2 +baseAMRShape = colorSH orange $ xCylinderST 3 30 teslaGunPic :: SPic teslaGunPic = noPic $ colorSH blue $ - upperPrismPoly 5 (rectNESW xb 8 xa 0) - <> upperPrismPoly 5 (rectNESW (- xa) 8 (- xb) 0) + upperPrismPolyST 5 (rectNESW xb 8 xa 0) + <> upperPrismPolyST 5 (rectNESW (- xa) 8 (- xb) 0) where xa = 1 xb = 9 @@ -440,9 +442,9 @@ teslaGunPic = lasGunPic :: Item -> SPic lasGunPic it = ( colorSH blue $ - upperPrismPoly 4 (rectNESW 3 30 1 0) - <> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0) - <> upperPrismPoly 1 (rectNESW 3 30 (-3) 0) + upperBoxST 4 (rectNESW 3 30 1 0) + <> upperBoxSU 4 (rectNESW (-1) 30 (-3) 0) + <> upperBoxSU 1 (rectNESW 3 30 (-3) 0) , setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0 ) where @@ -452,9 +454,9 @@ lasGunPic it = dualBeamPic :: Item -> SPic dualBeamPic it = ( colorSH blue $ - upperPrismPoly 4 (rectNESW gap 3 (- gap) 1) - <> upperPrismPoly 4 (rectNESW gap (-1) (- gap) (-3)) - <> upperPrismPoly 1 (rectNESW gap 3 (- gap) (-3)) + 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 @@ -463,30 +465,23 @@ dualBeamPic it = gap = _dbGap (_itParams it) - 3 tractorGunPic :: Item -> SPic -tractorGunPic it = - ( colorSH red $ - upperPrismPoly 4 (rectNESW 3 30 1 0) - <> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0) - <> upperPrismPoly 1 (rectNESW 3 30 (-3) 0) - , setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0 - ) - where - amFrac = fractionLoadedAmmo it - col = brightX 2 1.5 $ mixColors amFrac (1 - amFrac) green red +tractorGunPic = lasGunPic flatShieldEquipSPic :: SPic flatShieldEquipSPic = - ( colorSH yellow $ upperPrismPoly 10 (rectWH 2 10) + ( colorSH yellow $ upperBoxMT 10 (rectWH 2 10) , mempty ) headLampShape :: Shape headLampShape = colorSH yellow $ - translateSH (V3 5 2 4) (upperPrismPoly 4 $ rectWH 4 1) - <> translateSH (V3 5 2 0) (upperPrismPoly 4 $ rectWH 4 1) - <> translateSH (V3 5 (-2) 4) (upperPrismPoly 4 $ rectWH 4 1) - <> translateSH (V3 5 (-2) 0) (upperPrismPoly 4 $ rectWH 4 1) + 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 @@ -513,4 +508,4 @@ keyPic = -- ] legsSPic :: Color -> SPic -legsSPic col = noPic $ translateSH (V3 0 4 0) $ colorSH col $ upperPrismPoly 3 $ rectWH 2 2 +legsSPic col = noPic $ translateSH (V3 0 4 0) $ colorSH col $ upperPrismPolyST 3 $ rectWH 2 2 diff --git a/src/Dodge/Item/Weapon/Drone.hs b/src/Dodge/Item/Weapon/Drone.hs index eb44ee7da..0fa1f93af 100644 --- a/src/Dodge/Item/Weapon/Drone.hs +++ b/src/Dodge/Item/Weapon/Drone.hs @@ -23,7 +23,7 @@ droneLauncher = lasDronesPic :: Item -> SPic lasDronesPic _ = ( colorSH chartreuse $ - prismPoly + prismPoly Small Typical (map (+.+.+ V3 10 0 4.5) $ polyCircx 4 5) (map (+.+.+ V3 (-10) 0 4.5) $ polyCircx 4 5) , mempty diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs index 9f05ff17e..f79e380de 100644 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ b/src/Dodge/Item/Weapon/Grenade.hs @@ -58,7 +58,7 @@ import Shape grenadePic :: Int -> SPic grenadePic time = - ( colorSH (dark $ dark green) $ upperPrismPolyHalf 5 $ polyCirc 3 5 + ( colorSH (dark $ dark green) $ upperPrismPolyHalf Small Typical 5 $ polyCirc 3 5 , pictures [ color green $ arc (degToRad $ (179 * fromIntegral time / 50) - 180 ) (degToRad $ 180 - (179 * fromIntegral time / 50) ) diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs index 2d6e6f0b7..d10897437 100644 --- a/src/Dodge/LevelGen/Switch.hs +++ b/src/Dodge/LevelGen/Switch.hs @@ -24,15 +24,15 @@ makeButton col eff = defaultButton , _btState = BtOff } - +-- TODO remove duplication drawSwitchWire :: Color -> Color -> Button -> SPic drawSwitchWire col1 col2 bt | _btState bt == BtOff = flick $ pi/4 | otherwise = flick (negate (pi/4)) where flick a = ( mconcat - [ colorSH col1 . translateSHz 10 . upperPrismPoly 10 $ reverse $ rectNSWE (-2) (-5) (-10) 10 - , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperPrismPoly 2 . reverse + [ colorSH col1 . translateSHz 10 . upperBox Small Typical 10 $ reverse $ rectNSWE (-2) (-5) (-10) 10 + , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperBox Small Typical 2 . reverse $ rectNSWE 10 0 (-2) 2 ] , mempty) diff --git a/src/Dodge/Machine/Draw.hs b/src/Dodge/Machine/Draw.hs index ec2ad9d9c..9ff557101 100644 --- a/src/Dodge/Machine/Draw.hs +++ b/src/Dodge/Machine/Draw.hs @@ -28,13 +28,13 @@ terminalShape :: Machine -> Shape terminalShape mc = colorSH col - ( prismPoly + ( prismBox Medium Typical [V3 10 10 20, V3 (-10) 10 20, V3 (-10) (-10) 10, V3 10 (-10) 10] [V3 10 10 0, V3 (-10) 10 0, V3 (-10) (-10) 0, V3 10 (-10) 0] ) <> colorSH black - ( prismPoly + ( prismBox Small Superfluous [V3 8 8 20, V3 (-8) 8 20, V3 0 (-8) 10] [V3 8 8 19, V3 (-8) 8 19, V3 0 (-8) 9] --[V3 8 8 20, V3 (-8) 8 20, V3 (-8) (-8) 10, V3 8 (-8) 10] @@ -45,7 +45,7 @@ terminalShape mc = drawBaseMachine :: Float -> Machine -> SPic drawBaseMachine h mc = - ( colorSH (_mcColor mc) $ upperPrismPoly h (reverse $ square (_mcWidth mc)) + ( colorSH (_mcColor mc) $ upperBox Medium Typical h (reverse $ square (_mcWidth mc)) , mempty ) drawTurret :: Turret -> Machine -> SPic diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index b8408eb00..49c64c24a 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -187,7 +187,8 @@ graphicsMenuOptions = (uvIOEffects .~ updatePreload) , makeEnumOption graphics_overlay_resolution "Overlay resolution" (uvIOEffects .~ updatePreload) - , makeEnumOption graphics_object_shadows "SHADOW DETAIL" id + , makeEnumOption graphics_shadow_rendering "SHADOW RENDERING" id + , makeEnumOption graphics_shadow_size "SHADOW DETAIL" id , makeEnumOption graphics_distortions "ENABLE DISTORTIONS" id , makeEnumOption graphics_bloom "ENABLE BLOOM" id , makeBoolOption graphics_cloud_shadows "CLOUD SHADOWS" diff --git a/src/Dodge/Placement/Instance/Pipe.hs b/src/Dodge/Placement/Instance/Pipe.hs index 42f7ddf69..c24f6861c 100644 --- a/src/Dodge/Placement/Instance/Pipe.hs +++ b/src/Dodge/Placement/Instance/Pipe.hs @@ -4,7 +4,7 @@ import Geometry import Quaternion verticalPipe :: Float -> Shape -verticalPipe = flip upperPrismPoly $ polyCirc 2 5 +verticalPipe = flip (upperBox Small Typical) (polyCirc 2 5) horPipe :: Float -> Point2 -> Point2 -> Shape horPipe h x y = translateSH (x `v2z` h) $ overPosSH (rotateToZ (V3 xd yd 0)) $ verticalPipe (dist x y) diff --git a/src/Dodge/Placement/TopDecoration.hs b/src/Dodge/Placement/TopDecoration.hs index 100162909..7b20e3009 100644 --- a/src/Dodge/Placement/TopDecoration.hs +++ b/src/Dodge/Placement/TopDecoration.hs @@ -22,7 +22,7 @@ midBarDecoration w h z _ c = w' = 0.3 * w embossingR = colorSH c $ - prismPoly + prismPoly Medium Typical [V3 w h z, V3 w (0.3 * h) 41, V3 w (-0.3 * h) 41, V3 w (- h) z] [V3 w' h z, V3 w' (0.3 * h) 41, V3 w' (-0.3 * h) 41, V3 w' (- h) z] @@ -30,7 +30,7 @@ fourEmbossDecoration :: Float -> Float -> Float -> Color -> Color -> Shape fourEmbossDecoration w h z _ c = colorSH c $ foldMap f [(w, h), (- w, h), (w, - h), (- w, - h)] where f (a, b) = translateSH (V3 (a / 2) (b / 2) z) embossing - embossing = upperPrismPolyHalf 10 $ reverse $ rectNSWE (h / 2) (- h / 2) (- w / 2) (w / 2) + embossing = upperBoxHalf Large Typical 10 $ reverse $ rectNSWE (h / 2) (- h / 2) (- w / 2) (w / 2) plusDecoration :: Float -> Float -> Float -> Color -> Color -> Shape plusDecoration w h z _ c = diff --git a/src/Dodge/Projectile/Draw.hs b/src/Dodge/Projectile/Draw.hs index ee331b821..5e99f694d 100644 --- a/src/Dodge/Projectile/Draw.hs +++ b/src/Dodge/Projectile/Draw.hs @@ -22,7 +22,7 @@ drawShell pj = $ rotateSH (argV $ _prjAcc pj) shellShape shellShape :: Shape -shellShape = colorSH black $ upperPrismPoly 4 $ map toV2 [(-6, 4), (-6, -4), (6, -4), (8, 0), (6, 4)] +shellShape = colorSH black $ upperPrismPoly Small Typical 4 $ map toV2 [(-6, 4), (-6, -4), (6, -4), (8, 0), (6, 4)] drawRemoteShell :: Proj -> SPic drawRemoteShell pj diff --git a/src/Dodge/Prop/Draw.hs b/src/Dodge/Prop/Draw.hs index 0b6b7a9d2..f36473084 100644 --- a/src/Dodge/Prop/Draw.hs +++ b/src/Dodge/Prop/Draw.hs @@ -7,6 +7,7 @@ import Picture import qualified Quaternion as Q import Shape import ShapePicture +import Control.Lens drawProp' :: Prop -> SPic drawProp' pr = drawProp (_prDraw pr) pr @@ -29,12 +30,11 @@ drawGib x pr = flesh <> skin where flesh = colorSH (dark $ dark red) - . translateSHz (negate x) - $ upperPrismPoly (2 * x) $ square x + $ translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous) skin = colorSH (_prColor pr) - . translateSH (V3 1 1 (1 - x)) - $ upperPrismPoly (2 * x) $ square x + $ translateSH (V3 1 1 (1 - x)) baseCube + baseCube = upperPrismPoly Small Typical (2 * x) $ square x propDrawToggle :: PropDraw -> Prop -> SPic propDrawToggle pd pr @@ -46,21 +46,24 @@ drawLampCover h pr = ( translateSHz (h -2.5) . uncurryV translateSHxy (_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)] + [ aface 1 2 (-1) + , aface 1 (-1) 2 + , aface 2 2 (-1) + , aface 2 (-1) 2 + , upperPrismPoly Small Essential 1 [V2 2 2, V2 (-1) 2, V2 2 (-1)] ] , mempty ) + where + aface ztran s w = translateSHz ztran . upperPrismPoly Small Essential 1 + . reverse $ rectNSWE 3 s w 3 drawVerticalLampCover :: Float -> Prop -> SPic drawVerticalLampCover h pr = ( translateSHz h . uncurryV translateSHxy (_prPos pr) $ rotateSHx (_prRot pr) $ mconcat - [ translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5 + [ translateSHz (-3) . upperPrismPoly Small Essential 1 $ reverse $ rectNSWE 2 (-2) (-5) 5 ] , mempty ) @@ -85,10 +88,10 @@ drawDoubleLampCover h pr = ( translateSHz (h -2.5) . uncurryV translateSHxy (_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)] + [ upperPrismPoly Small Essential 5 $ reverse $ rectNSWE 6 5 (-6) 6 + , upperPrismPoly Small Essential 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6 + , upperPrismPoly Small Essential 1 [V2 0 (-1), V2 6 5, V2 (-6) 5] + , upperPrismPoly Small Essential 1 [V2 0 1, V2 (-6) (-5), V2 6 (-5)] ] , mempty ) diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 3e1a33058..00746c53e 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -6,6 +6,7 @@ module Dodge.Render ( --import qualified Data.Vector as V +import Dodge.Shadows import Dodge.WindowSize import Control.Lens import Control.Monad @@ -76,7 +77,7 @@ doDrawing' win pdata u = do windowPoints wallsToPoke ) - ( pokeShape + ( pokeShape (drawShadowsByImportance $ cfig ^. graphics_shadow_size) (_vboPtr $ _vboShapes pdata) (_eboPtr $ _shapeEBO pdata) (_eboPtr $ _silhouetteEBO pdata) @@ -199,7 +200,6 @@ doDrawing' win pdata u = do --draw lightmap into its own buffer createLightMap cfig - (u ^. uvConfig . graphics_object_shadows) (fromIntegral trueNWalls) nSilIndices nIndices @@ -320,7 +320,6 @@ doDrawing' win pdata u = do glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) createLightMap cfig - (_graphics_object_shadows $ _uvConfig u) (fromIntegral trueNWalls) nSilIndices nIndices diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 341868390..4692c2ccd 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -112,7 +112,7 @@ drawCreature cr = case _crType cr of lampCrSPic :: Float -> SPic lampCrSPic h = - ( colorSH blue . upperBox h $ rectWH 5 5 + ( colorSH blue . upperBox Small Typical h $ rectWH 5 5 , setLayer BloomLayer (setDepth h . color white $ circleSolid 3) ) diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 673e1da1c..58313f37e 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -90,7 +90,8 @@ highBar :: Float -> Float -> Point2 -> Point2 -> Shape highBar thickness h x y = translateSHz h $ colorSH orange $ - upperPrismPoly + upperBoxMT + --upperPrismPolySU thickness [x +.+ n, y +.+ n, y -.- n, x -.- n] where @@ -236,7 +237,7 @@ barPP :: Float -> Point3 -> Point3 -> Shape barPP w a b | a == b = mempty | otherwise = - prismPoly + cylinderPoly Medium Typical (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 2 w) (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 2 w) where diff --git a/src/Render.hs b/src/Render.hs index e4d6bbda6..ce3a089ff 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -27,7 +27,6 @@ import Shader.Data -} createLightMap :: Configuration -> - ShadowRendering -> -- | number of walls GLsizei -> -- | number of silhoutte lines to draw @@ -41,11 +40,13 @@ createLightMap :: [(Point3, Float, Point3)] -> -- Lights RenderData -> IO () -createLightMap cfig shadrendertype = case shadrendertype of +createLightMap cfig = case shadrendertype of InstancingShads -> instanceLightMap cfig NoShadows -> const . const . const renderLightingNoShadows NoLighting -> const . const . const . const . const . const renderFlatLighting _ -> renderShadows shadrendertype + where + shadrendertype = cfig ^. graphics_shadow_rendering renderLightingNoShadows :: TO -> diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index d81a19e8c..bf4cb2fe5 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -95,15 +95,18 @@ pokeW ptr i' ((V2 a b, V2 c d), V4 e f g h) = do return $ i' + 1 pokeShape :: + (Surface -> Bool) -> Ptr Float -> Ptr GLushort -> Ptr GLushort -> (Int, Int, Int) -> [Surface] -> IO (Int, Int, Int) -pokeShape ptr iptr ieptr is = VFSM.foldlM' (pokeShapeObj ptr iptr ieptr) is . VFSM.fromList +pokeShape shadowtest ptr iptr ieptr is = VFSM.foldlM' (pokeShapeObj shadowtest ptr iptr ieptr) is + . VFSM.fromList pokeShapeObj :: + (Surface -> Bool) -> Ptr Float -> Ptr GLushort -> Ptr GLushort -> @@ -111,13 +114,15 @@ pokeShapeObj :: Surface -> IO (Int, Int, Int) {-# INLINE pokeShapeObj #-} -pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col shadfid) = case shtype of - FlatFaces size -> pokeBox shadfid col size ptr iptr ieptr counts shVerts - RoundedFaces size -> pokeRoundedFaces shadfid col size ptr iptr ieptr counts shVerts - Cylinder size -> pokeCylinder shadfid col size ptr iptr ieptr counts shVerts +pokeShapeObj shadowtest ptr iptr ieptr counts surf@(Surface shtype shVerts col _ _) = case shtype of + FlatFaces size -> pokeBox blockshadows col size ptr iptr ieptr counts shVerts + RoundedFaces size -> pokeRoundedFaces blockshadows col size ptr iptr ieptr counts shVerts + Cylinder size -> pokeCylinder blockshadows col size ptr iptr ieptr counts shVerts + where + blockshadows = shadowtest surf pokeRoundedFaces :: - ShadowFidelity -> + Bool -> Point4 -> Int -> Ptr Float -> @@ -134,15 +139,14 @@ pokeRoundedFaces sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = d (pokeIndex nv iptr) nsi (memoTopPrismIndices V.! (size - 3)) - nei' <- case sfid of - NoShadowFidelity -> return nei - FullShadowFidelity -> UV.foldM' (pokeIndex nv ieptr) nei $ + nei' <- if sfid then return nei + else UV.foldM' (pokeIndex nv ieptr) nei $ memoTopPrismEdgeIndices V.! (size - 3) return (nv', nsi', nei') pokeRoundedFaces _ _ _ _ _ _ _ _ = undefined pokeCylinder :: - ShadowFidelity -> + Bool -> Point4 -> Int -> Ptr Float -> @@ -159,9 +163,9 @@ pokeCylinder sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = do (pokeIndex nv iptr) nsi (memoCylinderIndices V.! (size - 3)) - nei' <- case sfid of - NoShadowFidelity -> return nei - FullShadowFidelity -> UV.foldM' (pokeIndex nv ieptr) nei $ + nei' <- if sfid + then return nei + else UV.foldM' (pokeIndex nv ieptr) nei $ memoTopPrismEdgeIndices V.! (size - 3) return (nv', nsi', nei') pokeCylinder _ _ _ _ _ _ _ _ = undefined @@ -182,7 +186,7 @@ pokeCylinderCaps col ptr tc bc = go True go _ [] n = return n pokeBox :: - ShadowFidelity -> + Bool -> Point4 -> Int -> Ptr Float -> @@ -199,9 +203,8 @@ pokeBox sfid col size ptr iptr ieptr (nv, nsi, nei) svs = do (pokeIndex nv iptr) nsi (memoFlatIndices V.! (size -3)) - nei' <- case sfid of - NoShadowFidelity -> return nei - FullShadowFidelity -> UV.foldM' (pokeIndex nv ieptr) nei $ + nei' <- if sfid then return nei + else UV.foldM' (pokeIndex nv ieptr) nei $ memoBoxEdgeIndices V.! (size - 3) return (nv', nsi', nei') where @@ -297,15 +300,12 @@ boxEdgeIndices :: [Int] boxEdgeIndices n = concatMap f [0 .. n -1] where - f i = - map - g - [ 0 , 1 , n , 2 - , 0 , n , -1 , n + 1 - , n , n + 1 , n -1 , 1 + f i = [ g 0 , g 1 ,n + g 0 , g 2 + , g 0 , n + g 0 , n + g (-1) , g 1 + , n + g 0 , n + g 1 , n + g (-1) , g 1 ] where - g j = (i + j) `mod` (2 * n) + g j = (i + j) `mod` n cylinderIndices :: Int -> [Int] cylinderIndices n = diff --git a/src/Shape.hs b/src/Shape.hs index e2f4813a0..79465be3a 100644 --- a/src/Shape.hs +++ b/src/Shape.hs @@ -1,36 +1,52 @@ -{-# LANGUAGE BangPatterns #-} -module Shape - ( module Shape.Data - , translateSH - , upperPrismPoly - , upperPrismPolyHalf - , prismPoly - , polyCirc - , upperBox - , translateSHz - , translateSHxy - , rotateSH - , rotateSHx - , rotateSHq - , polyCircx - , scaleSH - , colorSH - , overColSH - , overPosSH - , upperCylinder - , upperRounded - , xCylinder - , xCylinder' - ) where -import Geometry -import Shape.Data +{-# LANGUAGE BangPatterns #-} + +module Shape ( + module Shape.Data, + translateSH, + upperPrismPoly, + upperPrismPolyMT, + upperPrismPolySE, + upperPrismPolyST, + upperPrismPolySI, + upperPrismPolySU, + upperPrismPolyTS, + upperBoxMT, + upperBoxST, + upperBoxSU, + upperBoxHalf, + upperPrismPolyHalf, + upperPrismPolyHalfMI, + upperPrismPolyHalfST, + xCylinderST, + prismPoly, + prismBox, + cylinderPoly, + polyCirc, + upperBox, + translateSHz, + translateSHxy, + rotateSH, + rotateSHx, + rotateSHq, + polyCircx, + scaleSH, + colorSH, + overColSH, + overPosSH, + upperCylinder, + upperRounded, + xCylinder', +) where + import Color +import Geometry import qualified Quaternion as Q +import Shape.Data -- - approximate a circle by a polygon with n*2 points of radius x polyCirc :: Int -> Float -> [Point2] {-# INLINE polyCirc #-} -polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/fromIntegral n..] +polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n * 2) [0, pi / fromIntegral n ..] -- - approximate a circle around the x axis by a polygon with n*2 points of radius r polyCircx :: Int -> Float -> [Point3] @@ -40,83 +56,175 @@ polyCircx n = map (vNormaly . addZ 0) . polyCirc n -- length of polys must be the same -- points should be correctly ordered so that -- polys form a prism-like object with quad faces between them -prismPoly - :: [Point3] - -> [Point3] - -> Shape +prismPoly :: + Size -> + Importance -> + [Point3] -> + [Point3] -> + Shape {-# INLINE prismPoly #-} -prismPoly upps downps = [Surface (RoundedFaces n) (cp:cp:f upps downps) white FullShadowFidelity] +prismPoly size shads upps downps = [Surface (RoundedFaces n) (cp : cp : f upps downps) white shads size] where cp = centroidNum $ upps ++ downps n = length upps - f (a:as) (b:bs) = a:b:f as bs + f (a : as) (b : bs) = a : b : f as bs f _ _ = [] -upperPrismPoly - :: Float -- ^ height, expected to be strictly positive - -> [Point2] - -> Shape -{-# INLINE upperPrismPoly #-} -upperPrismPoly h ps = prismPoly (map (addZ h) ps) (map (addZ 0) ps) - -xCylinder :: Int -> Float -> Float -> Shape -xCylinder n r x = rotateSHq (V3 0 1 0) (pi/2) . translateSHxy (-r) 0 . upperCylinder x $ polyCirc n r - -xCylinder' :: Float -> Float -> Shape -xCylinder' r x = translateSHz r . rotateSHq (V3 0 1 0) (pi/2) . upperCylinder x $ - [V2 r r - ,V2 (-r/2) (r/2) - ,V2 (-r/2) (negate $ r/2) - ,V2 r (-r) - ] - -upperBox - :: Float -- ^ height, expected to be strictly positive - -> [Point2] - -> Shape -{-# INLINE upperBox #-} -upperBox h ps = [Surface (FlatFaces n) (f ps) white FullShadowFidelity] +prismBox :: + Size -> + Importance -> + [Point3] -> + [Point3] -> + Shape +{-# INLINE prismBox #-} +prismBox size shads upps downps = [Surface (FlatFaces n) (f upps downps) white shads size] where - n = length ps - g h' (V2 x y) = V3 x y h' - f (x:xs) = g h x : g 0 x : f xs - f _ = [] + n = length upps + f (a : as) (b : bs) = a : b : f as bs + f _ _ = [] + +cylinderPoly :: + Size -> + Importance -> + [Point3] -> + [Point3] -> + Shape +{-# INLINE cylinderPoly #-} +cylinderPoly size shads upps downps = [Surface (Cylinder n) (cp1 : cp2 : f upps downps) white shads size] + where + cp1 = centroidNum upps + cp2 = centroidNum downps + n = length upps + f (a : as) (b : bs) = a : b : f as bs + f _ _ = [] + +upperPrismPolyMT :: Float -> [Point2] -> Shape +upperPrismPolyMT = upperPrismPoly Medium Typical + +upperPrismPolySE :: Float -> [Point2] -> Shape +upperPrismPolySE = upperPrismPoly Small Essential + +upperPrismPolyST :: Float -> [Point2] -> Shape +upperPrismPolyST = upperPrismPoly Small Typical + +upperPrismPolySI :: Float -> [Point2] -> Shape +upperPrismPolySI = upperPrismPoly Small Important + +upperPrismPolySU :: Float -> [Point2] -> Shape +upperPrismPolySU = upperPrismPoly Small Unimportant + +--upperPrismPolySS :: Float -> [Point2] -> Shape +--upperPrismPolySS = upperPrismPoly Small Superfluous + +upperPrismPolyTS :: Float -> [Point2] -> Shape +upperPrismPolyTS = upperPrismPoly Tiny Superfluous + +upperPrismPoly :: + -- | height, expected to be strictly positive + Size -> + Importance -> + Float -> + [Point2] -> + Shape +{-# INLINE upperPrismPoly #-} +upperPrismPoly size shad h ps = prismPoly size shad (map (addZ h) ps) (map (addZ 0) ps) + +xCylinderST :: Float -> Float -> Shape +xCylinderST = xCylinder' Small Typical + +xCylinder' :: Size -> Importance -> Float -> Float -> Shape +xCylinder' size shad r x = + translateSHz r . rotateSHq (V3 0 1 0) (pi / 2) . upperCylinder size shad x $ + [ V2 r r + , V2 (- r / 2) (r / 2) + , V2 (- r / 2) (negate $ r / 2) + , V2 r (- r) + ] + +upperBoxMT :: Float -> [Point2] -> Shape +upperBoxMT = upperBox Medium Typical + +upperBoxST :: Float -> [Point2] -> Shape +upperBoxST = upperBox Small Typical + +upperBoxSU :: Float -> [Point2] -> Shape +upperBoxSU = upperBox Small Unimportant + +upperBox :: + -- | height, expected to be strictly positive + Size -> + Importance -> + Float -> + [Point2] -> + Shape +{-# INLINE upperBox #-} +upperBox size shad h ps = prismBox size shad (map (addZ h) ps) (map (addZ 0) ps) rotateSHq :: Point3 -> Float -> Shape -> Shape rotateSHq p = overPosSH . Q.rotate . Q.axisAngle p -upperCylinder - :: Float -- ^ height, expected to be strictly positive - -> [Point2] - -> Shape +upperCylinder :: + -- | height, expected to be strictly positive + Size -> + Importance -> + Float -> + [Point2] -> + Shape {-# INLINE upperCylinder #-} -upperCylinder h ps = [Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) white FullShadowFidelity] +upperCylinder size shad h ps = [Surface (Cylinder n) (addZ (h -0.5) cc : addZ 0.5 cc : f ps) white shad size] where cc = V2 0 0 n = length ps g h' (V2 x y) = V3 x y h' - f (x:xs) = g h x : g 0 x : f xs + f (x : xs) = g h x : g 0 x : f xs f _ = [] -upperRounded - :: Float -- ^ height, expected to be strictly positive - -> [Point2] - -> Shape +upperRounded :: + -- | height, expected to be strictly positive + Size -> + Importance -> + Float -> + [Point2] -> + Shape {-# INLINE upperRounded #-} -upperRounded h ps = [Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) white FullShadowFidelity] +upperRounded size shad h ps = [Surface (RoundedFaces n) (addZ h cc : addZ 0 cc : f ps) white shad size] where cc = centroid ps n = length ps g h' (V2 x y) = V3 x y h' - f (x:xs) = g h x : g 0 x : f xs + f (x : xs) = g h x : g 0 x : f xs f _ = [] -upperPrismPolyHalf - :: Float -- ^ height, expected to be strictly positive - -> [Point2] - -> Shape +upperPrismPolyHalfMI :: Float -> [Point2] -> Shape +upperPrismPolyHalfMI = upperPrismPolyHalf Medium Important + +upperPrismPolyHalfST :: Float -> [Point2] -> Shape +upperPrismPolyHalfST = upperPrismPolyHalf Small Typical + +upperPrismPolyHalf :: + -- | height, expected to be strictly positive + Size -> + Importance -> + Float -> + [Point2] -> + Shape {-# INLINE upperPrismPolyHalf #-} -upperPrismPolyHalf h ps = prismPoly upps downps +upperPrismPolyHalf size shad h ps = prismPoly size shad upps downps + where + upps = map f ps + downps = map g ps + f (V2 x y) = V3 (0.5 * x) (0.5 * y) h + g (V2 x y) = V3 x y 0 + +upperBoxHalf :: + -- | height, expected to be strictly positive + Size -> + Importance -> + Float -> + [Point2] -> + Shape +{-# INLINE upperBoxHalf #-} +upperBoxHalf size shad h ps = prismBox size shad upps downps where upps = map f ps downps = map g ps @@ -157,12 +265,12 @@ rotateSHx = overPosSH . rotate3x scaleSH :: Point3 -> Shape -> Shape {-# INLINE scaleSH #-} -scaleSH (V3 a b c) = overPosSH (\(V3 x y z) -> V3 (x*a) (y*b) (z*c)) +scaleSH (V3 a b c) = overPosSH (\(V3 x y z) -> V3 (x * a) (y * b) (z * c)) overColObj :: (Point4 -> Point4) -> Surface -> Surface {-# INLINE overColObj #-} -overColObj f (Surface st vs col sfid) = Surface st vs (f col) sfid +overColObj f (Surface st vs col sfid size) = Surface st vs (f col) sfid size overPosObj :: (Point3 -> Point3) -> Surface -> Surface {-# INLINE overPosObj #-} -overPosObj f (Surface st vs col sfid) = Surface st (map f vs) col sfid +overPosObj f (Surface st vs col sfid size) = Surface st (map f vs) col sfid size diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index 2a9cdeb15..aa70fe75a 100644 --- a/src/Shape/Data.hs +++ b/src/Shape/Data.hs @@ -25,11 +25,25 @@ data ShadowFidelity = FullShadowFidelity | NoShadowFidelity deriving (Eq, Ord, Show, Read) --Generic, Flat) +data Size = Huge + | Large + | Medium + | Small + | Tiny + deriving (Eq, Ord, Show, Read) --Generic, Flat) +data Importance = Essential + | Important + | Typical + | Unimportant + | Superfluous + deriving (Eq, Ord, Show, Read, Enum, Bounded) --Generic, Flat) + data Surface = Surface { _sfType :: ShapeType , _sfVs :: [Point3] , _sfColor :: Point4 - , _sfShadowFidelity :: ShadowFidelity + , _sfShadowImportance :: Importance + , _sfSize :: Size } deriving (Eq, Ord, Show, Read) --Generic, Flat) @@ -46,4 +60,6 @@ shapeVerxSizes = [4,4,4] deriveJSON defaultOptions ''ShadowFidelity deriveJSON defaultOptions ''ShapeType +deriveJSON defaultOptions ''Size +deriveJSON defaultOptions ''Importance deriveJSON defaultOptions ''Surface