Cleanup

src/Dodge/Data.hs

@@ -20,7 +20,6 @@ import Dodge.Config.Data
 import Dodge.Config.KeyConfig
 import Dodge.Item.Attachment.Data
 import Dodge.Item.Data
-import Dodge.World.Trigger.Data
 import Dodge.Bounds
 import Data.Preload
 import Picture.Data
@@ -82,7 +81,7 @@ data World = World
     , _storedLevel          :: Maybe World
     , _quicksaveLevel       :: Maybe World
     , _menuLayers           :: [ScreenLayer]
-    , _worldState           :: M.Map WorldState Bool
+--    , _worldState           :: M.Map WorldState Bool
     , _worldTriggers        :: S.Set WorldTrigger
     , _carteDisplay         :: !Bool
     , _carteCenter          :: !Point2
@@ -236,10 +235,9 @@ data CrMvType
         , _mvTurnJit    :: Float
         , _mvAimSpeed   :: Float -> Float
         }
-data WorldState 
+data WorldTrigger
-    = DoorNumOpen Int 
+    = ResetLevel Int
-    | DoorNumOpening Int
+    | GameOver
-    | CrNumAlive Int
   deriving (Eq,Ord)
 data Button = Button 
     { _btPict :: Button -> SPic

src/Dodge/Default/World.hs

@@ -55,7 +55,7 @@ defaultWorld = World
     , _storedLevel = Nothing
     , _quicksaveLevel = Nothing
     , _menuLayers = []
-    , _worldState = M.empty
+--    , _worldState = M.empty
     , _worldTriggers = S.empty
     , _clickMousePos = V2 0 0
     , _pathGraph = Data.Graph.Inductive.Graph.empty

src/Dodge/Floor.hs

@@ -5,40 +5,24 @@ module Dodge.Floor
     ( levx
     ) where
 import Geometry.Data
---import Picture
 import Dodge.Data
---import Dodge.Room
 import Dodge.Creature.State.Data
---import Dodge.Creature.SwarmCrit
 import Dodge.Room.Procedural
 import Dodge.Room.RoadBlock
 import Dodge.Room.Data
 import Dodge.Room
---import Dodge.Room.Link
---import Dodge.Room.Door
 import Dodge.Room.Branch
 import Dodge.Room.Boss
---import Dodge.Room.Airlock
 import Dodge.Room.LongDoor
 import Dodge.Room.NoNeedWeapon
---import Dodge.Base
---import Dodge.Layout
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.Layout.Tree.Either
---import Dodge.Layout.Tree.GenerateStructure
 import Dodge.Layout.Tree.Annotate
 import Dodge.Layout.Tree.Shift
 import Dodge.Creature
---import Dodge.SoundLogic
---import Dodge.RandomHelp
---import Dodge.LightSources
 import Dodge.LevelGen.Data
---import Dodge.LevelGen.SwarmPlacement
---import Dodge.Item.Weapon
 import Dodge.Item.Weapon.Launcher
 
---import Data.Tree
---import Data.Maybe (fromJust,isNothing)
 import Control.Lens
 import Control.Monad.State
 import Control.Monad.Loops
@@ -52,6 +36,9 @@ initialRoomTree = do
             [[StartRoom]
             ,[Corridor]
             ,[Corridor]
+            ,[AirlockAno]
+            ,[Corridor]
+            ,[Corridor]
 ----            ,[SpecificRoom roomCCrits]
 ----            ,[Corridor]
 ----            ,[Corridor]

src/Dodge/Initialisation.hs

@@ -58,7 +58,6 @@ initialWorld = defaultWorld
     , _decorations = IM.empty
     , _storedLevel = Nothing
     , _menuLayers = [TerminalScreen 300 rezText']
-    , _worldState = M.empty
     }
 testStringInit :: World -> [String]
 testStringInit _ = []

src/Dodge/Layout/Tree/Annotate.hs

@@ -46,28 +46,20 @@ addLock i t = do
     (beforeLock, afterLock) <- splitTrunk t
     newBefore <- applyToRandomNode (Key i :) beforeLock
     return $ addToTrunk newBefore [Node [Lock i] afterLock]
-{- |
+{- | Add one corridor between each parent-child link of a tree of annotations.  -}
-Add one corridor between each parent-child link of a tree of annotations.
- -}
 padCorridors :: Tree [Annotation g] -> Tree [Annotation g]
 padCorridors (Node x xs) = Node [Corridor] [Node x (map padCorridors xs)]
-{-
+{- Add one to three corridors between each parent-child link of a tree of annotations.  -}
-Add one to three corridors between each parent-child link of a tree of annotations.
- -}
 randomPadCorridors :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annotation g])
 randomPadCorridors  (Node x xs) = do
     n <- state $ randomR (1, 3)
     xs' <- mapM randomPadCorridors xs
     return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
