Add random floor tiles to floors

src/Data/Tile.hs

@@ -11,4 +11,5 @@ data Tile = Tile
     , _tileY :: Point2
     , _tileZ :: Float
     }
+  deriving (Eq, Ord, Show)
 makeLenses ''Tile

src/Dodge/Default/World.hs

@@ -9,7 +9,7 @@ import Dodge.Config.KeyConfig
 import Dodge.Item.Data
 import Picture
 import Geometry
-import Picture.Texture
+--import Picture.Texture
 import Data.Tile
 import Tile
 

src/Dodge/Layout.hs

@@ -9,6 +9,7 @@ import Dodge.Base
 import Dodge.Graph
 import Dodge.Layout.Tree.Polymorphic (applyToRoot)
 import Dodge.Room.Data
+import Dodge.Room.AddTile
 import Dodge.Default.Wall
 import Geometry
 import Dodge.Room.Link
@@ -36,7 +37,9 @@ generateLevelFromRoomList gr w = updateWallZoning
         }
   where
     plmnts = concatMap _rmPS rs
-    rs = evalState gr $ _randGen w
+    rs = zipWith addTile zs rs'
+    zs = map fromIntegral $ randomRs (0,(63::Int)) $ _randGen w
+    rs' = evalState gr $ _randGen w
 
 -- | connects a collection (tree) of rooms together
 generateFromTree :: State StdGen (Tree Room) -> World -> World

src/Dodge/Room.hs

@@ -34,6 +34,7 @@ import Dodge.Room.Airlock
 import Dodge.Room.LongDoor
 import Geometry
 import Picture
+import Tile
 
 import Control.Lens
 import Control.Monad.State
@@ -214,14 +215,15 @@ roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst)
 
 roomOctogon :: Room
 roomOctogon = defaultRoom
