Make buttons have shape, expose multiple bugs

src/Dodge/Data.hs

@@ -240,7 +240,7 @@ data WorldState
     | CrNumAlive Int
   deriving (Eq,Ord)
 data Button = Button 
-    { _btPict :: Picture
+    { _btPict :: Button -> SPic
     , _btPos :: Point2
     , _btRot :: Float
     , _btEvent :: Button -> World -> World

src/Dodge/Default.hs

@@ -19,7 +19,7 @@ import Dodge.SoundLogic.LoadSound
 import Dodge.Picture.Layer
 import Geometry
 import Picture
---import ShapePicture
+import ShapePicture
 import Shape
 
 import Control.Lens
@@ -208,14 +208,22 @@ defaultIt = Consumable
     , _itHammer = HammerUp
     , _itAimStance = LeaveHolstered
     }
+defaultDrawButton :: Color -> Button -> SPic
+defaultDrawButton col bt
+    | _btState bt == BtOff = 
+        ( translateSHz 15 . colorSH col $ upperPrismPoly 5 $ rectNSEW 5 (-5) 10 (-10)
+        , mempty
+        )
+    | otherwise = 
+        ( translateSHz 15 . colorSH red $ upperPrismPoly 5 $ rectNSEW (-3) (-5) 10 (-10)
+        , mempty
+        )
 defaultButton :: Button
 defaultButton = Button
-    { _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10)
+    { _btPict = defaultDrawButton (dark red)
     , _btPos = V2 0 0
     , _btRot = 0
-    , _btEvent = \b w -> 
+    , _btEvent = \b w -> set (buttons . ix (_btID b) . btState) BtNoLabel
-        set (buttons . ix (_btID b) . btPict) (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10))
-        . set (buttons . ix (_btID b) . btState) BtNoLabel
         . soundStart (LeverSound 0) (_btPos b) click1S Nothing $ w
     , _btID = 0
     , _btText = "Button"

src/Dodge/Floor.hs

@@ -52,24 +52,24 @@ initialRoomTree = do
             [[StartRoom]
             ,[Corridor]
             ,[Corridor]
-            ,[SpecificRoom roomCCrits]
+----            ,[SpecificRoom roomCCrits]
-            ,[Corridor]
+----            ,[Corridor]
-            ,[Corridor]
+----            ,[Corridor]
-            ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
+----            ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
-                & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit 
+----                & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit 
-                            ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit 
+----                            ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit 
-                            ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit 
+----                            ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit 
-                            ]++)
+----                            ]++)
-             ]
+----             ]
-            --,[Corridor]
+----            --,[Corridor]
-            --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
+----            --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
-            --    & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
+----            --    & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
-            -- ]
+----            -- ]
-            ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
+----            ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 
-                & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
+----                & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
-             ]
+----             ]
-            ,[Corridor]
+----            ,[Corridor]
-            ,[Corridor]
+----            ,[Corridor]
 --            --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30]
             ,[SpecificRoom $ pure $ (pure . Right) (twinSlowDoorRoom 30 80 200 40)]
             ,[Corridor]

src/Dodge/GameRoom.hs

