Cleanup
This commit is contained in:
+55
-64
@@ -6,8 +6,7 @@ Consider splitting. -}
|
||||
module Dodge.Base
|
||||
( module Dodge.Base
|
||||
, module Dodge.Base.You
|
||||
)
|
||||
where
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.WinScale
|
||||
import Dodge.Zone
|
||||
@@ -34,9 +33,8 @@ import Data.Maybe
|
||||
takeUntil :: Foldable t => (a -> Bool) -> t a -> [a]
|
||||
takeUntil p = foldr (\x xs -> x : if p x then [] else xs) []
|
||||
|
||||
|
||||
decreaseToZero :: Int -> Int
|
||||
decreaseToZero x = max 0 (x - 1)
|
||||
decreaseToZero = max 0 . subtract 1
|
||||
|
||||
decreaseToNothing' :: (Num a, Ord a) => Maybe' a -> Maybe' a
|
||||
decreaseToNothing' ma = case ma of
|
||||
@@ -54,7 +52,6 @@ errorHead s [] = error s
|
||||
aCrPos :: Int -> World -> Point2
|
||||
aCrPos i w = _crPos $ _creatures w IM.! i
|
||||
|
||||
|
||||
selectedObject :: World -> Maybe (Either FloorItem Button)
|
||||
selectedObject w = lookup (_crInvSel ycr) $ zip [n..] $ _closeObjects w
|
||||
where
|
||||
@@ -75,15 +72,16 @@ yourItemRef
|
||||
yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))
|
||||
|
||||
wallNormal :: Wall -> Point2
|
||||
wallNormal wl = normalizeV . vNormal $ a -.- b
|
||||
where
|
||||
(a,b) = _wlLine wl
|
||||
wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine
|
||||
|
||||
wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
|
||||
wallsOnLine p1 p2 ws = hitWalls
|
||||
where
|
||||
hitPoint = uncurry (intersectSegSeg p1 p2) . _wlLine
|
||||
hitWalls = filter (isJust . hitPoint) (IM.elems ws)
|
||||
wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
wallsOnLine p1 p2 = IM.filter
|
||||
(isJust . uncurry (intersectSegSeg p1 p2) . _wlLine)
|
||||
|
||||
wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
|
||||
wallsOnLineHit p1 p2 = IM.mapMaybe f
|
||||
where
|
||||
f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
|
||||
|
||||
wallsOnLine3D :: Point3 -> Point3 -> IM.IntMap Wall -> [Wall]
|
||||
wallsOnLine3D = undefined
|
||||
@@ -97,10 +95,11 @@ wallsOnCirc p r = IM.filter f
|
||||
f wl = uncurry circOnSeg (_wlLine wl) p r
|
||||
|
||||
allWalls :: World -> IM.IntMap Wall
|
||||
allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _znObjects $ _wallsZone w
|
||||
allWalls = IM.unions . concatMap IM.elems . IM.elems . _znObjects . _wallsZone
|
||||
|
||||
creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature
|
||||
creaturesNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
|
||||
creaturesNearPoint p w = IM.unions
|
||||
[f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
|
||||
where
|
||||
(x,y) = crZoneOfPoint p
|
||||
f i m = case IM.lookup i m of
|
||||
@@ -108,7 +107,8 @@ creaturesNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _creaturesZone w |
|
||||
_ -> IM.empty
|
||||
|
||||
creaturesNearPointI :: Int -> Point2 -> World -> IM.IntMap Creature
|
||||
creaturesNearPointI n p w = IM.unions [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]]
|
||||
creaturesNearPointI n p w = IM.unions
|
||||
[f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]]
|
||||
where
|
||||
(x,y) = crZoneOfPoint p
|
||||
f i m = case IM.lookup i m of
|
||||
@@ -120,11 +120,14 @@ creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
|
||||
--creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b]
|
||||
-- where f i m = case IM.lookup i m of Just val -> val
|
||||
-- _ -> IM.empty
|
||||
creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty kps
|
||||
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s))
|
||||
kps = zoneOfLineIntMap a b
|
||||
f i m = case IM.lookup i m of Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty (zoneOfLineIntMap a b)
|
||||
where
|
||||
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s))
|
||||
f i = fromMaybe IM.empty . IM.lookup i
|
||||
-- f i m = case IM.lookup i m of Just val -> val
|
||||
-- _ -> IM.empty
|
||||
|
||||
{- | Expands a line out to a given thickness. -}
|
||||
lineGeom :: Float -> Point2 -> Point2 -> [Point2]
|
||||
lineGeom t x y
|
||||
@@ -191,13 +194,6 @@ newProjectileKey = IM.newKey . _props
|
||||
{- | Finds unused creature key. -}
|
||||
newCrKey :: World -> Int
|
||||
newCrKey = IM.newKey . _creatures
|
||||
-- | collides a point with forcefields
|
||||
-- if found, returns point of collision, deflection if required, and the id
|
||||
collidePointFFs :: a
|
||||
collidePointFFs = undefined
|
||||
collidePointFF :: a
|
||||
collidePointFF = undefined
|
||||
--
|
||||
-- | Looks for overlap of a circle with walls.
|
||||
-- If found, gives wall
|
||||
overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall
|
||||
@@ -249,9 +245,9 @@ collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Lef
|
||||
-- | Looks for first collision of a circle with walls.
|
||||
-- If found, gives point and reflection velocity, reflection damped in normal.
|
||||
collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
collideCircWalls p1 p2 rad ws
|
||||
collideCircWalls p1 p2 rad
|
||||
= safeMinimumOn (dist p1 . fst)
|
||||
$ IM.mapMaybe
|
||||
. IM.mapMaybe
|
||||
(( \(x:y:_) -> fmap
|
||||
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
|
||||
. (+.+ normalizeV (vNormal (x -.- y)))
|
||||
@@ -259,7 +255,7 @@ collideCircWalls p1 p2 rad ws
|
||||
(intersectSegSeg p1 p2 x y)
|
||||
)
|
||||
. shiftByRad . _wlLine
|
||||
) ws
|
||||
)
|
||||
where
|
||||
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
|
||||
[a +.+ rad *.* normalizeV (a -.-b)
|
||||
@@ -284,22 +280,17 @@ collideCircWalls p1 p2 rad ws
|
||||
-- | Looks for first collision of a point with walls.
|
||||
-- If found, gives point and wall.
|
||||
collidePointWallsWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Wall)
|
||||
collidePointWallsWall p1 p2 ws
|
||||
= safeMinimumOn f
|
||||
$ IM.mapMaybe ( \wl -> uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> ( , wl ) )
|
||||
ws
|
||||
where
|
||||
f (a,_) = magV (p1 -.- a)
|
||||
collidePointWallsWall p1 p2
|
||||
= safeMinimumOn (dist p1 . fst)
|
||||
. IM.mapMaybe ( \wl -> uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> ( , wl ) )
|
||||
|
||||
-- | Looks for first collision of a point with walls.
|
||||
-- If found, gives point and normal of wall.
|
||||
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
|
||||
collidePointWallsNorm p1 p2 ws
|
||||
= safeMinimumOn f
|
||||
= safeMinimumOn (dist p1 . fst)
|
||||
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
|
||||
. _wlLine) ws
|
||||
where
|
||||
f (a,_) = magV (p1 -.- a)
|
||||
-- | Returns the first creature, if any, that a point intersects with.
|
||||
collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
|
||||
collidePointCreatures p1 p2 = fmap fst
|
||||
@@ -339,53 +330,53 @@ collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
|
||||
{- | Test if a circle collides with any wall.
|
||||
- Note no check on whether the wall is walkable. -}
|
||||
circOnSomeWall :: Point2 -> Float -> World -> Bool
|
||||
circOnSomeWall p rad w
|
||||
circOnSomeWall p rad
|
||||
= any (\(x,y) -> circOnSeg x y p rad)
|
||||
. fmap _wlLine
|
||||
. IM.elems
|
||||
$ wallsNearPoint p w
|
||||
. wallsNearPoint p
|
||||
{- | Test whether there is a creature of weight 4 or greater near a line. -}
|
||||
isHeavyCrNearLine
|
||||
:: Float
|
||||
-> [Point2]
|
||||
-> World
|
||||
-> Bool
|
||||
isHeavyCrNearLine d (p1:p2:_) w
|
||||
isHeavyCrNearLine d (p1:p2:_)
|
||||
= any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c))
|
||||
. IM.filter (\cr -> _crMass cr > 4)
|
||||
$ _creatures w
|
||||
isHeavyCrNearLine _ _ _ = error "Testing whether creature is near empty line"
|
||||
. _creatures
|
||||
isHeavyCrNearLine _ _ = error "Testing whether creature is near empty line"
|
||||
{- | Adds the distance to the creature radius, tests whether the center is in
|
||||
the circle of this size centered at the point -}
|
||||
crsNearPoint :: Float -> Point2 -> World -> Bool
|
||||
crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w)
|
||||
crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures
|
||||
{- | Produce an unordered list of creatures on a line. -}
|
||||
crsOnLine :: Point2 -> Point2 -> World -> [Creature]
|
||||
crsOnLine p1 p2 w
|
||||
= IM.elems
|
||||
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
|
||||
$ _creatures w
|
||||
crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
|
||||
crsOnLine p1 p2
|
||||
= IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
|
||||
. _creatures
|
||||
{- | Produce an unordered list of creatures on a wide line. -}
|
||||
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
|
||||
crsOnThickLine thickness p1 p2 w
|
||||
= IM.elems
|
||||
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
|
||||
$ _creatures w
|
||||
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature
|
||||
crsOnThickLine thickness p1 p2
|
||||
= IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
|
||||
. _creatures
|
||||
{- | Find 'Maybe' the closest creature to a point, within a circle.
|
||||
-}
|
||||
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
|
||||
nearestCrInRad p r w
|
||||
nearestCrInRad p r
|
||||
= safeMinimumOn (dist p . _crPos)
|
||||
$ IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
|
||||
. IM.filter (\cr -> dist p (_crPos cr) < r)
|
||||
. _creatures
|
||||
{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape. -}
|
||||
nearestCrInTri
|
||||
:: Point2
|
||||
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
|
||||
-> Float -- ^ Distance.
|
||||
-> World -> Maybe Creature
|
||||
nearestCrInTri p dir x w
|
||||
nearestCrInTri p dir x
|
||||
= safeMinimumOn (dist p . _crPos)
|
||||
$ IM.filter (\cr -> pointInPolygon (_crPos cr) tri) $ _creatures w
|
||||
. IM.filter (\cr -> pointInPolygon (_crPos cr) tri)
|
||||
. _creatures
|
||||
where
|
||||
tri =
|
||||
[p
|
||||
@@ -400,9 +391,10 @@ nearestCrInFront
|
||||
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
|
||||
-> Float -- ^ Distance.
|
||||
-> World -> Maybe Creature
|
||||
nearestCrInFront p dir x w
|
||||
nearestCrInFront p dir x
|
||||
= safeMinimumOn (dist p . _crPos)
|
||||
$ IM.filter (\cr -> pointInPolygon (_crPos cr) rec) $ _creatures w
|
||||
. IM.filter (\cr -> pointInPolygon (_crPos cr) rec)
|
||||
. _creatures
|
||||
where
|
||||
rec = [p, pR, pR1, pL1, pL ]
|
||||
pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
|
||||
@@ -411,7 +403,7 @@ nearestCrInFront p dir x w
|
||||
pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
|
||||
{- | Test whether a creature is in a polygon. -}
|
||||
crInPolygon :: Creature -> [Point2] -> Bool
|
||||
crInPolygon cr = pointInPolygon (_crPos cr)
|
||||
crInPolygon = pointInPolygon . _crPos
|
||||
|
||||
{- | Transform coordinates from world position to screen coordinates. -}
|
||||
worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2
|
||||
@@ -494,4 +486,3 @@ dbArg f x = f x x
|
||||
-- TODO check whether this is simply the reader monad, flipped
|
||||
dbArgChain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b
|
||||
dbArgChain f g x = f x . g x
|
||||
|
||||
|
||||
+1
-2
@@ -21,8 +21,7 @@ splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardC
|
||||
& blocks . ix (_blID bl) . blHPs %~ tail
|
||||
& matSplintSound (_blMaterial bl) cen
|
||||
where
|
||||
wls = IM.restrictKeys (_walls w) (_blWallIDs bl)
|
||||
cen = centroid $ fmap (fst . _wlLine) wls
|
||||
cen = centroid $ fst . _wlLine <$> IM.restrictKeys (_walls w) (_blWallIDs bl)
|
||||
|
||||
unshadowBlock :: Int -> World -> World
|
||||
unshadowBlock wlid w = case w ^? walls . ix wlid of
|
||||
|
||||
@@ -23,7 +23,8 @@ import Data.Maybe
|
||||
import Data.List (scanl',sortOn)
|
||||
|
||||
combinationsTrie :: Trie (Int,CombineType) Item
|
||||
combinationsTrie = foldr (uncurry insertInTrie . first (sortOn snd))
|
||||
combinationsTrie = foldr
|
||||
(uncurry insertInTrie . first (sortOn snd))
|
||||
emptyTrie
|
||||
itemCombinations
|
||||
|
||||
|
||||
+5
-14
@@ -1,6 +1,5 @@
|
||||
module Dodge.Debug where
|
||||
import Dodge.Data
|
||||
import Dodge.Picture
|
||||
import Dodge.Picture.Layer
|
||||
import Dodge.Zone
|
||||
import Dodge.Base
|
||||
@@ -14,17 +13,8 @@ import qualified Data.IntSet as IS
|
||||
import Control.Lens
|
||||
|
||||
drawCircleAtFor :: Point2 -> Int -> World -> World
|
||||
drawCircleAtFor p t w = w & props %~
|
||||
IM.insert k Projectile
|
||||
{ _pjPos = p
|
||||
, _pjStartPos = p
|
||||
, _pjVel = V2 0 0
|
||||
, _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
|
||||
, _pjID = k
|
||||
, _pjUpdate = \_ -> pjTimerF t k
|
||||
}
|
||||
where
|
||||
k = IM.newKey $ _props w
|
||||
drawCircleAtFor p t = drawCircleAtForCol p t white
|
||||
|
||||
drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
|
||||
drawCircleAtForCol p t col w = w & props %~
|
||||
IM.insert k Projectile
|
||||
@@ -37,13 +27,14 @@ drawCircleAtForCol p t col w = w & props %~
|
||||
}
|
||||
where
|
||||
k = IM.newKey $ _props w
|
||||
|
||||
drawLineForCol :: [Point2] -> Int -> Color -> World -> World
|
||||
drawLineForCol ps t col w = w & props %~
|
||||
IM.insert k Projectile
|
||||
{ _pjPos = head ps
|
||||
, _pjStartPos = head ps
|
||||
, _pjVel = V2 0 0
|
||||
, _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ color col $ lineOfThickness 5 ps
|
||||
, _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ color col $ thickLine 5 ps
|
||||
, _pjID = k
|
||||
, _pjUpdate = \_ -> pjTimerF t k
|
||||
}
|
||||
@@ -66,7 +57,7 @@ debugWallZoningPic :: World -> Picture
|
||||
debugWallZoningPic w = setLayer 1 $ zonesPic `appendPic` wallsPic
|
||||
where
|
||||
wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls
|
||||
drawTheWall (a,b) = lineOfThickness 20 [a,b]
|
||||
drawTheWall (a,b) = thickLine 20 [a,b]
|
||||
theWalls = wallsAlongLine sp ep w
|
||||
zonesPic = setDepth 20 $ drawDDA zones
|
||||
zones = ddaExt zoneSize sp ep
|
||||
|
||||
+6
-12
@@ -39,12 +39,6 @@ import Control.Lens
|
||||
import qualified Data.Set as S
|
||||
import SDL
|
||||
|
||||
|
||||
--handleEvent :: Event -> Universe -> Maybe Universe
|
||||
--handleEvent e uv = case handleEvent' e (_uvWorld uv) of
|
||||
-- Nothing -> Nothing
|
||||
-- Just w -> Just $ uv & uvWorld .~ w
|
||||
|
||||
handleEvent :: Event -> Universe -> IO (Maybe Universe)
|
||||
handleEvent e = case eventPayload e of
|
||||
KeyboardEvent kev -> handleKeyboardEvent kev
|
||||
@@ -64,18 +58,18 @@ handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2
|
||||
P (V2 x y) = mouseMotionEventPos mmev
|
||||
|
||||
handleMouseButtonEvent :: MouseButtonEventData -> Universe -> Maybe Universe
|
||||
handleMouseButtonEvent mbev u = case mouseButtonEventMotion mbev of
|
||||
Released -> Just $ u & updateButtons S.delete
|
||||
Pressed -> handlePressedMouseButton thebutton $ u & updateButtons S.insert
|
||||
handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
|
||||
Released -> Just . updateButtons S.delete
|
||||
Pressed -> handlePressedMouseButton thebutton . updateButtons S.insert
|
||||
where
|
||||
thebutton = mouseButtonEventButton mbev
|
||||
updateButtons f = uvWorld . mouseButtons %~ f thebutton
|
||||
|
||||
{- | Sets window position in config. -}
|
||||
handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe
|
||||
handleWindowMoveEvent mev u = Just $ u
|
||||
& config . windowPosX .~ fromIntegral x
|
||||
& config . windowPosY .~ fromIntegral y
|
||||
handleWindowMoveEvent mev = Just
|
||||
. (config . windowPosX .~ fromIntegral x)
|
||||
. (config . windowPosY .~ fromIntegral y)
|
||||
where
|
||||
P (V2 x y) = windowMovedEventPosition mev
|
||||
|
||||
|
||||
@@ -96,5 +96,3 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk
|
||||
initialRoomTree :: RandomGen g => State g (Tree Room)
|
||||
initialRoomTree = do
|
||||
expandTree <$> mapM anoToRoomTree initialAnoTree
|
||||
|
||||
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
module Dodge.FloorItem
|
||||
(copyItemToFloor
|
||||
,copyItemToFloorID
|
||||
( copyItemToFloor
|
||||
, copyItemToFloorID
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
|
||||
+4
-5
@@ -2,7 +2,6 @@ module Dodge.Item
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Default
|
||||
import Dodge.Picture
|
||||
import Picture
|
||||
import Geometry.Data
|
||||
--import ShapePicture
|
||||
@@ -22,8 +21,8 @@ keyToken n = defaultEquipment
|
||||
keyPic :: Picture
|
||||
keyPic = color green $
|
||||
pictures [translate (-4) 0 $ thickCircle 4 2
|
||||
,lineOfThickness 2 $ map toV2 [(0,0),(8,0),(8,-4)]
|
||||
,lineOfThickness 2 $ map toV2 [(4,0),(4,-4)]
|
||||
,thickLine 2 $ map toV2 [(0,0),(8,0),(8,-4)]
|
||||
,thickLine 2 $ map toV2 [(4,0),(4,-4)]
|
||||
]
|
||||
|
||||
latchkey :: Int -> Item
|
||||
@@ -39,6 +38,6 @@ latchkey n = defaultEquipment
|
||||
latchkeyPic :: Picture
|
||||
latchkeyPic = color yellow $
|
||||
pictures [translate (-4) 0 $ thickCircle 4 2
|
||||
,lineOfThickness 2 $ map toV2 [(0,0),(8,0),(8,-4)]
|
||||
,lineOfThickness 2 $ map toV2 [(4,0),(4,-4)]
|
||||
,thickLine 2 $ map toV2 [(0,0),(8,0),(8,-4)]
|
||||
,thickLine 2 $ map toV2 [(4,0),(4,-4)]
|
||||
]
|
||||
|
||||
@@ -23,7 +23,6 @@ import Geometry
|
||||
import Picture
|
||||
import Shape
|
||||
import ShapePicture
|
||||
import Dodge.Picture
|
||||
import LensHelp
|
||||
|
||||
import Data.List
|
||||
@@ -214,8 +213,8 @@ mvLaser phasev pos dir w pt
|
||||
notseen ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws
|
||||
notseen _ _ = True
|
||||
pic = setLayer 1 $ pictures
|
||||
[ setDepth 19 . color (brightX 0 0.5 yellow) $ lineOfThickness 20 (pos:ps)
|
||||
, setDepth 19.5 . color (brightX 10 1 yellow) $ lineOfThickness 3 (pos:ps)
|
||||
[ setDepth 19 . color (brightX 0 0.5 yellow) $ thickLine 20 (pos:ps)
|
||||
, setDepth 19.5 . color (brightX 10 1 yellow) $ thickLine 3 (pos:ps)
|
||||
]
|
||||
|
||||
aTractorBeam :: Item -> Creature -> World -> World
|
||||
|
||||
@@ -6,7 +6,6 @@ module Dodge.Item.Weapon.Decoration
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Picture.Layer
|
||||
import Dodge.Picture
|
||||
import Geometry.Data
|
||||
import Picture
|
||||
|
||||
@@ -26,4 +25,4 @@ makeLaserScope p ep relFrac = Particle
|
||||
}
|
||||
where
|
||||
lineAlphaThick a w =
|
||||
color (withAlpha a $ mixColors relFrac (1-relFrac) red green) $ lineOfThickness w [p,ep]
|
||||
color (withAlpha a $ mixColors relFrac (1-relFrac) red green) $ thickLine w [p,ep]
|
||||
|
||||
+1
-1
@@ -65,7 +65,7 @@ putFloorTiles :: GenWorld -> GenWorld
|
||||
putFloorTiles gw = gw & gWorld . floorTiles .~ floorsFromGenWorld gw
|
||||
|
||||
setFloors :: GenWorld -> GenWorld
|
||||
setFloors gw = putFloorTiles $ setTiles gw
|
||||
setFloors = putFloorTiles . setTiles
|
||||
|
||||
-- note the order of traversal of the rooms is important
|
||||
-- hence the reverse
|
||||
|
||||
@@ -10,8 +10,7 @@ module Dodge.LightSource
|
||||
, lsPosRad
|
||||
, lsColPosID
|
||||
, makeTlsTimeRadColPos
|
||||
)
|
||||
where
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Geometry.Data
|
||||
import Dodge.Default
|
||||
|
||||
@@ -6,7 +6,6 @@ import Dodge.WorldEvent.Damage
|
||||
import Dodge.Base
|
||||
import Dodge.Zone
|
||||
import Dodge.Base.Collide
|
||||
import Dodge.Picture
|
||||
import Dodge.Particle.Spark
|
||||
import Dodge.WorldEvent.ThingsHit
|
||||
import Dodge.RandomHelp
|
||||
@@ -30,8 +29,8 @@ makeTeslaArcAt col pos dir = LinearParticle
|
||||
}
|
||||
drawTeslaArc :: Particle -> Picture
|
||||
drawTeslaArc pt = setLayer 1 $ pictures
|
||||
[ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ lineOfThickness 3 ps
|
||||
, setDepth 20 $ color (V4 0 0 0 0.5) $ lineOfThickness 10 ps
|
||||
[ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ thickLine 3 ps
|
||||
, setDepth 20 $ color (V4 0 0 0 0.5) $ thickLine 10 ps
|
||||
]
|
||||
where
|
||||
ps = _ptPoints pt
|
||||
|
||||
+1
-2
@@ -4,8 +4,7 @@ module Dodge.Path
|
||||
, makePathBetweenPs
|
||||
, removePathsCrossing
|
||||
, pairsToGraph
|
||||
)
|
||||
where
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Base.Collide
|
||||
import Dodge.Zone
|
||||
|
||||
@@ -6,30 +6,6 @@ module Dodge.Picture
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
|
||||
-- {- |
|
||||
-- Current thickness: 2 -}
|
||||
-- thickLine :: [Point2] -> Picture
|
||||
-- thickLine = lineOfThickness 2
|
||||
{- |
|
||||
Current thickness: 3 -}
|
||||
vThickLine :: [Point2] -> Picture
|
||||
vThickLine = lineOfThickness 3
|
||||
{- |
|
||||
Current thickness: 6 -}
|
||||
vvThickLine :: [Point2] -> Picture
|
||||
vvThickLine = lineOfThickness 6
|
||||
|
||||
-- shit this is ugly
|
||||
lineOfThickness :: Float -> [Point2] -> Picture
|
||||
lineOfThickness t = pictures . f
|
||||
where
|
||||
f (x:y:ys)
|
||||
| x == y = f (x:ys)
|
||||
| otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
|
||||
f _ = []
|
||||
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
|
||||
|
||||
wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
|
||||
wedgeOfThickness t x y
|
||||
| x == y = blank
|
||||
|
||||
@@ -7,7 +7,7 @@ import Control.Monad.State
|
||||
import Data.List
|
||||
|
||||
randomRanges :: (Random a,RandomGen g) => [a] -> State g a
|
||||
randomRanges xs = join $ takeOne $ f xs
|
||||
randomRanges = join . takeOne . f
|
||||
where
|
||||
f (x:y:ys) = state (randomR (x,y)) : f ys
|
||||
f _ = []
|
||||
@@ -51,12 +51,15 @@ shuffleTail :: RandomGen g => [a] -> State g [a]
|
||||
shuffleTail (x:xs) = (x :) <$> shuffle xs
|
||||
shuffleTail _ = undefined
|
||||
|
||||
-- select elements from a list randomly
|
||||
-- each element has the same independent chance of being selected
|
||||
randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a]
|
||||
randomSelectionFromList p = filterM $ const $ randProb p
|
||||
randomSelectionFromList = filterM . const . randProb
|
||||
|
||||
randProb :: RandomGen g => Float -> State g Bool
|
||||
randProb p = do p1 <- state $ randomR (0,1)
|
||||
return (p1 < p)
|
||||
randProb p = do
|
||||
p1 <- state $ randomR (0,1)
|
||||
return (p1 < p)
|
||||
|
||||
randInCirc :: RandomGen g => Float -> State g Point2
|
||||
randInCirc maxRad = do
|
||||
|
||||
@@ -158,4 +158,3 @@ soundMultiFrom (so:sos) pos sType mtime w
|
||||
{- | Sets '_soundTime' to 0. -}
|
||||
stopSoundFrom :: SoundOrigin -> World -> World
|
||||
stopSoundFrom so = over (playingSounds . ix so . soundTime) (fmap $ min 0)
|
||||
|
||||
|
||||
@@ -103,7 +103,8 @@ pushOutFromWall rad cp2 (wp1,wp2)
|
||||
isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
|
||||
|
||||
pushOutFromCorners :: Float -> [(Point2,Point2)] -> Point2 -> Point2
|
||||
pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls
|
||||
--pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls
|
||||
pushOutFromCorners r = flip $ foldr (squashIntersectCirclePoint r . fst)
|
||||
|
||||
squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
|
||||
squashIntersectCirclePoint rad p cCen
|
||||
|
||||
@@ -3,8 +3,7 @@ module Dodge.WorldEvent.Sound
|
||||
, mkSoundSplinterGlass
|
||||
, mkSoundSplinterBlock
|
||||
, originIDsAt
|
||||
)
|
||||
where
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.SoundLogic
|
||||
import Sound.Data
|
||||
@@ -20,10 +19,13 @@ originIDsAt so sids p w = soundStart so p sid Nothing $ set randGen g w
|
||||
(sid,g) = _randGen w & runState (takeOne sids)
|
||||
|
||||
mkSoundBreakGlass :: Point2 -> World -> World
|
||||
mkSoundBreakGlass = originIDsAt (GlassBreakSound 0) [glassShat1S,glassShat2S,glassShat3S,glassShat4S]
|
||||
mkSoundBreakGlass = originIDsAt (GlassBreakSound 0)
|
||||
[glassShat1S,glassShat2S,glassShat3S,glassShat4S]
|
||||
|
||||
mkSoundSplinterGlass :: Point2 -> World -> World
|
||||
mkSoundSplinterGlass = originIDsAt (GlassBreakSound 1) [smallGlass1S,smallGlass2S,smallGlass3S,smallGlass4S]
|
||||
mkSoundSplinterGlass = originIDsAt (GlassBreakSound 1)
|
||||
[smallGlass1S,smallGlass2S,smallGlass3S,smallGlass4S]
|
||||
|
||||
mkSoundSplinterBlock :: Point2 -> World -> World
|
||||
mkSoundSplinterBlock = originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S,impact4S]
|
||||
mkSoundSplinterBlock = originIDsAt (BlockDegradeSound 1)
|
||||
[impact1S,impact2S,impact3S,impact4S]
|
||||
|
||||
@@ -19,7 +19,7 @@ import Geometry
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
--import Data.Bifunctor
|
||||
import Data.Bifunctor
|
||||
{- List those objects that appear on a line. -}
|
||||
thingsHit
|
||||
:: Point2 -- ^ Line start point
|
||||
@@ -34,16 +34,11 @@ thingsHit sp ep w
|
||||
(\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
|
||||
. IM.elems
|
||||
$ _creatures w
|
||||
hitWls = wallsOnLine sp ep
|
||||
wls = map (second Right) . IM.elems $ wallsOnLineHit sp ep
|
||||
$ IM.unions [f b $ f a $ _znObjects $ _wallsZone w
|
||||
| a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
|
||||
-- $ _walls w
|
||||
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls)
|
||||
hitPoint w' = uncurry (intersectSegSeg sp ep) (_wlLine w')
|
||||
f i = fromMaybe IM.empty . IM.lookup i
|
||||
thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
|
||||
thingHit sp ep = listToMaybe . thingsHit sp ep
|
||||
{- List objects that appear on a line.
|
||||
@@ -69,16 +64,12 @@ wallsHit sp ep w
|
||||
| sp == ep = []
|
||||
| otherwise = sortOn (dist sp . fst) wls
|
||||
where
|
||||
hitWls = wallsOnLine sp ep
|
||||
wls = IM.elems $ wallsOnLineHit sp ep
|
||||
$ IM.unions [f b $ f a $ _znObjects $ _wallsZone w
|
||||
| a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
|
||||
-- $ _walls w
|
||||
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
wls = zip (map (fromJust . hitPoint) hitWls) hitWls
|
||||
hitPoint w' = uncurry (intersectSegSeg sp ep) (_wlLine w')
|
||||
f i = fromMaybe IM.empty . IM.lookup i
|
||||
|
||||
thingsHitExceptCrLongLine
|
||||
:: Maybe Int
|
||||
@@ -96,13 +87,10 @@ thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, Either Creature Wall
|
||||
thingsHitLongLine sp ep w
|
||||
| sp == ep = []
|
||||
| otherwise = sortOn (dist sp . fst) (crs ++ wls)
|
||||
where
|
||||
where
|
||||
crs = mapMaybe
|
||||
(\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
|
||||
. IM.elems
|
||||
$ _creatures w
|
||||
-- $ creaturesAlongLine sp ep w
|
||||
wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls)
|
||||
--hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
|
||||
hitWls = wallsOnLine sp ep $ _walls w
|
||||
hitPoint wl = uncurry (intersectSegSeg sp ep) (_wlLine wl)
|
||||
wls = map (second Right) . IM.elems $ wallsOnLineHit sp ep $ _walls w
|
||||
|
||||
+3
-2
@@ -253,9 +253,10 @@ thickLine t = pictures . f
|
||||
where
|
||||
f (x:y:ys)
|
||||
| x == y = f (x:ys)
|
||||
| otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
|
||||
| otherwise = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y:ys)
|
||||
where
|
||||
n = (t*0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
|
||||
f _ = []
|
||||
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
|
||||
|
||||
thickLineCol :: Float -> [(Point2,RGBA)] -> Picture
|
||||
{-# INLINE thickLineCol #-}
|
||||
|
||||
Reference in New Issue
Block a user