diff --git a/data/texture/ayene_wooden_floor.png b/data/texture/ayene_wooden_floor.png index d8c4ade7c..00d088b3b 100644 Binary files a/data/texture/ayene_wooden_floor.png and b/data/texture/ayene_wooden_floor.png differ diff --git a/src/Data/Tile.hs b/src/Data/Tile.hs index 1d4bb544d..5977c8b01 100644 --- a/src/Data/Tile.hs +++ b/src/Data/Tile.hs @@ -11,4 +11,5 @@ data Tile = Tile , _tileY :: Point2 , _tileZ :: Float } + deriving (Eq, Ord, Show) makeLenses ''Tile diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index be7cfb883..e85638313 100644 --- a/src/Dodge/Default/World.hs +++ b/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 diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 14fabac11..a56739d30 100644 --- a/src/Dodge/Layout.hs +++ b/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 diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 37e81140a..e4ef6ce4c 100644 --- a/src/Dodge/Room.hs +++ b/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) diff --git a/src/Dodge/Room/AddTile.hs b/src/Dodge/Room/AddTile.hs new file mode 100644 index 000000000..57327a767 --- /dev/null +++ b/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 diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index ffb5beb8c..1ef9dc315 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/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 = [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)] - ] + { _rmPolys = [poly] , _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) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 6d974b72d..b813fa2b5 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/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 diff --git a/src/Geometry.hs b/src/Geometry.hs index e23e74fa6..9fba1f4d1 100644 --- a/src/Geometry.hs +++ b/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 - where - cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps +orderPolygon ps = orderPolygonAround (1/ fromIntegral (length ps) *.* foldr1 (+.+) ps) 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 _ = error "Tried to create the convex hull of two or less points" +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 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. diff --git a/src/Tile.hs b/src/Tile.hs index 8c8328220..f6eb90d01 100644 --- a/src/Tile.hs +++ b/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