@@ -7,6 +7,7 @@ import Geometry
 
 data GameRoom = GameRoom
     { _grViewpoints :: [Point2]
+    , _grViewpointsEx :: [Point2]
     , _grBound :: [Point2]
     , _grDir :: Float   -- ^ gives direction of room
     , _grName :: String

src/Dodge/Layout.hs

@@ -138,7 +138,7 @@ gameRoomsFromRooms = map f
   where
     f rm = GameRoom
         { _grViewpoints = (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
-            ++ map fst (_rmLinks rm)
+        , _grViewpointsEx = map fst (_rmLinks rm)
         , _grBound = expandPolyByFixed 100 $ orderPolygon $ convexHullSafe $ concat $ _rmBound rm ++ _rmPolys rm
         , _grDir   = snd . last $ _rmLinks rm
         , _grName  = _rmName rm

src/Dodge/LevelGen/Switch.hs

@@ -1,11 +1,13 @@
 module Dodge.LevelGen.Switch
     where
 import Dodge.Data
+import Dodge.Default
 import Dodge.Data.SoundOrigin
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
-import Dodge.Picture.Layer
 import Picture
+import ShapePicture
+import Shape
 import Geometry
 --import Geometry.Data
 
@@ -15,8 +17,8 @@ makeButton
     :: Color 
     -> (World -> World) -- ^ Effect when pressed
     -> Button
-makeButton c eff = Button
+makeButton col eff = Button
-    { _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
+    { _btPict = defaultDrawButton col
     , _btPos = V2 0 0
     , _btRot = 0
     , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
@@ -27,17 +29,28 @@ makeButton c eff = Button
     , _btState = BtOff
     }
   where
-    turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = const id}
+    turnOn bt = bt {_btState = BtNoLabel, _btEvent = const id}
-    onPict = setLayer 0 $ onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
     btpos b w' = _btPos $ _buttons w' IM.! _btID b
 
+drawSwitch :: Color -> Color -> Button -> SPic
+drawSwitch col1 col2 bt
+    | _btState bt == BtOff = flick $ pi/4
+    | otherwise = flick (negate (pi/4))
+  where
+    flick a = ( mconcat
+        [ colorSH col1 . translateSHz 10 . upperPrismPoly 10 $ rectNSEW (-2) (-5) 10 (-10)
+        , colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperPrismPoly 2 $ rectNSEW 10 (0) 2 (-2)
+        ]   
+        , mempty)
+
 makeSwitch 
     :: Color
+    -> Color
     -> (World -> World) -- ^ Switch on effect
     -> (World -> World) -- ^ Switch off effect
     -> Button
-makeSwitch c effOn effOff = Button
+makeSwitch col1 col2 effOn effOff = Button
-    { _btPict = offPict
+    { _btPict = drawSwitch col1 col2
     , _btPos = V2 0 0
     , _btRot = 0
     , _btEvent = flipSwitch
@@ -52,24 +65,14 @@ makeSwitch c effOn effOff = Button
         BtOff -> effOn  . over buttons (IM.adjust turnOn  (_btID b))
         BtOn  -> effOff . over buttons (IM.adjust turnOff (_btID b))
         _ -> error "Trying to switch a button with no label"
-    offPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
-                              polygon $ rectNSEW (-2) (-5) (-10) 10
-                              ,polygon $ map toV2 [(-2,-5),(-10,4),(-6,4),(2,-5)]
-                             ]
-    onPict  = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
-                              polygon $ rectNSEW (-2) (-5) (-10) 10
-                              ,polygon $ map toV2 [(-2,-5), (6,4),( 10,4),(2,-5)]
-                             ]
     turnOn :: Button -> Button
     turnOn bt = bt 
         { _btState = BtOn
-        , _btPict = onPict
         , _btText = "SWITCH\\"
         }
     turnOff :: Button -> Button
     turnOff bt = bt 
         { _btState = BtOff
-        , _btPict = offPict
         , _btText = "SWITCH/"
         }
 

src/Dodge/LevelGen/TriggerDoor.hs

@@ -52,7 +52,7 @@ addSwitchDoor c btp btr a b speed w = over buttons (IM.insert bid bt)
   where 
     bid = IM.newKey $ _buttons w
     cond w' = BtOn == _btState (_buttons w' IM.! bid)
-    bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
+    bt = (makeSwitch c red openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
     (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) 
                                              $ _pathGraphP w
     newGraph = pairsToGraph dist newGraphPairs

src/Dodge/LightSources.hs

@@ -5,6 +5,8 @@ module Dodge.LightSources
     , colorLightAt
     , lampPic
     , lampCover
+    , doubleLampCover
+    , verticalLampCover
     )
     where
 import Dodge.Data
@@ -72,22 +74,72 @@ lampCover h = ShapeProp
     { _pjPos = V2 0 0
     , _pjID  = 0
     , _pjRot = 0
-    , _pjUpdate = updateLampCover
+    , _pjUpdate = rotateProp 0.15
     , _prDraw = drawLampCover h
     }
 
-updateLampCover :: Prop -> World -> World
+doubleLampCover :: Float -> Prop
-updateLampCover pr w = w
+doubleLampCover h = ShapeProp
-    & props . ix (_pjID pr) . pjRot +~ 0.15
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = rotateProp 0.15
+    , _prDraw = drawDoubleLampCover h
+    }
+
+-- on the current (27/9/21) version of shadow stencilling, this glitches
+-- slightly when the shadow rotates towards the screen
+verticalLampCover :: Float -> Prop
+verticalLampCover h = ShapeProp
+    { _pjPos = V2 0 0
+    , _pjID  = 0
+    , _pjRot = 0
+    , _pjUpdate = rotateProp 0.15
+    , _prDraw = drawVerticalLampCover h
+    }
+
+rotateProp :: Float -> Prop -> World -> World
+rotateProp rotAmount pr w = w
+    & props . ix (_pjID pr) . pjRot +~ rotAmount
 
 drawLampCover :: Float -> Prop -> SPic
 drawLampCover h pr =
     ( translateSHz (h-2.5) . uncurryV translateSHf pos 
         $ rotateSH a $ mconcat
-        [ upperPrismPoly 5 $ rectNSEW 6 5    6 (-4)
+        [ translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
-        , upperPrismPoly 5 $ rectNSEW 6 (-4) 6 5
+        , translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
+        , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
+        , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
         --, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
-        , upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
+        , upperPrismPoly 1 $ [V2 2 2,V2 (-1) 2,V2 2 (-1)]
+        ]
+    , mempty
+    )
+  where
+    a = _pjRot pr
+    pos = _pjPos pr
+
+drawDoubleLampCover :: Float -> Prop -> SPic
+drawDoubleLampCover h pr =
+    ( translateSHz (h-2.5) . uncurryV translateSHf pos 
+        $ rotateSH a $ mconcat
+        [ upperPrismPoly 5 $ rectNSEW 6 5       6 (-6)
+        , upperPrismPoly 5 $ rectNSEW (-5) (-6) 6 (-6)
+        , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
+        , upperPrismPoly 1 [V2 0 (1),V2 (-6) (-5),V2 6 (-5)]
+        ]
+    , mempty
+    )
+  where
+    a = _pjRot pr
+    pos = _pjPos pr
+
+drawVerticalLampCover :: Float -> Prop -> SPic
+drawVerticalLampCover h pr =
+    ( translateSHz h . uncurryV translateSHf pos 
+        $ rotateSHx a $ mconcat
+        [ 
+        translateSHz (-3) . upperPrismPoly 1 $ rectNSEW 2 (-2) 5 (-5)
         ]
     , mempty
     )

src/Dodge/Render/Picture.hs

@@ -93,7 +93,7 @@ crDraw w c = _spPicture $ _crPict c c w
 ppDraw :: PressPlate -> Picture
 ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
 btDraw :: Button -> Picture
-btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_btPict c)
+btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_spPicture $ _btPict c c)
 
 clDraw :: Cloud -> Picture
 clDraw c = translate3 (_clPos c) (_clPict c c)

