Allow shadow fidelity option, fix bug in rendering box shadows

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

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

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 =
+    | _btState bt == BtOff = flick $ pi / 4
-        flick $ pi / 4
     | otherwise = flick (negate (pi / 4))
   where
     flick a =
         ( mconcat
-            [ colorSH col1 . upperPrismPoly 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10
+            [ colorSH col1 . upperBox Small Typical 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10
-            , colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperPrismPoly 2 $
+            , 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

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
+doTopInvLeftClick :: Creature -> World -> World
-useLeftItem cid w = fromMaybe w $ do
+doTopInvLeftClick cr w = fromMaybe w $ do
-    cr <- w ^? cWorld . lWorld . creatures . ix cid
     guard . not $ _crInvLock cr
-    let mitRef = cr ^? crManipulation . manObject . inInventory . ispItem
+    return $ doTopInvLeftClick' cr w
-        itmIsConsumable = isJust $ do
+
-            itRef <- mitRef
+doTopInvLeftClick' :: Creature -> World -> World
-            cr ^? crInv . ix itRef . itUse . cUse
+doTopInvLeftClick' cr w = fromMaybe (doTopInvLeftClickSearch cr w) $ do
-        itmIsEquipable = isJust $ do
+    invid <- cr ^? crManipulation . manObject . inInventory . ispItem
-            itRef <- mitRef
+    ituse <- cr ^? crInv . ix invid . itUse
-            guard $ cr ^. crLeftInvSel . lisMPos == Just itRef
+    case ituse of
-            cr ^? crInv . ix itRef . itUse . equipEffect . eeUse
+        ConsumeUse{} -> return $ useItem cr w
-    if itmIsConsumable || itmIsEquipable
+        EquipUse{} -> return $ useItem cr w
-        then return $ useItem cr w -- I believe this ONLY sets equipment options
+        LeftUse{} -> return $ equipAndUse (_leftUseOnEquip ituse) invid cr w
-        else do
+        _ -> Nothing
-            invid <- cr ^. crLeftInvSel . lisMPos
+
-            itm <- cr ^? crInv . ix invid
+equipAndUse :: Bool -> Int -> Creature -> World -> World
-            f <- cr ^? crInv . ix invid . itUse . leftUse
+equipAndUse useonequip invid cr w = case cr ^? crInvEquipped . ix invid of
-            return
+    Nothing | useonequip -> tryUseL (_crID cr) invid $ useItem cr w
-                . (runIdentity . pointerToItemLocation (_itLocation itm) (return . (itUse . leftHammer .~ HammerDown)))
+        | otherwise -> useItem cr w
-                . useL f itm cr
+    _ -> tryUseL (_crID cr) invid w
-                $ 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

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
+deadFeet = feet 
-    Just (Walking sa LeftForward) ->
+--cr = case cr ^? crStance . carriage of
-        mconcat
+--    Just (Walking sa LeftForward) ->
-            [ translateSHxy (f sa) off aFoot
+--        mconcat
-            , translateSHxy (- f sa) (- off) aFoot
+--            [ translateSHxy (f sa) off aFoot
-            ]
+--            , translateSHxy (- f sa) (- off) aFoot
-    Just (Walking sa RightForward) ->
+--            ]
-        mconcat
+--    Just (Walking sa RightForward) ->
-            [ translateSHxy (- f sa) off aFoot
+--        mconcat
-            , translateSHxy (f sa) (- off) aFoot
+--            [ translateSHxy (- f sa) off aFoot
-            ]
+--            , translateSHxy (f sa) (- off) aFoot
-    _ ->
+--            ]
-        mconcat
+--    _ ->
-            [ translateSHxy 0 off aFoot
+--        mconcat
-            , translateSHxy 0 (- off) aFoot
+--            [ translateSHxy 0 off aFoot
-            ]
+--            , translateSHxy 0 (- off) aFoot
-  where
+--            ]
-    aFoot :: Shape
+--  where
-    aFoot = upperPrismPoly 3 $ polyCirc 3 4
+--    aFoot :: Shape
-    off = 5
+--    aFoot = upperPrismPolyT 3 $ polyCirc 3 4
-    sLen = _strideLength $ _crStance cr
+--    off = 5
-    f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
+--    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 #-}

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)

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

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

src/Dodge/Default/Item/Use.hs

@@ -18,6 +18,7 @@ defaultLeftUse =
         , _leftHammer = HammerUp
         , _equipEffect = defaultEquip
         , _leftConsumption = defaultLeftLoadable
+        , _leftUseOnEquip = False
         }
 
 defaultEquipUse :: ItemUse

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)
+    INVISIBILITYEQUIPMENT _ -> noPic (colorSH chartreuse $ upperPrismPolySI 3 $ rectWH 2 2)
-    BRAINHAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4)
+    BRAINHAT -> noPic (colorSH yellow $ upperPrismPolySU 3 $ rectWH 4 4)
-    HAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4)
+    HAT -> noPic (colorSH yellow $ upperPrismPolySU 3 $ rectWH 4 4)
-    TARGETINGHAT _ -> noPic (colorSH yellow $ upperPrismPoly 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
+        noPic $ colorSH yellow $ upperPrismPolyMT 10 $ polyCirc 3 5
-    AUTODETECTOR dt -> noPic (colorSH (detectorColor dt) $ upperPrismPoly 3 $ rectWH 2 2)
+    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
+    side = upperPrismPolySE 3 $ rectXH 10 0.5
-    top = upperPrismPoly 0.5 $ rectXH 10 2
+    top = upperPrismPolySE 0.5 $ rectXH 10 2
-    bot = upperPrismPoly 0.5 $ rectXH 9 2
+    bot = upperPrismPolySE 0.5 $ rectXH 9 2
-    back = upperPrismPoly 3 $ rectXH 1 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)
+        xCylinderST 3 x
-            <> upperPrismPoly 6 (reverse $ rectNSWE 4 (-4) x (10 + 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)
+            upperPrismPolyST 5 (rectNESW xb 8 xa 0)
-                <> upperPrismPoly 5 (rectNESW (- xa) 8 (- xb) 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)
+        translateSHxy tx ty (upperPrismPolyST tz $ polyCirc 3 r)
-            <> upperPrismPoly 5 (rectNESW 2 18 (-2) 0)
+            <> 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)
+            upperPrismPolyST 5 (rectNESW xb 8 xa 0)
-                <> upperPrismPoly 5 (rectNESW (- xa) 8 (- xb) 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)
+        upperBoxST 4 (rectNESW 3 30 1 0)
-            <> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0)
+            <> upperBoxSU 4 (rectNESW (-1) 30 (-3) 0)
-            <> upperPrismPoly 1 (rectNESW 3 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)
+        upperBoxST 4 (rectNESW gap 3 (- gap) 1)
-            <> upperPrismPoly 4 (rectNESW gap (-1) (- gap) (-3))
+            <> upperBoxSU 4 (rectNESW gap (-1) (- gap) (-3))
-            <> upperPrismPoly 1 (rectNESW gap 3 (- 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 =
+tractorGunPic = lasGunPic
-    ( 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
 
 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)
+        oneside 5 2 4
-            <> translateSH (V3 5 2 0) (upperPrismPoly 4 $ rectWH 4 1)
+            <> oneside 5 2 0
-            <> translateSH (V3 5 (-2) 4) (upperPrismPoly 4 $ rectWH 4 1)
+            <> oneside 5 (-2) 4
-            <> translateSH (V3 5 (-2) 0) (upperPrismPoly 4 $ rectWH 4 1)
+            <> 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

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

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) ) 

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 col1 . translateSHz 10 . upperBox Small Typical 10 $ reverse $ rectNSWE (-2) (-5) (-10) 10
-        , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperPrismPoly 2 . reverse 
+        , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperBox Small Typical 2 . reverse 
             $ rectNSWE 10 0 (-2) 2
         ]   
         , mempty)

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

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"

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)

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 =

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

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)
+            $ translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous)
-            $ upperPrismPoly (2 * x) $ square x
     skin =
         colorSH (_prColor pr)