-    { _rmPolys = [[(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
+    { _rmPolys = [poly ]
-                 ]
     , _rmLinks = lnks
     , _rmPath  = allPairs $ map fst lnks
     , _rmPS    = []
     , _rmBound = [[(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
+    , _rmFloor = [oTile poly 7]
     }
   where 
+    poly = [(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
     lnks = 
         [((0,140),0)
         ,((35,125),0-pi/4)

src/Dodge/Room/AddTile.hs

@@ -0,0 +1,15 @@
+module Dodge.Room.AddTile
+    where
+import Dodge.Room.Data
+import Tile
+import Geometry
+
+import Control.Lens
+
+addTile :: Float -> Room -> Room
+addTile z r
+    | not (null (_rmFloor r)) || null rp = r
+    | otherwise = r & rmFloor .~ [oTile poly z]
+  where
+    rp = _rmPolys r
+    poly = convexHull $ concat rp

src/Dodge/Room/Corridor.hs

@@ -3,21 +3,20 @@ module Dodge.Room.Corridor
 import Dodge.Room.Data
 import Dodge.Default.Room
 import Geometry
+import Tile
 {- | First exit due north, two other exits at angles next to this.
  Entrance from south.  -}
 corridor :: Room
 corridor = defaultRoom
-    { _rmPolys = [rectNSWE 80 0 0 40
+    { _rmPolys = [poly]
-    --{ _rmPolys = [rectNSWE 90 (-10) 0 40
---                 ,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)]
---                 ,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
-                 ]
     , _rmLinks = lnks
     , _rmPath  = concatMap (doublePair . (,) (20,60) . fst) lnks
     , _rmPS    = []
     , _rmBound = [ rectNSWE 50 30 0 40 ]
+    , _rmFloor = [oTile poly 2]  
     }
   where 
+    poly = rectNSWE 80 0 0 40
     lnks = 
         [((20,70)  ,0)
         ,((20,70), pi/6)

src/Dodge/Room/Procedural.hs

@@ -103,6 +103,7 @@ combineRooms r r' = defaultRoom
     , _rmPath  = _rmPath  r ++ _rmPath  r'
     , _rmPS    = _rmPS    r ++ _rmPS    r'
     , _rmBound = _rmBound r ++ _rmBound r'
+    , _rmFloor = _rmFloor r ++ _rmFloor r'
     }
 --{- The top fourth of a room of a given height.  -}
 --fourth 

src/Geometry.hs

@@ -21,7 +21,7 @@ import Geometry.Intersect
 import Geometry.Bezier
 import Geometry.Vector
 
-import Data.Function
+--import Data.Function
 import Data.List
 import Data.Maybe
 --import Control.Applicative
@@ -143,12 +143,20 @@ isRHS
     a2 = y' - y
     b1 = x'' - x
     b2 = y'' - y
+orderPolygonAround 
+    :: Point2 -- ^ point to order around
+    -> [Point2]
+    -> [Point2]
+orderPolygonAround _ [] = []
+orderPolygonAround cen ps = sortOn (\p -> argV (p -.- cen)) ps
+
+orderAroundFirst :: [Point2] -> [Point2]
+orderAroundFirst [] = []
+orderAroundFirst (a:as) = a : orderPolygonAround a as
 -- | Reorder points to be anticlockwise around their center.
 orderPolygon :: [Point2] -> [Point2]
 orderPolygon [] = []
-orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps
+orderPolygon ps = orderPolygonAround (1/ fromIntegral (length ps) *.* foldr1 (+.+) ps) ps
-  where 
-    cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps
 -- | Adds a point to a convex polygon.
 -- If the point is inside, returns the original.
 -- Points ordered anticlockwise, input not checked.
@@ -158,8 +166,22 @@ addPointPolygon p ps
     | otherwise = orderPolygon $ p : ps
 -- | Creates the convex hull of a set of points.
 convexHull :: [Point2] -> [Point2]
-convexHull (x:y:z:xs) = foldr addPointPolygon (orderPolygon [x,y,z]) xs
+convexHull (x:y:z:xs) = grahamScan $ orderAroundFirst $ sortOn (\(a,b) -> (b,a)) (x:y:z:xs)
-convexHull _ = error "Tried to create the convex hull of two or less points"
+convexHull _ = error "Tried to create the convex hull of two or fewer points"
+
+grahamScan :: [Point2] -> [Point2]
+grahamScan = foldr push []
+  where
+    push point stack = grahamEliminate (point:stack)
+
+-- | Remove second element if top three elements are not counterclockwise.
+-- Repeat if necessary. See 
+-- https://codereview.stackexchange.com/questions/206019/graham-scan-algorithm-in-haskell
+grahamEliminate :: [Point2] -> [Point2]
+grahamEliminate (x:y:z:xs)
+    | isRHS x y z = grahamEliminate (x:z:xs)
+grahamEliminate xs = xs
+
 -- | Return distance between two points.
 dist :: Point2 -> Point2 -> Float
 {-# INLINE dist #-}
@@ -229,7 +251,7 @@ anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
 -- split a list into triples, forms triangles from a polygon
 polyToTris :: [s] -> [s]
 {-# INLINE polyToTris #-}
-polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
+polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (b:c:as) (c:as))
 polyToTris _ = []
 
 -- | Return n equidistant points on a circle with a radius of 600.

src/Tile.hs

@@ -29,3 +29,20 @@ calcTexCoord cen x' y' p =
   where
     x = x' -.- cen
     y = y' -.- cen
+
+oTile
+    :: [Point2]
+    -> Float
+    -> Tile
+oTile poly z = Tile
+    { _tilePoly = poly
+    , _tileCenter = c
+    , _tileX = x
+    , _tileY = y
+    , _tileZ = z
+    }
+  where
+    c = head poly
+    xdir = 50 *.* (normalizeV (poly !! 1 -.- c))
+    x = c +.+ xdir
+    y = c +.+ vNormal xdir