src/Dodge/Render/Shape.hs

@@ -15,10 +15,14 @@ worldShape w = _foregroundShape w
     <> foldMap (crShape w) (IM.filter (pointIsClose . _crPos) (_creatures w))
     <> foldMap (_spShape . floorItemSPic) (IM.filter (pointIsClose . _flItPos) $ _floorItems w)
     <> foldMap (_spShape . dbArg _prDraw) (IM.filter (pointIsClose . _pjPos) $ _props w)
+    <> foldMap btShape (IM.filter (pointIsClose . _btPos) $ _buttons w)
   where
     pointIsClose p = dist camCen p < winSize
     winSize = 30 + max (getWindowX w) (getWindowY w)
     camCen = _cameraCenter w
 
+btShape :: Button -> Shape
+btShape bt = uncurryV translateSHf (_btPos bt) $ rotateSH (_btRot bt) (_spShape $ _btPict bt bt)
+
 crShape :: World -> Creature -> Shape
 crShape w c = _spShape $ _crPict c c w

src/Dodge/Room/Airlock.hs

@@ -62,7 +62,7 @@ airlock0 n = defaultRoom
     , _rmPS    = 
         [sPS (V2 0 20) 0 $ PutDoubleDoor col (not . cond) (V2 1 0) (V2 39 0) 2
         ,sPS (V2 0 80) 0 $ PutDoubleDoor col cond         (V2 1 0) (V2 39 0) 2
-        ,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col 
+        ,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col red
                            (over worldState (M.insert (DoorNumOpen n) True))
                            (over worldState (M.insert (DoorNumOpen n) False))
         ,sPS (V2 (-25) 50) 0 putLamp
@@ -100,7 +100,7 @@ airlock90 n = defaultRoom
          ]
     , _rmPS    = 
         [sPS (V2 5 5) 0 $ PutDoor col (not . cond) pss
-        ,sPS (V2 120 120) (3* pi/4) $ PutButton $ makeSwitch col 
+        ,sPS (V2 120 120) (3* pi/4) $ PutButton $ makeSwitch col red
             (over worldState (M.insert (DoorNumOpen n) True))
             (over worldState (M.insert (DoorNumOpen n) False))
         ,sPS (V2 60  60) 0 putLamp
@@ -140,7 +140,7 @@ airlockCrystal n = defaultRoom
          ]
     , _rmPS    = 
         [sPS (V2 0 0) 0 $ PutDoor col (not . cond) pss
-        ,sPS (V2 145 70) (pi/2) $ PutButton $ makeSwitch col 
+        ,sPS (V2 145 70) (pi/2) $ PutButton $ makeSwitch col red
             (over worldState (M.insert (DoorNumOpen n) True))
             (over worldState (M.insert (DoorNumOpen n) False))
         ,crystalLine (V2 0 70) (V2 40 70)

src/Dodge/Room/Corridor.hs

@@ -17,8 +17,8 @@ corridor = defaultRoom
     , _rmLinks = lnks
     , _rmPath  = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
     , _rmPS    = 
-        [-- sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50)
+        [sPS (V2 20 40) 0 $ PutLS (lightAt (V3 0 0 50) 0) (lampPic 50)
-         sPS (V2 0 0)   0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40)
+        ,sPS (V2 0 0)   0 $ PutForeground $ highPipe 55 (V2 0 40) (V2 40 40)
         ]
     , _rmBound = [ rectNSWE 50 30 0 40 ]
     , _rmFloor = [makeTileFromPoly poly 2]  