-{- |
+{- | Add a corridor to a random out-link of a room.  -}
-Add a corridor to a random out-link of a room.
- -}
 roomThenCorridor :: RandomGen g => Room -> State g (Tree (Either Room Room))
 roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r]) 
                                 (randomiseOutLinks corridor)
-{- |
+{- | Create a random room tree structure from a list of annotations.  -}
-Create a random room tree structure from a list of annotations.
- -}
 annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
 annoToRoomTree [OrAno as] = do
     a <- takeOne as
@@ -75,7 +67,7 @@ annoToRoomTree [OrAno as] = do
 annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor
 annoToRoomTree [CorridorDebug] = pure . Right <$> randomiseOutLinks corridorDebug
 annoToRoomTree [DoorAno] = roomThenCorridor door
-annoToRoomTree [DoorNumAno _,AirlockAno] = airlock >>=  roomThenCorridor
+annoToRoomTree [AirlockAno] = airlock >>=  roomThenCorridor
 annoToRoomTree [FirstWeapon] = do
     branchWP <- branchRectWith weaponRoom
     blockedC <- longBlockedCorridor

src/Dodge/Room/Airlock.hs

@@ -1,8 +1,6 @@
 {-# LANGUAGE TupleSections #-}
-{-
+{- Rooms that contain two doors and a switch alternating both.  -}
-Rooms that contain two doors and a switch alternating both.  -}
+module Dodge.Room.Airlock where
-module Dodge.Room.Airlock
-    where
 import Dodge.Room.Data
 import Dodge.LightSources.Fitting
 import Dodge.Room.Placement
@@ -15,49 +13,18 @@ import Dodge.RandomHelp
 import Geometry
 import Picture
 
-import qualified Data.Map.Strict as M
 import qualified Data.IntMap.Strict as IM
 import System.Random
 import Control.Monad.State
-import Control.Lens
+{- | A passage with a switch that opens forward access while closing backwards access. -}
-
-airlockOneWay :: Int -> Room
-airlockOneWay n = defaultRoom
-    { _rmPolys = [rectNSWE 90 0 0 40]
-    , _rmLinks = lnks
-    , _rmPath  = []
-    , _rmPS    = [sPS (V2 0 15) 0 $ PutDoubleDoor col (not . cond) (V2 0 0) (V2 0 40) 2
-                 ,sPS (V2 0 75) 0 $ PutDoubleDoor col cond         (V2 0 0) (V2 0 40) 2
-                 ,sPS (V2 35 45) (pi/2) $ PutButton $ makeButton col (over worldState 
-                                                                 (M.insert (DoorNumOpen n) True))
-                 ]
-    --, _rmBound = rectNSWE 90 30 (-30) 30
-    , _rmBound = [rectNSWE 75 15 0 40]
-    }
-    where lnks = [(V2 0 85,0)
-                 ,(V2 0  5,pi)
-                 ]
-          cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
-          col = dim $ dim $ bright red
-
-{- |
-A passage with a switch that opens forward access while closing backwards access. -}
 airlock :: RandomGen g => State g Room
---airlock = takeOne [airlock0,airlock90,airlockCrystal]
+airlock = takeOne [airlock0,airlock90,airlockCrystal]
-airlock = takeOne [airlock0]
+{- | Straight airlock -}
-
-{- |
-Straight airlock -}
 airlock0 :: Room
 airlock0 = defaultRoom
-    { _rmPolys =
+    { _rmPolys = [ rectNSWE 100 0 0 40 , rectNSWE 65 35 (-40) 20 ]
-        [ rectNSWE 100 0 0 40
-        , rectNSWE 65 35 (-40) 20
-        ]
     , _rmLinks = lnks
-    , _rmPath  = [(V2 20 95,V2 20 45)
+    , _rmPath  = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20  5) ]
-                 ,(V2 20 45,V2 20  5)
-                 ]
     , _rmPS    = 
         [Placement (PS (V2 (-35) 50) (negate $ pi/2) $ PutButton $ makeSwitch col red id id)
             $ \btid -> jspsJ (V2 0 20) 0 (PutDoubleDoor col (not . cond' btid) (V2 1 0) (V2 39 0) 2)
@@ -74,8 +41,7 @@ airlock0 = defaultRoom
     cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
     col = dim $ dim $ bright red
 
-airlock90 
+airlock90 :: Room
-    :: Room
 airlock90 = defaultRoom
     { _rmPolys =
         [ rectNSWE 100 10 10 100

src/Dodge/Room/Foreground.hs

@@ -8,6 +8,7 @@ import Geometry
 --import Geometry.Data
 import Geometry.Vector3D
 import Shape
+import Quaternion
 
 import Data.List
 import Data.Maybe
@@ -133,8 +134,10 @@ robotArm = undefined
 
 pipePP :: Float -> Point3 -> Point3 -> Shape
 pipePP w a b = prismPoly
-    (map ((+.+.+ a) . addZ 0) $ polyCirc 4 w)
+    (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
-    (map ((+.+.+ b) . addZ 0) $ polyCirc 4 w)
+    (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
+  where
+    z1 = b -.-.- a
     
 tankTopPipe :: Shape
 tankTopPipe = colorSH orange $ 

src/Dodge/Room/Furniture.hs

@@ -8,9 +8,10 @@ import Dodge.Default.Wall
 import Geometry
 import Shape
 import Color
+--import Quaternion
 
-roundTankTopRail :: Color -> Float -> Float -> Placement
+roundTank :: Color -> Float -> Float -> Placement
-roundTankTopRail col x y = shiftPlacement (V2 x y,0) $ ps0j 
+roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j 
     (PutForeground $ colorSH col $ 
         upperPrismPoly 31 thecircle
         <> foldMap toprail ( take 8 [0,pi/4..]) 
@@ -47,8 +48,8 @@ tankSquareCross = tankRectCross 20 20
 
 tankRect :: Float -> Float -> Color -> Float -> Float -> Placement
 tankRect w h col x y = shiftPlacement (V2 x y,0) $ ps0j
-    (PutForeground $ colorSH col $
+    (PutForeground $ colorSH col
-        upperPrismPoly 31 therect
+        $ upperPrismPoly 31 therect
         <> foldMap f [(w',-w',h',h'),(w',-w',-h',-h'),(w',w',h',-h'),(-w',-w',h',-h')]
     )
     $ sps0 $ PutWall therect defaultWall {_wlDraw = False, _wlColor = col, _wlRotateTo = False}
@@ -77,7 +78,6 @@ tankRectEmboss w h col x y = shiftPlacement (V2 x y,0) $ ps0j
         [V3 w h 31,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) 31]
         [V3 w' h 31,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) 31]
 
-
 tankSquareEmboss :: Color -> Float -> Float -> Placement
 tankSquareEmboss = tankRectEmboss 20 20
 

src/Dodge/Room/Start.hs

@@ -11,6 +11,7 @@ import Dodge.LevelGen.Data
 import Dodge.LightSources.Fitting
 import Geometry.Data
 import Color
+import Shape
 
 import Data.Tree
 import Control.Monad.State
@@ -27,14 +28,14 @@ startRoom = do
     h <- state $ randomR (200,400)
     let fground = sPS (V2 0 0) 0 $ PutForeground $ 
             girderV 40 20 10 (V2  0    (h/2)) (V2  w    (h/2))
---            <> highPipe 40 (V2  0    (h/2)) (V2  w    (h/2))
---            <> highPipe 60 (V2 (w/3)    0 ) (V2 (w/3)  h   )
     treeFromPost [Left rezBox, Left door] . Right 
         <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) 
             $ roomRectAutoLinks w h & rmPS .~ 
             [ fground
             , mountedLightJ (V2 0 (h/3)) (V3 40 (h/3) 70)
             , tankSquareEmboss4 (dim orange) 50 (h-60)
-            , tankSquareEmboss4 (dim orange) 50 50
+            , tankSquare (dim orange) 50 50
+            , tankSquare (dim orange) 50 120
+            , sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
             ]
             )

src/Dodge/Room/Teleport.hs

@@ -1,15 +1,11 @@
-{- 
+{- Specification of rooms that teleport (between levels).  -}
-Specification of rooms that teleport (between levels).
--}
 module Dodge.Room.Teleport
     where
 import Dodge.Data
-import Dodge.World.Trigger.Data
 import Dodge.Base
 import Dodge.Room.Data
 import Dodge.Room.Procedural
 import Dodge.Room.Placement
---import Dodge.Layout
 import Dodge.LevelGen.Data
 import Geometry
 import Picture
@@ -42,6 +38,6 @@ telRoomLev i = do
         }
     ppFootprint = rectNSEW 20 (-20) 20 (-20)
     levelReset pp w
-        | dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) $ startNewGame w
+        | dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) $ 
+            w & worldTriggers %~ S.insert (ResetLevel i)
         | otherwise = w
-    startNewGame w = w & worldTriggers %~ S.insert (ResetLevel i)

src/Dodge/Update.hs

@@ -9,14 +9,11 @@ import Dodge.Data
 import Dodge.Menu
 import Dodge.Zone.Data
 import Dodge.Config.Data
-import Dodge.World.Trigger.Data
---import Dodge.Config.Data
 import Dodge.Base
 import Dodge.Zone
 import Dodge.WallCreatureCollisions
 import Dodge.LevelGen.Block
 import Dodge.Update.Camera
---import Dodge.Update.UsingInput
 import Dodge.SoundLogic
 import Dodge.Inventory
 import Dodge.Initialisation
@@ -252,7 +249,7 @@ crCrSpring c1 c2 w
 
 ifConfigWallRotate :: World -> World
 ifConfigWallRotate w
-    | (_rotate_to_wall $ _config w ) && not (ButtonRight `S.member` _mouseButtons w)
+    | _rotate_to_wall (_config w) && not (ButtonRight `S.member` _mouseButtons w)
         = rotateToOverlappingWall w
     | otherwise = w
 

src/Dodge/World/Trigger/Data.hs

@@ -1,12 +1,5 @@
-{- |
+{- | World triggers are intended to help me handle global events, 
-World triggers are intended to help me handle global events, 
 such as new levels, game overs, etc, that disrupt the typical flow of the game.
-They should probably be used sparingly.
+They should probably be used sparingly.  -}
- -}
+module Dodge.World.Trigger.Data where
-module Dodge.World.Trigger.Data
-    where
 
-data WorldTrigger
-    = ResetLevel Int
-    | GameOver
-  deriving (Eq,Ord)

src/Geometry/Vector3D.hs

@@ -38,6 +38,7 @@ a *.*.* (V3 x2 y2 z2) =
   in V3 x y z
 
 crossProd :: Point3 -> Point3 -> Point3
+{-# INLINE crossProd #-}
 crossProd (V3 x y z) (V3 a b c) = V3
     ( y * c - z * b)
     ( z * a - x * c)
@@ -109,18 +110,16 @@ orderAround3 v ps = sortOn (argV . prj) ps
 vCen3 :: [Point3] -> Point3
 vCen3 ps = (1 / fromIntegral (length ps)) *.*.* foldr (+.+.+) (V3 0 0 0) ps 
 
-dotV3
+dotV3 :: Point3 -> Point3 -> Float
-    :: Point3
-    -> Point3
-    -> Float
 dotV3 (V3 x y z) (V3 a b c) = x*a + y*b + z*c
 
-projV3
+angleVV3 :: Point3 -> Point3 -> Float
-    :: Point3
+angleVV3 a b 
-    -> Point3
+    | a == b = 0
-    -> Point3
+    | otherwise = acos $ dotV3 a b / (magV3 a * magV3 b)
-projV3 = undefined
 
+projV3 :: Point3 -> Point3 -> Point3
+projV3 = undefined
 
 onXY :: (Point2 -> Point2) -> Point3 -> Point3
 onXY f (V3 x y z) = V3 x' y' z

src/Quaternion.hs

@@ -0,0 +1,13 @@
+module Quaternion
+    where
+import Geometry.Data
+import Geometry.Vector3D
+import qualified Linear.Quaternion as Q
+
+-- apply a rotation as if the z axis moves to the new point.
+rotateToZ :: Point3 -> Point3 -> Point3
+rotateToZ z1
+    | cprod == V3 0 0 0 = id
+    | otherwise = Q.rotate $ Q.axisAngle cprod (angleVV3 z1 (V3 0 0 1))
+  where
+    cprod = crossProd z1 (V3 0 0 1)

src/Shape.hs

@@ -14,6 +14,7 @@ module Shape
     , polyCircx
     , scaleSH
     , colorSH
+    , overPosSH
     )
   where
 import Geometry
@@ -111,6 +112,10 @@ rotateSH :: Float -> Shape -> Shape
 {-# INLINE rotateSH #-}
 rotateSH a = overPos (rotate3 a)
 
+overPosSH :: (Point3 -> Point3) -> Shape -> Shape
+{-# INLINEABLE overPosSH #-}
+overPosSH = overPos
+
 rotateSHx :: Float -> Shape -> Shape
 {-# INLINE rotateSHx #-}
 rotateSHx a = overPos (rotate3x a)