-            . translateSH (V3 1 1 (1 - x))
+            $ translateSH (V3 1 1 (1 - x)) baseCube
-            $ upperPrismPoly (2 * x) $ square x
+    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
+                [ aface 1 2 (-1)
-                , translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
+                , aface 1 (-1) 2
-                , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3
+                , aface 2 2 (-1)
-                , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
+                , aface 2 (-1) 2
-                , upperPrismPoly 1 [V2 2 2, V2 (-1) 2, V2 2 (-1)]
+                , 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 Small Essential 5 $ reverse $ rectNSWE 6 5 (-6) 6
-                , upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6
+                , upperPrismPoly Small Essential 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6
-                , upperPrismPoly 1 [V2 0 (-1), V2 6 5, V2 (-6) 5]
+                , upperPrismPoly Small Essential 1 [V2 0 (-1), V2 6 5, V2 (-6) 5]
-                , upperPrismPoly 1 [V2 0 1, V2 (-6) (-5), V2 6 (-5)]
+                , upperPrismPoly Small Essential 1 [V2 0 1, V2 (-6) (-5), V2 6 (-5)]
                 ]
     , mempty
     )

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

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)
     )
 

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

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 ->

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
+pokeShapeObj shadowtest ptr iptr ieptr counts surf@(Surface shtype shVerts col _ _) = case shtype of
-    FlatFaces size -> pokeBox shadfid col size ptr iptr ieptr counts shVerts
+    FlatFaces size -> pokeBox blockshadows col size ptr iptr ieptr counts shVerts
-    RoundedFaces size -> pokeRoundedFaces shadfid col size ptr iptr ieptr counts shVerts
+    RoundedFaces size -> pokeRoundedFaces blockshadows col size ptr iptr ieptr counts shVerts
-    Cylinder size -> pokeCylinder shadfid 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 
+    nei' <- if sfid then return nei
-        NoShadowFidelity -> return nei
+        else UV.foldM' (pokeIndex nv ieptr) nei $
-        FullShadowFidelity -> 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 
+    nei' <- if sfid
-        NoShadowFidelity -> return nei
+        then return nei
-        FullShadowFidelity -> UV.foldM' (pokeIndex nv ieptr) 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 
+    nei' <- if sfid then return nei
-        NoShadowFidelity -> return nei
+        else UV.foldM' (pokeIndex nv ieptr) nei $
-        FullShadowFidelity -> 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 =
+    f i = [ g 0 , g 1 ,n + g 0 , g 2 
-        map
+          , g 0 , n + g 0 , n + g (-1) , g 1
-            g
+          , n + g 0 , n + g 1 , n + g (-1) , g 1
-            [ 0 , 1 , n , 2 
-            , 0 , n , -1 , n + 1
-            , n , n + 1 , n -1 , 1
             ]
       where
-        g j = (i + j) `mod` (2 * n)
+        g j = (i + j) `mod` n
 
 cylinderIndices :: Int -> [Int]
 cylinderIndices n =

src/Shape.hs

@@ -1,36 +1,52 @@
-{-# LANGUAGE BangPatterns  #-}
+{-# LANGUAGE BangPatterns #-}
-module Shape
+
-    ( module Shape.Data
+module Shape (
-    , translateSH
+    module Shape.Data,
-    , upperPrismPoly
+    translateSH,
-    , upperPrismPolyHalf
+    upperPrismPoly,
-    , prismPoly
+    upperPrismPolyMT,
-    , polyCirc
+    upperPrismPolySE,
-    , upperBox
+    upperPrismPolyST,
-    , translateSHz
+    upperPrismPolySI,
-    , translateSHxy
+    upperPrismPolySU,
-    , rotateSH
+    upperPrismPolyTS,
-    , rotateSHx
+    upperBoxMT,
-    , rotateSHq
+    upperBoxST,
-    , polyCircx
+    upperBoxSU,
-    , scaleSH
+    upperBoxHalf,
-    , colorSH
+    upperPrismPolyHalf,
-    , overColSH
+    upperPrismPolyHalfMI,
-    , overPosSH
+    upperPrismPolyHalfST,
-    , upperCylinder
+    xCylinderST,
-    , upperRounded
+    prismPoly,
-    , xCylinder
+    prismBox,
-    , xCylinder'
+    cylinderPoly,
-    ) where
+    polyCirc,
-import Geometry
+    upperBox,
-import Shape.Data
+    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 
+prismPoly ::
-    :: [Point3] 
+    Size ->
-    -> [Point3] 
+    Importance ->
-    -> Shape
+    [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 
+prismBox ::
-    :: Float    -- ^ height, expected to be strictly positive
+    Size ->
-    -> [Point2] 
+    Importance ->
-    -> Shape
+    [Point3] ->
-{-# INLINE upperPrismPoly #-}
+    [Point3] ->
-upperPrismPoly h ps = prismPoly (map (addZ h) ps) (map (addZ 0) ps)
+    Shape
-
+{-# INLINE prismBox #-}
-xCylinder :: Int -> Float -> Float -> Shape
+prismBox size shads upps downps = [Surface (FlatFaces n) (f upps downps) white shads size]
-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]
   where
-    n = length ps
+    n = length upps
-    g h' (V2 x y) = V3 x y h'
+    f (a : as) (b : bs) = a : b : f as bs
-    f (x:xs) = g h x : g 0 x : f xs
+    f _ _ = []
-    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 
+upperCylinder ::
-    :: Float    -- ^ height, expected to be strictly positive
+    -- | height, expected to be strictly positive
-    -> [Point2] 
+    Size ->
-    -> Shape
+    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 
+upperRounded ::
-    :: Float    -- ^ height, expected to be strictly positive
+    -- | height, expected to be strictly positive
-    -> [Point2] 
+    Size ->
-    -> Shape
+    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
+upperPrismPolyHalfMI :: Float -> [Point2] -> Shape
-    :: Float    -- ^ height, expected to be strictly positive
+upperPrismPolyHalfMI = upperPrismPolyHalf Medium Important
-    -> [Point2] 
+
-    -> Shape
+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

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