src/Dodge/Room/LongDoor.hs

@@ -15,6 +15,7 @@ import Dodge.LevelGen.Switch
 import Dodge.RandomHelp
 import Dodge.Creature.Inanimate
 import Dodge.Creature
+import Dodge.LightSources
 import Picture
 import Geometry
 
@@ -44,14 +45,17 @@ twinSlowDoorRoom drID w h x = defaultRoom
         , sPS (V2 (negate 25) 5) 0 putLamp
         , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2   x  1) (V2   x  h) 1
         , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1
-        , sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col 
+        , sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col red
             (over worldState (M.insert (DoorNumOpen drID) True))
             (over worldState (M.insert (DoorNumOpen drID) False))
+--        , sPS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
+--        , sPS (V2 0 (h-1)) 0 $ PutProp $ lampCover lampHeight
         ]
     , _rmBound  = ps
     , _rmName   = "twinSlowDoorRoom"
     }
   where
+    lampHeight = 41
     ps = 
         [rectNSWE h    0 (-w) w
         ,rectNSWE 20 (-h) (negate x) x

src/Dodge/Room/Procedural.hs

@@ -246,7 +246,7 @@ centerVaultRoom n w h d = do
     col = dim $ dim $ bright red
     theDoor i = 
         [ sPS (V2 0  (d-10)) 0 $ PutDoubleDoor col (cond i) (V2 (-19) 0) (V2 19 0) 2
-        , sPS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col 
+        , sPS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col red
                            (over worldState (M.insert (DoorNumOpen i) True))
                            (over worldState (M.insert (DoorNumOpen i) False))
         ]

src/Dodge/Room/Start.hs

@@ -8,7 +8,7 @@ import Dodge.Room.Placement
 import Dodge.Room.Foreground
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.LevelGen.Data
-import Dodge.LightSources
+--import Dodge.LightSources
 --import Picture
 import Geometry.Data
 
@@ -33,13 +33,10 @@ startRoom = do
         <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) 
                 $ roomRectAutoLinks w h & rmPS .~ 
             [ fground
-            --, theLamp
+            , theLamp
-            , sPS (V2 100 100) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
+            --, sPS (V2 100 100) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0) (lampPic lampHeight)
-            , sPS (V2 100 100) 0 $ PutProp $ lampCover lampHeight
+            --, sPS (V2 100 100) 0 $ PutProp $ lampCover lampHeight
             ]
             )
   where
-    lampHeight = 41
+    --lampHeight = 41
---  where
---    cola = dark . dark . light . light $ light red
---    colb = dark . dark . light . light $ light blue

src/Dodge/Update/Camera.hs

@@ -147,7 +147,7 @@ autoZoomCam :: World -> World
 autoZoomCam w = over cameraZoom changeZoom w
   where 
     camPos = _cameraViewFrom w
-    wallZoom = farWallDist' camPos w
+    wallZoom = farWallDist camPos w
     idealZoom 
         | SDL.ButtonRight `S.member` _mouseButtons w 
             = theScopeZoom * maybe zoomNoItem zoomFromItem (yourItem w ^? itAimZoom) wallZoom
@@ -162,14 +162,17 @@ autoZoomCam w = over cameraZoom changeZoom w
     zoomOutSpeed = 15
     theScopeZoom = fromMaybe 1 $ yourItem w ^? itAttachment . scopeZoom
 
-farWallDist' :: Point2 -> World -> Float
+farWallDist :: Point2 -> World -> Float
-farWallDist' p w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
+farWallDist p w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
   where
     findMax curMax pout = max curMax $ dist p $ collidePointUpToIndirectMinDist p pout curMax wos
     hw = halfWidth w
     hh = halfHeight w
     winFac = min hw hh
-    vps = concatMap _grViewpoints grs
+    vps = concatMap _grViewpoints grs ++ linkvps
+    linkvps = map extend (concatMap _grViewpointsEx grs)
+    extend :: Point2 -> Point2
+    extend outp = p +.+ maxViewDistance *.* safeNormalizeV (outp -.- p)
     grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
     wos = wallsOnScreen w
 

src/Geometry/Vector3D.hs

@@ -49,6 +49,12 @@ rotate3 a (V3 x y z) = V3 x' y' z
   where 
     (V2 x' y') = rotateV a (V2 x y)
 
+rotate3x :: Float -> Point3 -> Point3
+{-# INLINE rotate3x #-}
+rotate3x a (V3 x y z) = V3 x y' z'
+  where 
+    (V2 y' z') = rotateV a (V2 y z)
+
 magV3 :: Point3 -> Float
 {-# INLINE magV3 #-}
 magV3 (V3 x y z) = sqrt $ x^i + y^i + z^i

src/Shader/Poke.hs

@@ -159,11 +159,14 @@ topPrismEdgeIndices n = concatMap f [0..n-1]
 
 topPrismIndices :: Int -> [Int]
 topPrismIndices n = concatMap f [1..n-2]    -- triangles on top face
+    ++  concatMap f' [1..n-2]   -- triangles on bottom face
+                                -- these should be checked
     ++ [2*n-2,2*n-1,1
         ,2*n-2,1,0]                         -- last side triangle (applies mod 2n)
     ++ concatMap g [0..n-2]                 -- other triangles on sides
   where
     f x = [0,2*x,2*x+2]
+    f' x = [1,2*x+1,2*x+3]
     g x = [2*x,2*x+1,2*x+3
             ,2*x,2*x+3,2*x+2]
 

src/Shape.hs

@@ -10,6 +10,7 @@ module Shape
     , translateSHz
     , translateSHf
     , rotateSH
+    , rotateSHx
     , scaleSH
     , colorSH
     )
@@ -104,6 +105,10 @@ rotateSH :: Float -> Shape -> Shape
 {-# INLINE rotateSH #-}
 rotateSH a = overPos (rotate3 a)
 
+rotateSHx :: Float -> Shape -> Shape
+{-# INLINE rotateSHx #-}
+rotateSHx a = overPos (rotate3x a)
+
 scaleSH :: Point3 -> Shape -> Shape
 {-# INLINE scaleSH #-}
 scaleSH (V3 a b c) = overPos (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))